R/read_PSL2R.R

In Luminescence: Comprehensive Luminescence Dating Data Analysis

#' @title Import SUERC portable OSL Reader PSL files into R
#'
#' @description
#' This function provides an import routine for the SUERC portable OSL Reader
#' PSL format (measurement data and sequence). PSL files are just plain text
#' and can be viewed with any text editor. Due to the formatting of PSL files,
#' this import function relies heavily on regular expression to find and
#' extract all relevant information. See **note**.
#'
#' @param file [character] (**required**):
#' name of one or multiple PSL files (URLs are supported); it can be the path
#' to a directory, in which case the function tries to detect and import all
#' PSL files found in the directory.
#'
#' @param drop_bg [logical] (*with default*):
#' `TRUE` to automatically remove all non-OSL/IRSL curves.
#'
#' @param as_decay_curve  [logical] (*with default*):
#' Portable OSL Reader curves are often given as cumulative light sum curves.
#' Use `TRUE` (default) to convert the curves to the more usual decay form.
#'
#' @param smooth [logical] (*with default*):
#' `TRUE` to apply Tukey's Running Median Smoothing for OSL and IRSL decay curves.
#' Smoothing is encouraged if you see random signal drops within the decay curves related
#' to hardware errors.
#'
#' @param merge [logical] (*with default*):
#' `TRUE` to merge all [Luminescence::RLum.Analysis-class] objects. Only applicable if multiple
#' files are imported.
#'
#' @param pattern [character] (*with default*):
#' regular expression pattern passed to [list.files] to construct a list of
#' files to read (used only when a path is provided).
#'
#' @param verbose [logical] (*with default*):
#' enable/disable output to the terminal.
#'
#' @param ... currently not used.
#'
#' @return
#' Returns an S4 [Luminescence::RLum.Analysis-class] object containing
#' [Luminescence::RLum.Data.Curve-class] objects for each curve. Results are
#' returned as a list when multiple files are processed or `file` is a list.
#'
#' @seealso [Luminescence::RLum.Analysis-class], [Luminescence::RLum.Data.Curve-class],
#' [Luminescence::RLum.Data.Curve-class]
#'
#' @author Christoph Burow, University of Cologne (Germany)\cr
#' Sebastian Kreutzer, F2.1 Geophysical Parametrisation/Regionalisation, LIAG - Institute for Applied Geophysics (Germany)\cr
#'
#' @section Function version: 0.1.2
#'
#' @note
#' Because this function relies heavily on regular expressions to parse
#' PSL files it is currently only in beta status. If the routine fails to import
#' a specific PSL file please report to `<christoph.burow@@gmx.net>` so the
#' function can be updated.
#'
#' @keywords IO
#'
#' @examples
#'
#' # (1) Import PSL file to R
#'
#' file <- system.file("extdata", "DorNie_0016.psl", package = "Luminescence")
#' psl <- read_PSL2R(file, drop_bg = FALSE, as_decay_curve = TRUE, smooth = TRUE, merge = FALSE)
#' print(str(psl, max.level = 3))
#' plot(psl, combine = TRUE)
#'
#' @export
read_PSL2R <- function(
  file,
  drop_bg = FALSE,
  as_decay_curve = TRUE,
  smooth = FALSE,
  merge = FALSE,
  pattern = "\\.psl$",
  verbose = TRUE,
  ...
) {
  .set_function_name("read_PSL2R")
  on.exit(.unset_function_name(), add = TRUE)

  ## Integrity checks -------------------------------------------------------
  .validate_logical_scalar(verbose)
  .validate_class(pattern, "character", length = 1)
  file <- unlist(.validate_file(file, ext = "psl", pattern = pattern, verbose = verbose))
  if (length(file) == 0) {
    return(NULL)
  }
  if (!all(file.exists(file)))
    .throw_error("The following files do not exist, please check:\n",
                 paste(file[!file.exists(file)], collapse = "\n"))

  ## MAIN ----
  results <- vector("list", length(file))
  for (i in 1:length(file)) {

    if (verbose) {
      cat("\n[read_PSL2R()] Importing ...")
      cat("\n path: ", dirname(file[i]))
      cat("\n file: ", .shorten_filename(basename(file[i])))
      cat("\n")
    }

    ## Read in file ----
    doc <- readLines(file[i])

    ## Document formatting ----
    # remove lines with i) blanks only, ii) dashes, iii) equal signs
    doc <- gsub("^[ ]*$", "", doc)
    doc <- gsub("^[ -]*$", "", doc)
    doc <- gsub("^[ =]*$", "", doc)

    # the header ends with date and time with the previous line starting with a single slash
    lines_with_slashes <- doc[grepl("\\", doc, fixed = TRUE)]

    ## OFFENDING LINE: this deletes the line with sample name and time and date
    sample_and_date <- lines_with_slashes[length(lines_with_slashes)]
    sample_date_split <- strsplit(sample_and_date, "@", fixed = TRUE)[[1]]
    sample <- trimws(gsub("\\", "", sample_date_split[1], fixed = TRUE))
    date_and_time <- strsplit(sample_date_split[2], " ")[[1]]
    date_and_time_clean <- date_and_time[nzchar(date_and_time) &
                                         !date_and_time %in% c("/", "AM", "PM")]
    date <- as.Date(date_and_time_clean[1], "%m/%d/%Y")
    time <- format(date_and_time_clean[2], format = "%h:%M:%S")
    doc <- gsub(lines_with_slashes[length(lines_with_slashes)],
                "", fixed = TRUE, doc)

    # last delimiting line before measurements are only apostrophes and dashes
    lines_with_apostrophes <-doc[grepl("'", doc, fixed = TRUE)]
    doc <- gsub(lines_with_apostrophes[length(lines_with_apostrophes)],
                "", fixed = TRUE, doc)

    # finally remove all empty lines
    doc <- doc[nzchar(doc)]

    ## Split document ----
    begin_of_measurements <- grep("Measurement :", doc, fixed = TRUE)
    number_of_measurements <- length(begin_of_measurements)

    # Parse and format header
    header <- doc[1:(begin_of_measurements[1]-1)]
    header <- format_Header(header)

    # add sample name, date and time to header list
    header$Date <- date
    header$Time <- time
    header$Sample <- sample

    # Parse and format the measurement values
    measurements_split <- vector("list", number_of_measurements)

    # save lines of each measurement to individual list elements
    for (j in seq_len(number_of_measurements)) {
      last <- min(begin_of_measurements[j + 1] - 1, length(doc), na.rm = TRUE)
      measurements_split[[j]] <- doc[begin_of_measurements[j]:last]
    }

    # format each measurement; this will return a list of RLum.Data.Curve objects
    measurements_formatted <- lapply(measurements_split, format_Measurements,
                                     convert = as_decay_curve, header = header)

    # drop dark count measurements if needed
    if (drop_bg) {
      measurements_formatted <- lapply(measurements_formatted, function(x) {
        if (x@recordType != "USER")
          return(x)
      })
      measurements_formatted <- .rm_NULL_elements(measurements_formatted)
    }

    # decay curve smoothing using Tukey's Running Median Smoothing (?smooth)
    if (smooth) {
      measurements_formatted <- lapply(measurements_formatted, function(x) {
        if (x@recordType != "USER")
          x@data[, 2] <- stats::smooth(x@data[, 2])
        return(x)
      })
    }

    ## get measurement sequence
    measurement_sequence <- data.table::rbindlist(
      lapply(seq_along(measurements_split), function(x) {
      ## remove measurement
      tmp <- gsub(
        pattern = "Measurement : ",
        replacement = "",
        x = measurements_split[[x]][1],
        fixed = TRUE)

    ## split entries
     tmp <- strsplit(x = tmp, split = " | ", fixed = TRUE)[[1]]

     ## data.frame
     data.frame(
       RUN = x,
       NAME = trimws(tmp[1]),
       STIM = strsplit(tmp[2], split = " ", fixed = TRUE)[[1]][2],
       ON_OFF = strsplit(tmp[3], split = "(us)", fixed = TRUE)[[1]][2],
       CYCLE = strsplit(tmp[4], split = "(ms),", fixed = TRUE)[[1]][2])
    }))

    ## RETURN ----
    results[[i]] <- set_RLum(
      "RLum.Analysis",
       protocol = "portable OSL",
       info = c(
         header,
         list(Sequence = as.data.frame(measurement_sequence))),
       records = measurements_formatted)
  }#Eof::Loop

  ## MERGE ----
  if (length(results) > 1 && merge)
    results <- merge_RLum(results)

  ## RETURN ----
  if (length(results) == 1)
    results <- results[[1]]

  return(results)
}

################################################################################
## HELPER FUNCTIONS
################################################################################


## ------------------------- FORMAT MEASUREMENT ----------------------------- ##
format_Measurements <- function(x, convert, header) {
  ## measurement parameters are given in the first line
  settings <- x[1]
  settings_split <- trimws(unlist(strsplit(settings, "|", fixed = TRUE)))

  # welcome to regex/strsplit hell
  grepvf <- function(pattern, x) grep(pattern, x, value = TRUE, fixed = TRUE)
  settings_measurement <- gsub(".*: ", "", grepvf("Measure", settings_split))
  settings_stim_unit <- gsub("[^0-9]", "", grepvf("Stim", settings_split))
  recordType <- switch(settings_stim_unit,
                       "0" = "USER", "1" = "IRSL", "2" = "OSL")
  on_off_times <- strsplit(gsub("[^0-9,]", "", grepvf("Off", settings_split)), ",")[[1]]
  settings_on_time <- as.integer(on_off_times[1])
  settings_off_time <- as.integer(on_off_times[2])
  vals <- stats::na.omit(as.integer(strsplit(
                     gsub("[^0-9,]", "", grepvf("No", settings_split)), ",")[[1]]))
  settings_cycle <- vals[1]
  settings_stimulation_time <- vals[2]

  settings_list <- list(measurement = settings_measurement,
                        stimulation_unit = recordType,
                        on_time = settings_on_time,
                        off_time = settings_off_time,
                        cycle = settings_cycle,
                        stimulation_time = settings_stimulation_time)

  ## terminal counts are given in the last line as count / count_error
  # terminal_count_text_formatted <- gsub("[^0-9]", "",
  #                                       unlist(strsplit(x[length(x)], "/")))

  ## parse values and create a data frame
  x_stripped <- x[-c(1, 2, length(x))]
  df <- data.frame(matrix(NA, ncol = 5, nrow = length(x_stripped)))
  for (i in 1:length(x_stripped)) {
    x_split <- unlist(strsplit(x_stripped[i], " ", fixed = TRUE))
    x_split <- x_split[nzchar(x_split)]
    x_split_clean <- gsub("[^0-9\\-]", "", x_split)
    x_split_cleaner <- x_split_clean[x_split_clean != "-"]

    df[i, ] <- as.numeric(x_split_cleaner)
  }

  names(df) <- c("time", "counts", "counts_error",
                 "counts_per_cycle", "counts_per_cycle_error")

  # shape of the curve: decay or cumulative
  if (convert)
    data <- matrix(c(df$time, df$counts_per_cycle), ncol = 2)
  else
    data <- matrix(c(df$time, df$counts), ncol = 2)

  set_RLum(
    class = "RLum.Data.Curve",
    originator = "read_PSL2R",
    recordType = paste(recordType, "(PMT)"),
    curveType = "measured",
    data = data,
    info = list(settings = c(settings_list, header),
    raw_data = df))
}

## ---------------------------- FORMAT HEADER ------------------------------- ##
format_Header <- function(x) {
  # split by double blanks
  header_split <- strsplit(x, "  ", fixed = TRUE)

  # check whether there are twice as many values
  # as colons; if there is an equal amount, the previous split was not sufficient
  # and we need to further split by a colon (that is followed by a blank)
  header_split_clean <- lapply(header_split, function(x) {
    x <- x[nzchar(x)]
    n_elements <- length(x)
    n_properties <- length(grep(":", x, fixed = TRUE))

    if (n_elements == n_properties)
      x <- unlist(strsplit(x, ": ", fixed = TRUE))

    return(x)
  })

  # format parameter/settings names and corresponding values
  dt <- rbindlist(lapply(header_split_clean, function(header) {
    idx <- seq(1, length(header), 2)
    data.frame(names = header[idx], values = header[idx + 1])
  }))

  # some RegExing for nice reading
  names <- gsub(":$", "", dt$names, perl = TRUE) |> trimws()
  # for some weird reason "offset subtract" starts with '256 '
  names <- gsub("256 ", "", names, fixed = TRUE)
  # finally, replace all blanks with underscores
  names <- gsub(" ", "_", names, fixed = TRUE)

  values <- gsub(":$", "", dt$values, perl = TRUE) |> trimws()

  # return header as list
  header <- as.list(values)
  names(header) <- names

  return(header)
}