R/proximate_read_data.R

In proximetricsR: Spectral Preprocessing and Chemometric Calibration of NIR Sensors

#' @title Read ProxiMate (.tsv) files
#'
#' @description
#'
#' \loadmathjax
#'
#' This function imports .tsv files generated by BUCHI ProxiMate sensors.
#' The text encoding of \code{file} (UTF-8 or Windows-1252/"ANSI") is
#' automatically detected and used to correctly decode special characters
#' (e.g. accented letters) in metadata fields such as notes or IDs.
#' @usage
#' proximate_read_data(file)
#' @param file A string indicating the name (and path) of the .tsv file. A
#' \code{\link[base]{textConnection}} (or any other R connection providing
#' the file's content) can also be passed.
#' @return A data.frame containing all the metadata, response variables and
#' spectra in the tsv file. The spectra is returned in a matrix embedded in the
#' data.frame which can be accessed as \code{...$spc}.
#' @author Leonardo Ramirez-Lopez
#'
#' @examples
#' data("proximateCannabis")
#' filename <- paste0(tempdir(), "/proximateCannabis.tsv")
#' # Need to produce a tsv file before we can read it
#' proximate_write_data(
#'   x = proximateCannabis,
#'   file = filename,
#'   properties = c("CBDA", "THCA", "CBD", "THC")
#' )
#' # Equivalent to dataset proximateCannabis
#' dat <- proximate_read_data(filename)
#' @export
proximate_read_data <- function(file) {
  # Read the lines of the TSV file
  lines <- read_tsv_lines(file)
  # Decide on the decimal separator based on the last entry of the first
  # data row (the second line of the file, right after the header)
  fin_entry <- tail(strsplit(lines[2], "\t")[[1]], 1)
  mdec <- ifelse(grepl(",", fin_entry), ",", ".")

  # Read the table directly from the lines of the file
  ftsv <- read.table(
    text = lines,
    sep = "\t",
    quote = "",
    dec = mdec,
    header = TRUE,
    comment.char = "",
    na.strings = "-",
    check.names = FALSE
  )

  empty_rows <- rowSums(!(is.na(ftsv) | ftsv == ""), na.rm = TRUE) == 0

  if (any(empty_rows)) {
    if (sum(empty_rows) == 1) {
      stop(paste0("An empty row was detected in the tsv file"))
    } else {
      stop(paste0("A total of ", sum(empty_rows), " empty rows were detected in the tsv file"))
    }
  }

  coefficient_separators <- ":|,|[|]"

  ftsv[["#X3"]] <- gsub("^\"|\"$", "", as.character(ftsv[["#X3"]]))
  ftsv[["#X2"]] <- gsub("^\"|\"$", "", as.character(ftsv[["#X2"]]))
  ftsv[["#X1"]] <- gsub("^\"|\"$", "", as.character(ftsv[["#X1"]]))

  sgmnt <- grep(coefficient_separators, ftsv[["#X3"]])
  convnirw <- NULL
  shift_pixels <- c()
  if (length(sgmnt) > 0) {
    fconvnirw <- t(sapply(as.character(ftsv[["#X3"]]), function(x) strsplit(x, coefficient_separators)[[1]], USE.NAMES = FALSE))
    for (i in seq_len(ncol(fconvnirw))) {
      convnirw[[i]] <- t(sapply(as.character(fconvnirw[, i]), function(x) as.numeric(strsplit(x, ";")[[1]]), USE.NAMES = FALSE))
      shift_pixels <- c(shift_pixels, decide_shift_pixel(convnirw[[i]]))
    }
    starts <- strsplit(as.character(ftsv[["#X1"]][1]), coefficient_separators)[[1]]
    ends <- strsplit(as.character(ftsv[["#X2"]][1]), coefficient_separators)[[1]]
  } else {
    convnirw[[1]] <- t(sapply(as.character(ftsv[["#X3"]]), function(x) as.numeric(strsplit(x, ";")[[1]]), USE.NAMES = FALSE))
    starts <- as.character(ftsv[["#X1"]][1])
    ends <- as.character(ftsv[["#X2"]][1])
    shift_pixels <- decide_shift_pixel(convnirw[[1]])
  }
  starts <- as.numeric(starts)
  ends <- as.numeric(ends)

  getwavs <- function(coeff, spartpixel, endpixel, shift_pixel) {
    d <- length(coeff) - 1
    mt <- t(matrix(rep((spartpixel:endpixel) + shift_pixel, each = length(coeff)), length(coeff)))
    mt2 <- sweep(mt, MARGIN = 2, STATS = d:0, FUN = "^")
    wavs <- coeff %*% t(mt2)
    return(wavs)
  }

  wavs <- list()
  for (i in seq_along(convnirw)) {
    wavs[[i]] <- getwavs(
      coeff = convnirw[[i]][1, ],
      spartpixel = starts[i],
      endpixel = ends[i],
      shift_pixel = shift_pixels[i]
    )
  }

  datar <- ftsv[, -grep("^#(X[0-9]|[0-9]+)", colnames(ftsv))]
  datar$spc <- as.matrix(ftsv[, grep("^#[0-9]+", colnames(ftsv))])
  # Use helper function to decide on wavelengths
  colnames(datar$spc) <- set_wavelengths(wavs, ncol(datar$spc))

  std_nms <- c(
    "ROW", "Check", "Date", "Unit", "SRN", "SNR", "ID", "Barcode", "Note", "Result",
    "Reference", "Begin", "End", "Recipe", "Composition", "Images", "spc"
  )

  # These columns could all be properties and therefore might be numeric (or NA)
  for (nms in setdiff(colnames(datar), std_nms)) {
    datar[[nms]] <- convert_numeric_like(datar[[nms]])
  }

  char_nms <- c(
    "Check", "Date", "Unit", "ID", "Barcode", "Note", "Result", "Reference", "Begin", "End",
    "Recipe", "Composition", "Images"
  )

  for (nms in intersect(colnames(datar), char_nms)) {
    datar[[nms]] <- replace(datar[[nms]], is.na(datar[[nms]]), "")
  }

  # "Unit" is equivalent to "SNR" in some tsv
  if (!"SNR" %in% colnames(datar)) {
    if ("Unit" %in% colnames(datar)) {
      if (all(nchar(datar$Unit) > 7)) {
        spl <- which(colnames(datar) %in% "Unit")
        datar <- cbind(
          datar[, 1:spl, drop = FALSE],
          SNR = datar$Unit,
          datar[, (spl + 1):ncol(datar), drop = FALSE]
        )
      }
    }
  }

  convnirw_red <- list()
  for (i in seq_along(convnirw)) {
    convnirw_red[[i]] <- convnirw[[i]][1, ]
  }
  attr(datar, "coeffs") <- list(X1 = starts, X2 = ends, X3 = convnirw_red)

  class(datar) <- c("proximate_data", "data.frame")
  return(datar)
}

#' @title Read the lines of a tsv file or connection, auto-detecting UTF-8 vs Windows-1252
#' @description
#' NIRWise PLUS may export tsv files either as UTF-8 or as Windows-1252
#' ("ANSI"), and there is no guarantee that a connection passed by the user
#' (e.g. a \code{\link[base]{textConnection}}) holds UTF-8 data either. This
#' helper reads the raw bytes only once, from a path or from a connection
#' alike (\code{encoding = "bytes"}, i.e. with no interpretation/
#' re-encoding), and checks whether they form a valid UTF-8 byte sequence
#' with \code{\link[base]{validUTF8}}. If they do (which also covers plain
#' ASCII data), the lines are simply tagged as \code{"UTF-8"}; otherwise they
#' are assumed to be \code{"windows-1252"} and converted to \code{"UTF-8"}.
#' This way special characters (e.g. accented letters) are decoded correctly
#' regardless of the current R session's locale, without reading the input
#' more than once.
#' @param file A string indicating the path to the tsv file, or an already
#' open connection (e.g. a \code{\link[base]{textConnection}}).
#' @return A character vector with the (correctly encoded) lines of the file.
#' @author Claudio Orellano
#' @keywords internal
#' @noRd
read_tsv_lines <- function(file) {
  raw_lines <- readLines(file, warn = FALSE, encoding = "bytes")
  if (validUTF8(paste(raw_lines, collapse = "\n"))) {
    Encoding(raw_lines) <- "UTF-8"
    return(raw_lines)
  }
  iconv(raw_lines, from = "windows-1252", to = "UTF-8")
}

#' @title Set wavelengths
#' @description
#' This helper function returns the wavelengths for the spectra in the `spc` column of the
#' dataset. If the wavelengths cannot be computed, an error is thrown
#' @param wavs A list of matrices containing the wavelengths. Should be of length
#' 1 for NIR and 2 for VIS and NIR.
#' @param ncols_spc The number of columns in the spectra.
#' @return A numeric vector containing the wavelengths
#' @author Claudio Orellano
#' @keywords internal
#' @noRd
set_wavelengths <- function(wavs, ncols_spc) {
  # Check that the number of wavelengths is equal to the number of columns in the spectra
  if (sum(sapply(wavs, length)) == ncols_spc) {
    return(unlist(wavs))
  }
  # The length of NIR should always be as given, but it's possible that VIS
  # only uses every 3rd wavelength
  if (length(wavs) == 2) {
    vis_seq <- seq(from = 1, to = length(wavs[[1]]), by = 3)
    if (length(vis_seq) + length(wavs[[2]]) == ncols_spc) {
      return(c(unlist(wavs[[1]])[vis_seq], unlist(wavs[[2]])))
    }
  }
  # If none of the above conditions are met, stop the function
  stop("The number of wavelengths is not equal to the number of columns in the spectra")
}


#' @title Decide shift pixel
#' @description
#' This helper function decides the if the pixels should be shifted for the
#' pixel-to-wavelength transformation.
#' @param coeff A numeric vector containing the coefficients for the pixel-to-wavelength transformation
#' @return A logical value indicating if the pixels should be shifted
#' @author Claudio Orellano
#' @keywords internal
#' @noRd
decide_shift_pixel <- function(coeff) {
  # If there are exactly 6 columns, the coefficients must be shifted
  if (ncol(coeff) == 6) {
    return(TRUE)
  }
  # If there are exactly 3 columns and the first coefficients are zero, the
  # coefficients must be shifted
  if (ncol(coeff) == 3 && sum(coeff[, 1]) == 0) {
    return(TRUE)
  }
  # Otherwise, return FALSE
  FALSE
}

#' @title Convert numeric-like numbers to numeric
#' @description
#' This helper function checks if a vector has any numeric-like entries. If it
#' does not, it just returns the vector. If it does, it tries to convert the vector
#' to numeric, also replacing any non-numeric entries with `NA_real_`.
#' Commas are replaced with dots before trying to convert to numeric.
#' Whitespaces are removed from the beginning and end of the string.
#' Any value equal to 0 is replaced with `NA_real_`.
#' @param x A vector of character strings or numerics
#' @param na_strings A character vector of strings that should be treated as NA
#' @keywords internal
#' @noRd
convert_numeric_like <- function(x, na_strings = c("", ".", "NA", "na", "N/A", "n/a", "NaN", "nan")) {
  # If the vector is already numeric, set any value equal to 0 to NA and return
  if (is.numeric(x)) {
    x[x == 0] <- NA_real_
    return(x)
  }
  # If no value is numeric-like, return x unchanged
  if (!any(is_numeric_like(x, na_strings = na_strings), na.rm = TRUE)) {
    return(x)
  }
  # Otherwise, the values are numeric-like, so we need to convert them to numeric
  # Trim and map NA-like strings to actual NA
  x <- trimws(x, "both")
  x[x %in% na_strings] <- NA_character_
  # Normalize comma decimal to dot
  x <- gsub("^(\\-?\\d+),(\\d+)$", "\\1.\\2", x, perl = TRUE)
  # Convert anything that is numeric like to numeric, rest is NA
  out <- rep(NA_real_, length(x))
  x_numerics <- is_numeric_like(x, na_strings = na_strings)
  out[x_numerics] <- as.numeric(x[x_numerics])
  # Replace 0 with NA
  out[out == 0] <- NA_real_
  out
}