R/Risoe.BINfileData2RLum.Analysis.R

In Luminescence: Comprehensive Luminescence Dating Data Analysis

#' @title Convert Risoe.BINfileData object to an RLum.Analysis object
#'
#' @description
#' Converts values from one specific position of a [Luminescence::Risoe.BINfileData-class]
#' object to an [Luminescence::RLum.Analysis-class] object.
#'
#' The [Luminescence::RLum.Analysis-class] object requires a set of curves for
#' specific further protocol analyses. However, the [Luminescence::Risoe.BINfileData-class]
#' usually contains a set of curves for different aliquots and different
#' protocol types that may be mixed up. Therefore, a conversion is needed.
#'
#' @param object [Luminescence::Risoe.BINfileData-class] (**required**):
#' object to convert.
#'
#' @param pos [numeric] (*optional*):
#' position number of the `Risoe.BINfileData` object for which the curves are
#' converted into an [Luminescence::RLum.Analysis-class] object.
#' If `length(pos) > 1`, a list of `RLum.Analysis` objects is returned.
#' If nothing is provided every position will be converted.
#' If the position is not valid `NULL` is returned.
#'
#' @param grain [vector], [numeric] (*optional*):
#' grain number from the measurement to limit the converted data set
#' (e.g., `grain = 1:48`). Please be aware that this option may lead to
#' unwanted effects, as the output is strictly limited to the chosen grain
#' number for all position numbers. Invalid grain numbers are skipped with a
#' warning. Records with `NA` as grain are always included, as some readers
#' report `NA` instead of a grain number.
#'
#' @param run [vector], [numeric] (*optional*):
#' run number from the measurement to limit the converted data set
#' (e.g., `run = 1:48`).
#'
#' @param set [vector], [numeric] (*optional*):
#' set number from the measurement to limit the converted data set
#' (e.g., `set = 1:48`).
#'
#' @param ltype [vector], [character] (*optional*):
#' curve type to limit the converted data. Commonly allowed values are:
#' `"IRSL"`, `"OSL"`, `"TL"`, `"RIR"`, `"RBR"` and `"USER"`
#' (see also [Luminescence::Risoe.BINfileData-class]).
#'
#' @param dtype [vector], [character] (*optional*):
#' data type to limit the converted data. Commonly allowed values are
#' listed in [Luminescence::Risoe.BINfileData-class].
#'
#' @param protocol [character] (*optional*):
#' protocol type to be set in the analysis object. This value may be used by
#' subsequent analysis functions.
#'
#' @param keep.empty [logical] (*with default*):
#' If `TRUE` (default) an `RLum.Analysis` object is returned even if it does
#' not contain any records. Set to `FALSE` to discard all empty objects.
#'
#' @param txtProgressBar [logical] (*with default*):
#' enable/disable the progress bar. The progress bar is disabled automatically
#' if fewer than two positions are converted.
#'
#' @return
#' Returns an [Luminescence::RLum.Analysis-class] object if exactly one
#' position and one grain number were converted, and a list of `RLum.Analysis`
#' objects (one per position/grain combination) otherwise. Returns `NULL` if
#' no valid position is provided or if all objects are discarded by
#' `keep.empty = FALSE`.
#'
#' @note
#' The `protocol` argument of the [Luminescence::RLum.Analysis-class]
#' object is set to 'unknown' if not stated otherwise.
#'
#' @section Function version: 0.4.3
#'
#' @author
#' Sebastian Kreutzer, F2.1 Geophysical Parametrisation/Regionalisation, LIAG - Institute for Applied Geophysics (Germany)
#'
#' @seealso [Luminescence::Risoe.BINfileData-class], [Luminescence::RLum.Analysis-class],
#' [Luminescence::read_BIN2R]
#'
#' @keywords manip
#'
#' @examples
#'
#' ##load data
#' data(ExampleData.BINfileData, envir = environment())
#'
#' ##convert values for position 1
#' Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos = 1)
#'
#' @export
Risoe.BINfileData2RLum.Analysis<- function(
  object,
  pos = NULL,
  grain = NULL,
  run = NULL,
  set = NULL,
  ltype = NULL,
  dtype = NULL,
  protocol = "unknown",
  keep.empty = TRUE,
  txtProgressBar = FALSE
) {
  .set_function_name("Risoe.BINfileData2RLum.Analysis")
  on.exit(.unset_function_name(), add = TRUE)

  ## Integrity checks -------------------------------------------------------
  .validate_class(object, "Risoe.BINfileData")
  .validate_class(pos, c("numeric", "integer"), null.ok = TRUE)

  ## check that all required columns are available
  sel.cols <- c("ID", "POSITION", "GRAIN", "RUN", "SET", "LTYPE", "DTYPE")
  if (!all(sel.cols %in% colnames(object@METADATA))) {
    .throw_error("'object' has missing columns in METADATA: ",
                 .collapse(setdiff(sel.cols, colnames(object@METADATA))))
  }

  positions.valid <- unique(object@METADATA[["POSITION"]])
  if (is.null(pos)) {
    pos <- positions.valid
  } else if (length(setdiff(pos, positions.valid)) > 0) {
    ## remove invalid positions from the input
      .throw_warning("Invalid position number skipped: ",
                     .collapse(setdiff(pos, positions.valid), quote = FALSE))
      pos <- intersect(pos, positions.valid)
  }

  # Grep run and set data ---------------------------------------------------

  ## grain
  grain.valid <- unique(object@METADATA[["GRAIN"]])
  if (is.null(grain)) {
    grain <- grain.valid
  } else if (length(setdiff(grain, grain.valid)) > 0) {
        .throw_warning("Invalid grain number skipped: ",
                       .collapse(setdiff(grain, grain.valid), quote = FALSE))
        grain <- intersect(grain, grain.valid)
  }

  ## run
  run.valid <- unique(object@METADATA[["RUN"]])
  if (is.null(run)) {
    run <- run.valid
  } else if (length(setdiff(run, run.valid)) > 0) {
      .throw_error("'run' contains invalid runs, valid runs are: ",
                   .collapse(run.valid, quote = FALSE))
  }

  ## set
  set.valid <- unique(object@METADATA[["SET"]])
  if (is.null(set)) {
    set <- set.valid
  } else if (length(setdiff(set, set.valid)) > 0) {
      .throw_error("'set' contains invalid sets, valid sets are: ",
                   .collapse(set.valid, quote = FALSE))
  }

  ## ltype
  ltype.valid <- unique(object@METADATA[["LTYPE"]])
  if (is.null(ltype)) {
    ltype <- ltype.valid
  } else if (length(setdiff(ltype, ltype.valid)) > 0) {
      .throw_error("'ltype' contains invalid ltypes, valid ltypes are: ",
                   .collapse(ltype.valid, quote = TRUE))
  }

  ## dtype
  dtype.valid <- unique(object@METADATA[["DTYPE"]])
  if (is.null(dtype)) {
    dtype <- dtype.valid
  } else if (length(setdiff(dtype, dtype.valid)) > 0) {
      .throw_error("'dtype' contains invalid dtypes, valid dtypes are: ",
                   .collapse(dtype.valid, quote = TRUE))
  }

  ## Select values and convert them -----------------------------------------

  ## switch off the progress bar if only one position is provided
  if (txtProgressBar && length(pos) < 2) {
    txtProgressBar <- FALSE
  }

  ## set progress bar
  if (txtProgressBar) {
    pb <- txtProgressBar(min = min(pos), max = max(pos), char = "=", style = 3)
  }

    ##This loop does:
    ## (a) iterating over all possible positions
    ## (b) consider grains in all possible positions
    ## (c) consider other selections
    ## (d) create the RLum.Analysis objects

  ## convert metadata object to data.table
  metadata.dt <- as.data.table(object@METADATA[, sel.cols])

  ## silence notes raised by R CMD check
  POSITION <- GRAIN <- RUN <- SET <- LTYPE <- DTYPE <- ID <- NULL

  object <- lapply(pos, function(pos) {

      ##update progress bar
      if(txtProgressBar){
        setTxtProgressBar(pb, value = pos)
      }

    ## loop over the grains and produce RLum.Analysis objects
    object <- lapply(grain, function(grain) {

        ## select data
        ## the NA check for grain is necessary as FI readers like to report
        ## NA instead of 0 in that column, and this causes some trouble
        temp_id <- metadata.dt[POSITION == pos &
                               (is.na(GRAIN) | GRAIN == grain) &
                               RUN %in% run & LTYPE %in% ltype &
                               SET %in% set & DTYPE %in% dtype,
                               ID]

        ## if the input object is empty, bypass the creation of curve objects
        if (length(object@DATA) == 0) {
          message("Empty Risoe.BINfileData object detected")
          records <- list()
        } else {
          ## create curve object
          records <- lapply(temp_id, function(x) {
            ## skip ROI information
            if (!is.null(object@METADATA[["RECTYPE"]]) &&
                object@METADATA[["RECTYPE"]][x] == 128)
              set_RLum(class = "RLum.Data.Curve")
            else
              .Risoe.BINfileData2RLum.Data.Curve(object, id = x)
          })
        }

        if (!keep.empty && length(records) == 0)
          return(NULL)

        ## create the RLum.Analysis object
        object <- set_RLum(
          class = "RLum.Analysis",
          records = records,
          protocol = protocol,
          originator = "Risoe.BINfileData2RLum.Analysis"
        )

        ## add unique id of RLum.Analysis object to each curve
        .set_pid(object)
        return(object)
      })

      return(object)
    })

  ## if only one element is included, output an RLum.Analysis object, not a list
  if (length(object) == 1 && length(object[[1]]) == 1)
    return(invisible(object[[1]][[1]]))

  return(invisible(unlist(object)))
}