R/utils.R

In PlotFTIR: Plot FTIR Spectra

#' Get Plot Sample IDs
#'
#' @description Get the sample IDs from a prepared plot. Useful if renaming in
#'   the plot legend.
#'
#'   Obtenez les ID d’échantillon à partir d’un tracé préparé. Utile si vous
#'   renommez dans la légende de le tracé
#'
#' @param ftir_spectra_plot A plot generated by [plot_ftir()] or
#'   [plot_ftir_stacked()].
#'
#'   Un tracé généré par [plot_ftir()] ou [plot_ftir_stacked()].
#'
#' @return A vector of factors corresponding to the sample IDs in the plot.
#'
#'   unvecteur de facteurs correspondant aux ID d'échantillon dans le tracé
#' @export
#'
#' @seealso [rename_plot_sample_ids()]
#' @examples
#' if (requireNamespace("ggplot2", quietly = TRUE)) {
#'   # Prepare a plot
#'   p <- plot_ftir(biodiesel)
#'
#'   # Get the Sample IDs
#'   get_plot_sample_ids <- (p)
#' }
get_plot_sample_ids <- function(ftir_spectra_plot) {
  # Package Checks
  if (!requireNamespace("ggplot2", quietly = TRUE)) {
    cli::cli_abort(c(
      "{.pkg PlotFTIR} requires {.pkg ggplot2} package installation.",
      i = "Install {.pkg ggplot2} with {.run install.packages('ggplot2')}"
    ))
  }
  if (!ggplot2::is.ggplot(ftir_spectra_plot)) {
    cli::cli_abort(
      "Error in {.fn PlotFTIR::get_plot_sample_ids}. {.arg ftir_spectra_plot} must be a ggplot object. You provided {.obj_type_friendly {ftir_spectra_plot}}."
    )
  }
  return(as.factor(unique(ftir_spectra_plot$data$sample_id)))
}

#' @title Check FTIR Data
#'
#' @description Check the provided FTIR data.frame is appropriate for
#'   manipulation or plotting. Not typically called directly, but as a function
#'   in data integrity check process before further calculation or plotting
#'   happens. Sets data.frame attribute `intensity` to `transmittance` or
#'   `absorbance` if not previously set.
#'
#'   Vérifie que le data.frame IRTF fourni est approprié pour la manipulation ou
#'   le tracé. Cette fonction n'est généralement pas appelée directement, mais
#'   elle est utilisée dans le cadre du processus de vérification de l'intégrité
#'   des données avant tout autre calcul ou tracé. Définit l'attribut data.frame
#'   `intensity` à `transmittance` ou `absorbance` s'il n'a pas été défini
#'   auparavant.
#'
#' @param ftir A data.frame of FTIR spectral data.
#'
#'   Un data.frame de données spectrales IRTF.
#'
#' @return Invisibly returns FTIR data if ok, or raises an error.
#'
#'   Renvoie de manière invisible les données IRTF si elles sont correctes, ou
#'   soulève une erreur.
#'
#' @export
#' @examples
#' # This returns (invisibly) the biodiesel data. If instead there was an issue
#' # with the data structure it would raise an error.
#' check_ftir_data(biodiesel)
check_ftir_data <- function(ftir) {
  fn <- try(deparse(sys.calls()[[sys.nframe() - 1]]), silent = TRUE)
  if (inherits(fn, 'try-error')) {
    fn <- "PlotFTIR::check_ftir_data"
  } else {
    fn <- paste0("PlotFTIR::", strsplit(fn, "(", fixed = TRUE)[[1]][1])
  }

  if ("ir" %in% class(ftir)) {
    cli::cli_inform("Converting {.pkg ir} data to {.pkg PlotFTIR} structure.")
    ftir <- ir_to_plotftir(ftir)
  }

  if ("Spectra" %in% class(ftir)) {
    cli::cli_inform(
      "Converting {.pkg ChemoSpec} data to {.pkg PlotFTIR} structure."
    )
    ftir <- chemospec_to_plotftir(ftir)
  }

  if (!(is.data.frame(ftir))) {
    cli::cli_abort(
      "Error in {.fn {fn}}. {.arg ftir} must be a data frame. You provided {.obj_type_friendly ftir}."
    )
  }
  if (!("sample_id" %in% colnames(ftir))) {
    cli::cli_abort(c(
      "Error in {.fn {fn}}. {.arg ftir} is missing a column.",
      i = "It must contain a column named {.var sample_id}."
    ))
  }
  if (!("wavenumber" %in% colnames(ftir))) {
    cli::cli_abort(c(
      "Error in {.fn {fn}}. {.arg ftir} is missing a column.",
      i = "It must contain a column named {.var wavenumber}."
    ))
  }
  if (!any(colnames(ftir) == "absorbance", colnames(ftir) == "transmittance")) {
    cli::cli_abort(
      "Error in {.fn {fn}}. {.arg ftir} must have one of {.var absorbance} or {.var transmittance} columns."
    )
  }
  if ("absorbance" %in% colnames(ftir) && "transmittance" %in% colnames(ftir)) {
    cli::cli_abort(
      "Error in {.fn {fn}}. {.arg ftir} cannot contain both {.var absorbance} and {.var transmittance} columns."
    )
  }
  if (
    any(
      !(colnames(ftir) %in%
        c("sample_id", "wavenumber", "absorbance", "transmittance"))
    )
  ) {
    cli::cli_abort(
      "Error in {.fn {fn}}. {.arg ftir} may only contain columns {.var sample_id}, {.var wavenumber}, and one of {.var absorbance} or {.var transmittance}."
    )
  }
  if (
    !is.null(attr(ftir, "intensity")) &&
      !(attr(ftir, "intensity") %in%
        c(
          "absorbance",
          "transmittance",
          "normalized absorbance",
          "normalized transmittance"
        ))
  ) {
    cli::cli_abort(
      "Error in {.fn {fn}}. {.arg ftir} has unexpected attributes."
    )
  }

  if (is.null(attr(ftir, "intensity"))) {
    attr(ftir, "intensity") <- intensity_type(ftir)
  }

  invisible(ftir)
}


#' Intensity Type
#'
#' @description Determines if the provided data has intensity type of absorbance
#'   or transmittance.
#'
#' @inheritParams conversion
#'
#' @return a character value 'absorbance' or 'transmittance'
#' @keywords internal
intensity_type <- function(ftir) {
  # Don't check_ftir_data to avoid a loop if called by check_ftir_data()

  if ("absorbance" %in% colnames(ftir)) {
    return("absorbance")
  } else if ("transmittance" %in% colnames(ftir)) {
    return("transmittance")
  }

  # implied else
  ftir <- ftir[, -which(names(ftir) %in% c("wavenumber", "sample_id"))]
  return(ifelse(max(ftir, na.rm = TRUE) > 10, "transmittance", "absorbance"))
}