Merge pull request #514 from R-Lum/issue_480_p1

Add the replace_metadata<-() method for the Risoe.BINfileData class

Author: RLumSK

DESCRIPTION

@@ -93,6 +93,7 @@ Collate:
     'RLum.Data.Image-class.R'
     'RLum.Data.Spectrum-class.R'
     'RLum.Results-class.R'
+    'metadata.R'
     'set_Risoe.BINfileData.R'
     'get_Risoe.BINfileData.R'
     'Risoe.BINfileData-class.R'

NAMESPACE

@@ -71,6 +71,7 @@ S3method(summary,RLum.Data.Curve)
 S3method(summary,RLum.Data.Image)
 S3method(summary,RLum.Results)
 S3method(unlist,RLum.Analysis)
+export("replace_metadata<-")
 export(Analyse_SAR.OSLdata)
 export(CW2pHMi)
 export(CW2pLM)
@@ -224,6 +225,7 @@ exportClasses(RLum.Data.Image)
 exportClasses(RLum.Data.Spectrum)
 exportClasses(RLum.Results)
 exportClasses(Risoe.BINfileData)
+exportMethods("replace_metadata<-")
 exportMethods(bin_RLum.Data)
 exportMethods(get_RLum)
 exportMethods(get_Risoe.BINfileData)

NEWS.Rmd

@@ -27,6 +27,9 @@ and `RLum.Analysis-class` objects and lists of such objects.
 * `merge_RLum.Data.Spectrum()`: This new function allows to merge two or
 more `RLum.Data.Spectrum` objects in different ways (#368, fixed in #419).
 
+* `replace_metadata()`: This function allows to manipulate the metadata of
+a `Risoe.BINfileData` object (#480, fixed in #514).
+
 * `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

@@ -5,7 +5,7 @@
 
 <!-- NEWS.md was auto-generated by NEWS.Rmd. Please DO NOT edit by hand!-->
 
-# Changes in version 0.9.26.9000-82 (2024-12-04)
+# Changes in version 0.9.26.9000-82 (2024-12-05)
 
 ## New functions
 
@@ -28,6 +28,9 @@
   more `RLum.Data.Spectrum` objects in different ways (#368, fixed in
   \#419).
 
+- `replace_metadata()`: This function allows to manipulate the metadata
+  of a `Risoe.BINfileData` object (#480, fixed in \#514).
+
 - `view()`: Provides a shortcut to the `utils::View()` spreadsheet-like
   data viewer tailored to the objects in the package (#489, fixed in
   \#490).

R/Risoe.BINfileData-class.R

@@ -1,4 +1,4 @@
-#' @include get_Risoe.BINfileData.R set_Risoe.BINfileData.R view.R
+#' @include get_Risoe.BINfileData.R set_Risoe.BINfileData.R metadata.R view.R
 NULL
 
 #' Class `"Risoe.BINfileData"`
@@ -445,6 +445,68 @@ setMethod("get_Risoe.BINfileData",
           }
 )
 
+# replace_metadata() --------------------------------------------------------
+#' @describeIn Risoe.BINfileData
+#' Replaces metadata of [Risoe.BINfileData-class] objects
+#'
+#' @param object an object of class [Risoe.BINfileData-class]
+#'
+#' @param info_element [character] (**required**) name of the metadata field
+#' to replace
+#'
+#' @param subset [expression] (*optional*) logical expression to limit the
+#' substitution only to the selected subset of elements
+#'
+#' @param value (**required**) The value assigned to the selected elements
+#' of the metadata field.
+#'
+#' @keywords internal
+#'
+#' @md
+#' @export
+setMethod("replace_metadata<-",
+          signature= "Risoe.BINfileData",
+          definition = function(object, info_element, subset = NULL, value) {
+            .set_function_name("replace_metadata")
+            on.exit(.unset_function_name(), add = TRUE)
+
+            ## Integrity checks ---------------------------------------------
+
+            .validate_class(info_element, "character")
+            valid.names <- colnames(object@METADATA)
+            if (!info_element %in% valid.names) {
+              .throw_error("'info_element' not recognised")
+            }
+
+            ## select relevant rows
+            sel <- TRUE
+            if (!is.null(substitute(subset))) {
+              sel <- tryCatch(eval(
+                  expr = substitute(subset),
+                  envir = object@METADATA,
+                  enclos = parent.frame()
+              ), error = function(e) {
+                .throw_error("Invalid 'subset' expression, valid terms are: ",
+                             .collapse(valid.names, quote = FALSE))
+              })
+              if (!is.logical(sel)) {
+                .throw_error("'subset' should contain a logical expression")
+              }
+              if (all(is.na(sel))) {
+                sel <- FALSE
+              }
+              if (!any(sel)) {
+                .throw_message("'subset' expression produced an ",
+                               "empty selection, nothing done")
+                return(object)
+              }
+            }
+
+            object@METADATA[sel, info_element] <- value
+            assign(x = deparse(substitute(object))[1], object)
+          })
+
+
 # view () -----------------------------------------------------------------------
 #'@describeIn Risoe.BINfileData
 #'View method for [Risoe.BINfileData-class] objects

R/metadata.R

@@ -0,0 +1,20 @@
+#' @title Safe replacement of object metadata
+#'
+#' @description
+#' Generic function for replacement of object metadata.
+#'
+#' @param object (**required**) object to manipulate
+#'
+#' @param ... further arguments passed to the function
+#'
+#' @param value the value assigned
+#'
+#' @author
+#' Marco Colombo, Institute of Geography, Heidelberg University (Germany)
+#'
+#' @keywords utilities
+#'
+#' @md
+#' @export
+setGeneric("replace_metadata<-",
+           function (object, ..., value) standardGeneric("replace_metadata<-"))

man/Risoe.BINfileData-class.Rd

@@ -0,0 +1,37 @@
+## load data
+bin.v8 <- system.file("extdata/BINfile_V8.binx", package = "Luminescence")
+risoe <- read_BIN2R(bin.v8, verbose = FALSE)
+
+test_that("input validation", {
+  testthat::skip_on_cran()
+
+  expect_error(replace_metadata(risoe, "error") <- 1,
+               "'info_element' not recognised")
+  expect_error(replace_metadata(risoe, "SEL", subset = error == 99) <- 0,
+               "Invalid 'subset' expression, valid terms are")
+  expect_error(replace_metadata(risoe, "SEL", subset = ID + 99) <- 0,
+               "'subset' should contain a logical expression")
+  expect_message(replace_metadata(risoe, "SEL", subset = ID == 99) <- 0,
+                 "'subset' expression produced an empty selection, nothing done")
+  expect_message(replace_metadata(risoe, "SEL", subset = ID == NA) <- 0,
+                 "'subset' expression produced an empty selection, nothing done")
+})
+
+test_that("check functionality", {
+  testthat::skip_on_cran()
+
+  ## Risoe.BINfileData
+  res <- risoe
+  replace_metadata(res, "SEL") <- FALSE
+  expect_equal(res@METADATA$SEL,
+               rep(FALSE, nrow(res@METADATA)))
+  replace_metadata(res, "LTYPE", subset = SET == 2 & POSITION == 1) <- "OSL"
+  expect_equal(res@METADATA$LTYPE,
+               c("OSL", "TL"))
+
+  ## the original object is unchanged
+  expect_equal(risoe@METADATA$SEL,
+               rep(TRUE, nrow(res@METADATA)))
+  expect_equal(risoe@METADATA$LTYPE,
+               rep("TL", nrow(res@METADATA)))
+})