R/proximate_write_nax.R

In proximetricsR: Spectral Preprocessing and Chemometric Calibration of NIR Sensors

#' @title Create an application file for the given list of models
#' @name proximate_write_nax
#' @description
#'
#' \loadmathjax
#' This function provides a flexible way to create an application file (.nax)
#' which can be deployed into ProxiMate sensors.
#'
#' @usage
#' proximate_write_nax(object, path, metadata, tsv_name, empty_tsv_name, 
#'                     spc = "spc", external_properties = NULL, report = TRUE, 
#'                     verbose = TRUE, internal_prj_path = NULL)
#'
#' @param object a list of objects of class \code{spectral_model}, as generated
#' by \code{\link{calibrate}}. Note that at least one of these models must contain
#' the relevant input data (i.e. run with \code{return_inputs = TRUE} in
#' \code{\link{calibrate}} method).
#' @param path a character for the directory in which the file should be
#' produced.
#' @param metadata an object of class \code{application_metadata}, as generated by
#' \code{\link{add_application_metadata}}. If not provided (and \code{object}
#' does not contain the metadata either), default values are used with a warning.
#' @param tsv_name an optional character. If not supplied, this parameter is set
#' to the name of the application plus the current date. See details.
#' @param empty_tsv_name an optional character. For ProxiMate applications, this
#' argument should be different to \code{tsv_name} or it cannot be imported into
#' the device. If missing, is set to the name of the application. See details.
#' @param spc a character to indicate the column name of the spectra used in the
#' data provided to the \code{object} list of models. This parameter is passed
#' to the \code{\link{proximate_write_data}} method. Defaults to \code{"spc"}.
#' @param external_properties a list for additional files to be included in the
#' application file. Defaults to \code{NULL}. See details for how these
#' files may be added.
#' @param report a logical. Should reports of the models be generated and added
#' to the file? Defaults to \code{TRUE}.
#' @param verbose a logical indicating whether progress bars during the creation
#' of the file should be printed. Defaults to \code{TRUE}.
#' @param internal_prj_path a string. Only used for changing the path printed on
#' the first line of each project file. For almost all cases, this argument can
#' be ignored. The only case where you should adjust this parameter is when you
#' are creating the application (.nax) file in a certain folder, but actually
#' want to move it to another one (e.g. on a different platform). If \code{NULL}
#' (default), the path is set equal to \code{path}, with \code{"Calibrations/"}
#' added at the end.
#'
#' @details
#' This function is capable of generating an application (.nax) file, which
#' contains compressed data files for the application. All files inside this
#' .nax file are organized in a fixed way, such that they are importable into a
#' ProxiMate device. For that, all models to be imported should be in a list,
#' and each individual model should be generated using the \code{\link{calibrate}}
#' function, preferably with the input data saved in it. This can easily be done
#' by calling the method with \code{return_inputs = TRUE}. Note that at least
#' one model in \code{object} must contain input data, otherwise an error will
#' occur.
#'
#' Furthermore, note that the \code{data} argument in \code{\link{calibrate}} for
#' all models in one single application must be from one single data set.
#' In particular, one single \code{data.frame} must suffice to describe the inputs
#' of all models in \code{object}. The data that is actually used to train these
#' models can still be different, e.g. by specifying the rows that you want to
#' exclude from a certain model (see \code{skip} argument of \code{\link{calibrate}}).
#' An error will be thrown if this is not the case.
#'
#' The directory \code{path} is created automatically (if it does not exist).
#' Inside, the application file is generated, which contains the following
#' compressed files: a file for the metadata (.nad), project (.prj) and
#' calibration (.cal) files for all the provided models in \code{object},
#' possibly report (.rtf) files (as indicated by the \code{report} argument),
#' a tab-separated value (.tsv) file of the spectral data, and an empty
#' tab-separated value (.tsv) file.
#'
#' The metadata file (.nad) is required for a successful import of the
#' application into a ProxiMate device. This requires metadata in every model,
#' which should be added using \code{\link{add_model_metadata}} prior
#' to the call of this function. Otherwise, default values for the model metadata
#' will be used with a warning. Furthermore, application specific metadata is
#' required, which can be either specified by providing the argument \code{metadata},
#' or included in the list of models \code{object} (see \code{\link{add_application_metadata}}),
#' where the former option will take precedence.
#' If neither option is available, default values of \code{add_application_metadata}
#' are used with a warning.
#'
#' Furthermore, this function provides a way of adding separately
#' generated project and calibration files through the parameter
#' \code{external_properties}. Note that these files have to be either in the
#' directory of the provided \code{path} or in a sub-directory "Calibrations"
#' thereof. External properties must be provided as a list containing model metadata
#' (using the \code{\link{add_model_metadata}} method) in order to be added properly
#' to the application file.
#'
#' These external files must also be named according to the naming convention of
#' the rest of the models used. In particular, the function searches the
#' provided \code{path} and the sub-directory "Calibrations" for files named with
#' the following format: \code{app_name.property_name.cal}, \code{app_name.property_name.prj}
#' and (if report is \code{TRUE}) \code{app_name.property_name.rtf}, where
#' the \code{app_name} is taken from the application metadata, and the \code{property_name}
#' from model metadata passed to \code{external_properties}. If the files cannot be
#' found, a warning will be displayed.
#'
#' An example for adding an external property is given in the example section below.
#'
#' Note that if an application file for the given application already exists,
#' the files inside the compressed application file are updated, but already
#' present files are not deleted.
#'
#'
#' @examples
#' \donttest{
#' data("proximateCannabis")
#' control <- calibration_control(validation_type = "kfold", number = 3, folds = "sequential")
#' # Models for application files must have model metadata!
#' model_metadata <- add_model_metadata(unit = "%")
#' modell <- calibrate(CBDA ~ spc,
#'   data = proximateCannabis, preprocess = preprocess_recipe(),
#'   method = fit_plsr(15), control = control,
#'   metadata = model_metadata, verbose = FALSE
#' )
#'
#' app_metadata <- add_application_metadata(name = "app")
#' proximate_write_nax(
#'   object = list(modell),
#'   path = tempdir(),
#'   metadata = app_metadata,
#'   tsv_name = "some_tsv",
#'   empty_tsv_name = "another_tsv",
#'   report = TRUE,
#'   verbose = FALSE
#' )
#'
#' # Another model
#' modelr <- calibrate(THCA ~ spc,
#'   data = proximateCannabis, preprocess = preprocess_recipe(),
#'   method = fit_plsr(15), control = control,
#'   metadata = model_metadata, verbose = FALSE
#' )
#'
#' # Generate some files to be added separately
#' proximate_write_model(
#'   object = list(modelr),
#'   path = tempdir(),
#'   tsv_paths = tempdir(),
#'   application_name = "app",
#'   cal = TRUE, prj = TRUE, rtf = TRUE,
#'   verbose = FALSE
#' )
#'
#' # Now add them using external properties. Requires a name for the property!
#' proximate_write_nax(
#'   object = list(modell),
#'   path = tempdir(),
#'   metadata = app_metadata,
#'   tsv_name = "some_tsv",
#'   empty_tsv_name = "another_tsv",
#'   external_properties = list(add_model_metadata(unit = "%", name = "THCA")),
#'   report = TRUE,
#'   verbose = FALSE
#' )
#' }
#' @return Invisibly returns \code{NULL}. Called for its side effect of writing
#' a \code{.nax} application file to \code{path}.
#' @author Claudio Orellano, Leonardo Ramirez-Lopez
#' @import utils
#' @export

proximate_write_nax <- function(object, path, metadata, tsv_name, empty_tsv_name,
                                spc = "spc", external_properties = NULL, report = TRUE,
                                verbose = TRUE, internal_prj_path = NULL) {
  # Save working directory

  my_wd <- getwd()
  on.exit({
    setwd(my_wd)
  })
  # Sanity checks
  if (missing(path)) {
    stop("'path' is required. Please provide the directory where the file should be saved.")
  }
  if (!is.logical(verbose)) {
    stop("Parameter 'verbose' has to be a logical")
  }
  if (sub(".*(?=.{1}$)", "", path, perl = T) != "/") {
    path <- paste0(path, "/")
  }
  if (!dir.exists(path)) {
    if (verbose) {
      cat("Created folder:", path, "\n")
    }
    dir.create(path)
  }
  if (missing(object)) {
    stop("Parameter 'object' has to be provided")
  }
  if (!is.list(object)) {
    stop("Parameter 'object' has to be a list.")
  }
  # Extract application metadata
  if (missing(metadata)) {
    if (is.null(object$metadata)) {
      stop(
        "No application metadata found in either 'object' or 'metadata', but must ",
        "be provided via function 'add_application_metadata'."
      )
    }
    if (!"application_metadata" %in% class(object$metadata)) {
      warning(
        "'metadata' in 'object' is not of class 'application_metadata', ",
        "which may result in errors. Consider using function 'add_application_metadata'."
      )
    }
    metadata <- object$metadata
  } else {
    if (!"application_metadata" %in% class(metadata)) {
      warning(
        "'metadata' is not of class 'application_metadata', which may result in errors. ",
        "Consider using function 'add_application_metadata'."
      )
    }
  }
  object$metadata <- NULL
  if (!all(sapply(object, FUN = inherits, what = "spectral_model"))) {
    stop("All entries in 'object' must be of class 'spectral_model'.")
  }

  # Check model metadata
  model_meta <- lapply(object, FUN = "[[", MARGIN = "metadata")
  if (!all(sapply(model_meta, FUN = inherits, what = "model_metadata"))) {
    whc <- which(!sapply(model_meta, FUN = inherits, what = "model_metadata"))
    if (length(whc) == 1) plr <- "model" else plr <- "models"
    nms <- paste(
      sapply(object, FUN = "[[", MARGIN = "target_variable")[intersect(seq_along(object), whc)],
      collapse = ", "
    )
    wrn <- paste0(
      "No metadata found in the ", plr, " for: ", nms, ". Using defaults instead, ",
      "which might be incorrect.\n Consider using function 'add_model_metadata'.\n"
    )
    warning(wrn)
    for (i in whc) {
      object[[i]] <- add_model_metadata(object = object[[i]])
    }
  }

  application_name <- metadata$Name

  # If all sort orders are still at its default value (1), update to use index instead
  change_order <- all(sapply(object, function(x) x$metadata$SortOrder) == 1)
  # Change Argument1 of each model metadata (if NULL) to name of calibration file
  for (i in 1:length(object)) {
    if (is.null(object[[i]]$metadata$Argument1)) {
      object[[i]]$metadata$Argument1 <- paste0(application_name, ".", object[[i]]$target_variable, ".cal")
    }
    if (change_order) object[[i]]$metadata$SortOrder <- i
  }

  if (missing(tsv_name)) {
    tsv_name <- paste0(application_name, "-", Sys.Date())
  }
  if (missing(empty_tsv_name)) {
    empty_tsv_name <- application_name
  }
  if (!is.logical(report)) {
    stop("'Report' has to be a logical.")
  }

  # Check that no property is duplicated
  if (any(duplicated(sapply(object, FUN = "[[", MARGIN = "target_variable")))) {
    prblm <- which(duplicated(sapply(object, FUN = "[[", MARGIN = "target_variable")))
    stp <- paste0(
      "The provided list of models contains more than one model for the following: ",
      paste(sapply(object, FUN = "[[", MARGIN = "target_variable")[prblm], collapse = ", "),
      ".\nDuplicates of properties are not supported."
    )
    stop(stp)
  }

  temp_path <- paste0(tempdir(check = TRUE), "/")
  files_to_zip <- list()
  setwd(temp_path)
  save_dir <- paste0(temp_path, "Calibrations/")
  if (!dir.exists(save_dir)) {
    dir.create(save_dir)
  }
  zipname <- paste0(path, application_name, ".nax")

  if (all(sapply(sapply(object, FUN = "[[", MARGIN = "input_data"), FUN = "is.null"))) {
    stop("No data found in any model of 'object', which is required for creating an application.")
  }
  if (!all(mapply(object, FUN = attr, which = "data_hash") == mapply(object, FUN = attr, which = "data_hash")[1])) {
    stop(
      "Differences found in data used to create the models in 'object'.",
      " The data for all models included must be from one single 'data.frame'."
    )
  }
  which_model_data <- which(!sapply(sapply(object, FUN = "[[", MARGIN = "input_data"), FUN = "is.null"))[1]
  tsv_data <- object[[which_model_data]]$input_data$data

  if (!"proximate_data" %in% class(tsv_data)) {
    warning("Data does not appear to be of class 'proximate_data', which can result in errors when creating an application.\n")
  }

  if (is.null(internal_prj_path) || !is.character(internal_prj_path)) {
    internal_prj_path <- paste0(path, "Calibrations/")
  }

  # Generate tsv file
  tsv_save_path <- paste0(save_dir, "Data/")
  if (!dir.exists(tsv_save_path)) {
    dir.create(tsv_save_path)
  }
  tsv_save_path <- paste0(tsv_save_path, tsv_name, ".tsv")
  properties <- extract_property_names(tsv_data)
  proximate_write_data(
    x = tsv_data,
    id = tsv_data$ID,
    spc = spc, spc_round = 8,
    barcode = tsv_data$Barcode,
    properties = properties,
    note = tsv_data$Note,
    recipe = tsv_data$Recipe,
    snr = if (!is.null(tsv_data$SNR)) {
      tsv_data$SNR
    } else {
      tsv_data$SRN
    },
    file = tsv_save_path
  )
  files_to_zip <- append(files_to_zip, paste0(
    "Calibrations/Data/", tsv_name, ".tsv"
  ))

  # Generate empty tsv file
  empty_tsv_save_path <- paste0(save_dir, "Local/")
  if (!dir.exists(empty_tsv_save_path)) {
    dir.create(empty_tsv_save_path)
  }
  empty_tsv_save_path <- paste0(empty_tsv_save_path, empty_tsv_name, ".tsv")
  writeLines("", con = empty_tsv_save_path)
  files_to_zip <- append(files_to_zip, paste0(
    "Calibrations/Local/",
    empty_tsv_name, ".tsv"
  ))

  tsv_save_path <- c(
    paste0("./Data/", tsv_name, ".tsv"),
    paste0("./Local/", empty_tsv_name, ".tsv")
  )
  # Generate .cal, .prj (and possibly rtf) files
  proximate_write_model(
    object = object,
    tsv_paths = tsv_save_path,
    application_name = application_name,
    path = save_dir,
    cal = TRUE, prj = TRUE, rtf = report,
    verbose = verbose,
    internal_prj_path = internal_prj_path
  )
  all_target_names <- sapply(object, FUN = "[[", MARGIN = "target_variable")
  files_to_zip <- append(
    files_to_zip,
    paste0("Calibrations/", application_name, ".", all_target_names, ".cal")
  )
  files_to_zip <- append(
    files_to_zip,
    paste0("Calibrations/", application_name, ".", all_target_names, ".prj")
  )
  if (report) {
    files_to_zip <- append(
      files_to_zip,
      paste0("Calibrations/", application_name, ".", all_target_names, ".rtf")
    )
  }

  ext_files_to_zip <- list()
  if (!is.null(external_properties)) {
    all_ext_target_names <- sapply(external_properties, FUN = "[[", MARGIN = "Name")
    ignore_property <- duplicated(all_ext_target_names)
    if (any(ignore_property)) {
      warning("Duplicated property names found in 'external_properties'. Only the first entry will be used.")
      external_properties <- external_properties[!ignore_property]
      all_ext_target_names <- all_ext_target_names[!ignore_property]
      ignore_property <- rep(FALSE, length(external_properties))
    }
    cal_names <- paste0(application_name, ".", all_ext_target_names, ".cal")
    prj_names <- paste0(application_name, ".", all_ext_target_names, ".prj")
    for (cals in cal_names) {
      if (file.exists(paste0(path, cals))) {
        file.copy(paste0(path, cals), paste0(temp_path, "Calibrations/", cals))
        ext_files_to_zip <- append(ext_files_to_zip, paste0("Calibrations/", cals))
      } else {
        if (file.exists(paste0(path, "Calibrations/", cals))) {
          file.copy(paste0(path, "Calibrations/", cals), paste0(temp_path, "Calibrations/", cals))
          ext_files_to_zip <- append(ext_files_to_zip, paste0("Calibrations/", cals))
        } else {
          warning(paste0("File '", cals, "' not found. Ignoring property in application file computation."))
          ignore_property[which(cal_names %in% cals)] <- TRUE
        }
      }
    }
    for (prjs in prj_names) {
      if (file.exists(paste0(path, prjs))) {
        file.copy(paste0(path, prjs), paste0(temp_path, "Calibrations/", prjs))
        ext_files_to_zip <- append(ext_files_to_zip, paste0("Calibrations/", prjs))
      } else {
        if (file.exists(paste0(path, "Calibrations/", prjs))) {
          file.copy(paste0(path, "Calibrations/", prjs), paste0(temp_path, "Calibrations/", prjs))
          ext_files_to_zip <- append(ext_files_to_zip, paste0("Calibrations/", prjs))
        } else {
          whc <- which(prj_names %in% prjs)
          if (!ignore_property[whc]) {
            warning(paste0("File '", prjs, "' not found. Ignoring property in application file computation."))
            ignore_property[whc] <- TRUE
          }
        }
      }
    }
    if (report) {
      rtf_names <- paste0(application_name, ".", all_ext_target_names, ".rtf")
      for (rtfs in rtf_names) {
        if (file.exists(paste0(path, rtfs))) {
          file.copy(paste0(path, rtfs), paste0(temp_path, "Calibrations/", rtfs))
          ext_files_to_zip <- append(ext_files_to_zip, paste0("Calibrations/", rtfs))
        } else {
          if (file.exists(paste0(path, "Calibrations/", rtfs))) {
            file.copy(paste0(path, "Calibrations/", rtfs), paste0(temp_path, "Calibrations/", rtfs))
            ext_files_to_zip <- append(ext_files_to_zip, paste0("Calibrations/", rtfs))
          } else {
            if (!ignore_property[which(rtf_names %in% rtfs)]) {
              warning(paste0("File '", rtfs, "' not found."))
            }
          }
        }
      }
    }
    if (all(ignore_property)) {
      external_properties <- NULL
    } else {
      external_properties <- external_properties[!ignore_property]
    }
  }

  write_nad(
    object = object,
    path = temp_path,
    application_meta = metadata,
    external_properties = external_properties,
    verbose = verbose
  )
  files_to_zip <- append(files_to_zip, paste0(application_name, ".nad"))

  # if (verbose) {
  #   flags <- formals(zip)$flags
  # } else {
  #   flags <- "-q"
  # }
  zip::zip(zipfile = zipname, files = unlist(c(files_to_zip, ext_files_to_zip)))
  if (verbose) {
    if (file.exists(zipname)) {
      cat(paste0("Application saved in: ", zipname, "\n"))
    } else {
      cat(paste0("Failed to create file ", zipname, "."))
    }
  }
  on.exit(
    {
      file.remove(unlist(c(files_to_zip, ext_files_to_zip)))
    },
    add = TRUE,
    after = FALSE
  )
}