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)
  }

  class(ftir) <- unique(c("PlotFTIR_data", class(ftir)))

  invisible(ftir)
}


#' Print PlotFTIR Data
#'
#' @description
#' Pretty print method for PlotFTIR data structures, showing spectral range,
#' inferred resolution, intensity type, number of samples, and sample IDs.
#'
#' Méthode d'impression jolie pour les structures de données PlotFTIR, montrant
#' la plage spectrale, la résolution inférée, le type d'intensité, le nombre
#' d'échantillons et les ID d'échantillons.
#'
#' @param x A PlotFTIR data object.
#'
#'   Un objet de données PlotFTIR.
#'
#' @param ... Additional arguments passed to print.
#'
#'   Arguments supplémentaires passés à print.
#'
#' @return Invisibly returns the object.
#'
#'   Renvoie l'objet de manière invisible.
#'
#' @export
#' @method print PlotFTIR_data
print.PlotFTIR_data <- function(x, ...) {
  cat("PlotFTIR data:\n")
  wn <- sort(unique(x$wavenumber))
  cat("  Spectral range:", min(wn), "-", max(wn), "cm\u207b\u00b9\n")
  res <- diff(wn)
  if (length(res) == 0) {
    cat("  Resolution: none\n")
  } else if (length(unique(res)) == 1) {
    cat("  Resolution:", unique(res), "cm\u207b\u00b9\\n")
  } else {
    cat("  Resolution: variable\n")
  }
  cat("  Intensity type:", attr(x, "intensity"), "\n")
  samples <- unique(x$sample_id)
  cat("  Number of samples:", length(samples), "\n")
  if (length(samples) <= 5) {
    cat("  Sample IDs:", paste(samples, collapse = ", "), "\n")
  } else {
    cat("  Sample IDs:", paste(utils::head(samples, 5), collapse = ", "), "...\n")
  }
  invisible(x)
}


#' 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"))
}