R/proximate_data.R

In proximetricsR: Spectral Preprocessing and Chemometric Calibration of NIR Sensors

#' @title Create a data frame for NIRWise PLUS applications
#'
#' @description
#'
#' \loadmathjax
#'
#' Create a data frame of class \code{"proximate_data"}, similar to \code{\link{proximate_read_data}},
#' but without the need for a file. Instead, data can be supplied directly from \code{R}.
#' @usage
#' proximate_data(
#'   spc, id, properties = NULL, row = seq_len(nrow(spc)), check = "True", date = Sys.time(),
#'   snr = NULL, barcode = "", note = "", begin = Sys.time(), end = Sys.time(),
#'   recipe = "", coeffs = NULL
#' )
#' @param spc A matrix containing the spectral data. Note that the names of the
#' columns must indicate the corresponding wavelength range at which the spectra
#' was measured. Hence, the column names must be convertible to numerical values.
#' @param id A vector of length equal to the number of rows of \code{spc}.
#' Corresponds to the ID of the spectra, and must be provided.
#' @param properties Either \code{NULL} (default) or a matrix containing numerical
#' values, indicating the reference values of each property, where the column
#' names correspond to the names of the properties. If a matrix is provided,
#' it must contain the same number of rows as \code{spc}, but can contain \code{NA}
#' values.
#' @param row A vector of length equal to the number of rows of \code{spc}.
#' Contains the row number of the observation.
#' @param check A vector of characters with length equal to the number of rows of
#' \code{spc} or a single character. Must only contain characters \code{"True"}
#' or \code{"False"}. Defaults to \code{"True"}.
#' @param date A vector of length equal to the number of rows of \code{spc} or a
#' single character. Indicates the date when the measurement was taken. Format
#' should be: \code{"year-month-day hour:min:sec"}. In case an object inheriting
#' from \code{"POSIXct"}, formatting will be done automatically. Defaults
#' to \code{Sys.time()}.
#' @param snr A vector of length equal to the number of rows of \code{spc}, a
#' single character or \code{NULL}. Indicated the serial number of the instrument
#' the measurement was taken with. Defaults to \code{NULL}, in which case the
#' serial numbers are all equal to \code{"0000000000"}.
#' @param barcode A vector of length equal to the number of rows of \code{spc} or a
#' single character. Contains the barcodes for the measurement. Defaults to an empty
#' string.
#' @param note A vector of length equal to the number of rows of \code{spc} or a
#' single character. Contains notes for the measurements. Defaults to an empty
#' string.
#' @param begin A vector of length equal to the number of rows of \code{spc} or a
#' single character. Contains the time and date of the beginning of the measurement
#' process. Format should be: \code{"year-month-day hour:min:sec"}. In case an
#' object inheriting from \code{"POSIXct"}, formatting will be done automatically.
#' Defaults to the system's current date and time.
#' @param end A vector of length equal to the number of rows of \code{spc} or a
#' single character. Contains the time and date of the ending of the measurement
#' process. Format should be: \code{"year-month-day hour:min:sec"}. In case an
#' object inheriting from \code{"POSIXct"}, formatting will be done automatically.
#' Defaults to the system's current date and time.
#' @param recipe A vector of length equal to the number of rows of \code{spc} or a
#' single character. Contains the recipe for the measurements. Defaults to an
#' empty string.
#' @param coeffs A list with exactly three entries. Parameter is ignored if the
#' wavelength resolution of \code{spc} is constant. For non-constant resolution,
#' this parameter must be supplied. See details on this parameter needs to be
#' defined. Default is \code{NULL}.
#'
#' @return A `data.frame` of class `proximate_data` containing all the metadata,
#' response variables and spectra. The spectra is returned in a matrix embedded
#' in the data.frame which can be accessed as \code{...$spc}.
#' @details
#' This function provides an alternative way of creating a \code{data.frame} with
#' the necessary structure that is required by many functions of this package.
#' In particular, this function does not require any already existing files like
#' \code{\link{proximate_read_data}}.
#'
#' Note that only the first two arguments to this function are required for creating
#' the data frame. However, the \code{properties} argument should most often also
#' be provided, as these contain the necessary reference values for the process of
#' modeling and creating an application with the spectral data.
#'
#' Most parameters of this function can either have length equal to the number of
#' rows of \code{spc} or length equal to one. In latter case, the value is recycled
#' for every row of the returned data frame.
#'
#' Furthermore, we emphasize that the column names of matrix \code{spc} must contain
#' the wavelength ranges of the spectra.
#'
#' In case these spectra do not have a constant resolution, the function will require
#' additional information on how the spectral wavelength range can be recovered.
#' Then, the parameter \code{coeffs} will be mandatory and must contain
#' information on the polynomial coefficients that were used to obtain the wavelengths.
#' More information, including an example, can be seen in the vignette about the \cr
#' \code{vignette(ProxiMate-Structure-of-the-application-files)}.
#' A concrete example is also given below.
#'
#' The \code{coeffs} must be a named list with exactly 3 entries: \code{X1}, \code{X2}, \code{X3}.
#' In ProxiMate data files (.tsv), they can be seen at columns #X1, #X2, #X3.
#' Note that both \code{X1} and \code{X2} must be vectors of either length 1 or 2,
#' containing the start and end pixels respectively, while \code{X3} is a list of
#' length 1 or 2, containing polynomial coefficients as vectors of arbitrary
#' length. The entries of the \code{coeffs} can either be for a near-infrared
#' only (i.e. length 1), or for both the visible and near-infrared range
#' (i.e. length 2).
#'
#' The coefficients are attached to the returned \code{data.frame} as an attribute
#' \code{"coeffs"}.
#'
#'
#' @author Claudio Orellano
#'
#' @examples
#' data("proximateCannabis")
#' dat <- proximateCannabis
#'
#' # Reconstruct proximateCannabis with properties in a different order
#' spc <- dat$spc
#' properties <- matrix(
#'   c(dat$CBD, dat$CBDA, dat$THC, dat$THCA),
#'   ncol = 4, dimnames = list(NULL, c("CBD", "CBDA", "THC", "THCA"))
#' )
#' datc <- proximate_data(
#'   spc, dat$ID, properties, dat$ROW,
#'   date = dat$Date, snr = dat$SNR, barcode = dat$Barcode,
#'   note = dat$Note, begin = dat$Begin, end = dat$End, recipe = dat$Recipe
#' )
#'
#' # They are similar to each other (except the order of properties):
#' dat_refs <- which(names(dat) %in% c("Reference", colnames(properties)))
#' datc_refs <- which(names(datc) %in% c("Reference", colnames(properties)))
#' all.equal(dat[, -dat_refs], datc[, -datc_refs]) # TRUE
#'
#' # In case of non-constant wavelengths, have to pass the coefficients to the function.
#' # Coefficients are usually given as #X1, #X2, #X3 in ProxiMate .tsv files,
#' # e.g. using coefficients example of vignette(Structure-of-the-application-files):
#' coeffs <- list(
#'   X1 = c(823, 4),
#'   X2 = c(1074, 272),
#'   X3 = list(
#'     c(0, 0, 0, -3.618926e-05, 2.137782, -1.333363e+03),
#'     c(2.04E-10, -1.28E-07, 2.80E-05, -4.76e-3, 3.89, 880.06)
#'   )
#' )
#'
#' # You can extract the wavelengths in nm using these coefficients like this:
#' # Note that NIR pixels must be shifted by one to the right, as they are zero-based
#' pixel_seq <- list((coeffs$X1[1]:coeffs$X2[1]), (coeffs$X1[2]:coeffs$X2[2]) + 1)
#' vis_wavs <- mapply(
#'   pixel_seq[[1]],
#'   FUN = function(x) coeffs$X3[[1]] %*% c(x^5, x^4, x^3, x^2, x^1, 1)
#' )
#' nir_wavs <- mapply(
#'   pixel_seq[[2]],
#'   FUN = function(x) coeffs$X3[[2]] %*% c(x^5, x^4, x^3, x^2, x^1, 1)
#' )
#' wavs <- c(vis_wavs, nir_wavs)
#'
#' # Above coefficients now have to be passed to the proximate_data()
#' # function since there are non-constant wavelengths.
#'
#' # If we (wrongly) assume that proximateCannabis has such wavelengths:
#' rand_mat <- matrix(rnorm((length(wavs) - ncol(spc)) * nrow(spc)), nrow = nrow(spc))
#' spc <- cbind(rand_mat, spc)
#' colnames(spc) <- wavs
#'
#' # Now we can create data object with coefficients
#' datcc <- proximate_data(
#'   spc, dat$ID, properties, dat$ROW,
#'   date = dat$Date, snr = dat$SNR, barcode = dat$Barcode,
#'   note = dat$Note, begin = dat$Begin, end = dat$End, recipe = dat$Recipe,
#'   coeffs = coeffs
#' )
#'
#' # Coefficients can be viewed with
#' attr(datcc, "coeffs")
#' @export
proximate_data <- function(spc, id, properties = NULL, row = seq_len(nrow(spc)), check = "True", date = Sys.time(),
                           snr = NULL, barcode = "", note = "", begin = Sys.time(), end = Sys.time(),
                           recipe = "", coeffs = NULL) {
  if (missing(spc)) {
    stop("'spc' is missing.")
  }
  if (!is.matrix(spc)) {
    stop("'spc' has to be a matrix")
  }
  if (missing(id)) {
    stop("'id' is missing.")
  }
  if (length(id) != nrow(spc)) {
    stop("Each spectra must have an 'id'.")
  }
  if (!is.null(properties)) {
    if (!is.matrix(properties)) {
      stop("'properties' must be a matrix.")
    }
    if (any(is.null(colnames(properties)))) {
      stop("Missing column names found in 'properties'.")
    }
  }
  if (any(!is_numeric_like(colnames(spc)))) {
    if (any(!is_numeric_like(gsub("spc.", "", colnames(spc))))) {
      stop("Column names of 'spc' must correspond to spectral wavelengths.")
    }
    colnames(spc) <- gsub("spc.", "", colnames(spc))
  }
  if (!is.null(properties)) {
    if (nrow(spc) != nrow(properties)) {
      stop("'spc' and 'properties' must have the same number of rows.")
    }
  }
  if (any(is.null(colnames(spc)))) {
    stop("Missing column names found in 'spc'.")
  }
  if (any(!check %in% c("True", "False"))) {
    stop("'check' must only consist of characters 'True' or 'False'.")
  }
  wavs <- as.numeric(colnames(spc))
  rln <- unique(diff(wavs))
  # Non-constant wavelengths case.
  if (length(rln) > 1) {
    # Catch if coeffs are NULL.
    if (is.null(coeffs)) {
      warning(
        "In case of non-constant wavelengths, polynomial coefficients 'coeffs'",
        "should be provided, otherwise errors can occur."
      )
    } else {
      # In case coeffs are given, check if they are in correct format
      if (!is.list(coeffs)) {
        warning("Coefficients should be given in a list.\n")
      } else {
        if (!is.list(coeffs$X3)) {
          warning("'X3' given in 'coeffs' should be a list.\n")
        }
      }
      if (any(!names(coeffs) %in% c("X1", "X2", "X3"))) {
        warning("Coefficients are not named correctly, might result in errors.\n")
      }
    }
  } else {
    # Constant wavelength case, can construct the coefficients ourselves.
    x1 <- 0
    x2 <- ncol(spc) - 1
    x3 <- list(c(0, rln, min(wavs) - rln))
    coeffs <- list(X1 = x1, X2 = x2, X3 = x3)
  }
  if (inherits(date, "POSIXct")) {
    date <- format(date, "%Y-%m-%d %H:%M:%S")
  }
  if (inherits(begin, "POSIXct")) {
    begin <- format(begin, "%Y-%m-%d %H:%M:%S")
  }
  if (inherits(end, "POSIXct")) {
    end <- format(end, "%Y-%m-%d %H:%M:%S")
  }
  if (is.null(snr)) {
    snr <- rep(1000000000, nrow(spc))
  }
  if (!is.null(properties)) {
    result <- paste(rep(0, ncol(properties)), collapse = " ; ")
    zero_properties <- properties
    zero_properties[is.na(zero_properties)] <- 0
    reference <- apply(zero_properties, FUN = paste, MARGIN = 1, collapse = " ; ")
  } else {
    result <- ""
    reference <- ""
  }


  return_df <- data.frame(
    ROW = row,
    Check = check,
    Date = date,
    SNR = snr,
    ID = id,
    Barcode = barcode,
    Note = note,
    Result = result,
    Reference = reference
  )
  if (!is.null(properties)) {
    return_df <- cbind(return_df, properties)
  }
  return_df <- data.frame(
    return_df,
    Begin = begin,
    End = end,
    Recipe = recipe,
    Composition = "",
    Images = "",
    check.names = FALSE
  )
  return_df$spc <- spc
  class(return_df) <- c("proximate_data", "data.frame")
  attr(return_df, "coeffs") <- coeffs
  return_df
}