R/proximate_read_nax.R

In proximetricsR: Spectral Preprocessing and Chemometric Calibration of NIR Sensors

#' @title Reads and summarizes ProxiMate spectroscopic applications (nax files)
#' @description
#'
#' This function reads and summarizes the main aspects of BUCHI ProxiMate
#' applications which are files of extension .nax. In addition, the file is
#' retain as raw binary in the object generated by this function.
#' @usage
#' proximate_read_nax(file, ignore_version = FALSE)
#' @param file a character vector containing the .nax file name (and path).
#' @param ignore_version a logical passed to \code{\link{proximate_read_cal}}.
#' If \code{FALSE} (default), embedded \code{.cal} files with no version
#' information or created with NIRWise PLUS prior to version 1.0 raise an
#' error. Set to \code{TRUE} to read them with a warning instead.
#' @return
#'
#' A a list of class \code{nax} which contains the following objects:
#'
#' \itemize{
#'     \item \strong{\code{nax_summary}:} a list with:
#'         \itemize{
#'             \item \strong{\code{content}:} the name of the files inside the nax/application.
#'             \item \strong{\code{size}:} the size (on disk) of the nax.
#'             \item \strong{\code{raw}:} the original nax file/application stored as raw binary.
#'             }
#'     \item \strong{\code{nad_info}:} a list with:
#'         \itemize{
#'             \item \strong{\code{summary}:} a summary of the high-level ProxiMate
#'             application parameters.
#'             \item \strong{\code{data}:} a full list of the high-level ProxiMate
#'             application parameters.
#'             }
#'     \item \strong{\code{cal_info}:} a list with:
#'         \itemize{
#'             \item \strong{\code{summary}:} a summary of the calibration models
#'             contained in the ProxiMate application.
#'             \item \strong{\code{meta_param}:} a list with parameters of each
#'             calibration model (e.g. pre-processing recipes.
#'             }
#'     \item \strong{\code{rtf_info}:} a list with:
#'         \itemize{
#'             \item \strong{\code{summary}:} a summary of the calibration models
#'             as printed in the calibration reports contained in the nax file.
#'             This includes the optimal number of components suggested
#'             (\code{ncomp}).
#'             }
#'     \item \strong{\code{data}:} a list with:
#'         \itemize{
#'             \item \strong{\code{summary}:} a summary of the calibration data (tsv
#'             files) contained in the ProxiMate application.
#'             \item \strong{\code{data}:} a \code{list} with the calibration data
#'             found in all the tsv files.
#'             }
#'  }
#'
#' In case, any of the above components is encrypted a character string
#' indicating so will be returned. In case of the rtf calibration reports
#' are not present in the nax, a NULL will be returned for \code{rtf_info}.
#' @author Leonardo Ramirez-Lopez
#' @export

proximate_read_nax <- function(file, ignore_version = FALSE) {
  if (!file.exists(file)) {
    stop("File does not exists!")
  }
  finfo <- file.info(file)
  finfo$size_format <- format(structure(finfo$size, class = "object_size"), units = "auto")
  tmpd <- tempdir()
  # dname <- file
  fname <- get_fname(file)

  cname <- paste0(fname, "-", uuid::UUIDgenerate(n = 1, output = "string"))
  otherd <- list.dirs(tmpd, recursive = FALSE)
  max_iter <- 5000
  i <- 0
  while (any(grepl(cname, otherd)) | i < max_iter) {
    cname <- paste0(fname, "-", uuid::UUIDgenerate(n = 1, output = "string"))
    i <- i + 1
  }

  if (any(grepl(cname, otherd))) {
    stop("A problem while writing the file into a temporary directory")
  }

  cname <- paste0(tmpd, "/", cname)

  dir.create(cname)

  unzip(file, exdir = cname, overwrite = TRUE)
  lfiles <- list.files(cname, recursive = TRUE, full.names = TRUE)
  inad <- grep(".nad$", lfiles)
  if (length(inad) == 0) {
    stop("File corrupted, .nad information is missing")
  }

  # check and extract info from the .nad
  nad_info <- try(get_nad_info(lfiles[inad]))
  if (inherits(nad_info, "try-error")) {
    stop("Problem with the nad file")
  }

  # check project files
  prjf_wext <- lfiles[grep(".prj$", lfiles)]

  # check the cal files
  calf_wext <- lfiles[grep(".cal$", lfiles)]
  calf <- get_fname(calf_wext)
  cal_properties <- gsub(paste0(nad_info$summary$app_name, "."), "", calf)

  cal_idx <- sapply(
    nad_info$summary$properties$names,
    FUN = function(x, x2) {
      which(x == x2)
    },
    x2 = cal_properties
  )

  cal_ok <- all(tolower(nad_info$summary$properties$names) %in% tolower(cal_properties))
  if (!cal_ok) {
    stop("File corrupted. One or more missing cal models")
  }
  cal_info <- try(proximate_read_cal(calf_wext[cal_idx], ignore_version = ignore_version))
  if ("try-error" %in% class(cal_info)) {
    stop("Problem with the cal file(s)")
  }

  # read the rtfs
  rtfs <- lfiles[grep(".rtf$", lfiles)]
  if (length(rtfs) > 0) {
    rtff <- get_fname(rtfs)
    rtf_properties <- gsub(paste0(nad_info$summary$app_name, "."), "", rtff)
    rtf_idx <- sapply(
      nad_info$summary$properties$names,
      FUN = function(x, x2) {
        which(x == x2)
      },
      x2 = rtf_properties
    )
    rtfs_ok <- all(tolower(nad_info$summary$properties$names) %in% tolower(rtf_properties))
    if (!rtfs_ok) {
      warning("Skipping rtf files as one or more files are missing")
    } else {
      rtf_info <- try(read_rtfs(rtfs[rtf_idx]))
      if (inherits(rtf_info, "try-error")) {
        stop("Problem with the rtf file(s)")
      }
      oncomps <- sapply(rtf_info$summary, FUN = function(x) x$ncomp)

      if (!any(is.na(oncomps))) {
        if (inherits(cal_info$summary, "data.frame")) {
          if (!identical(oncomps, cal_info$summary$Factors)) {
            warning("The number of components in the rtf reports and the cal files do not match for one or more models")
          }
        }
      }
    }
  } else {
    rtf_info <- NULL
  }

  # read the tsvs
  tsvf_wext <- lfiles[grep(".tsv$", lfiles)]
  tsvs <- try(get_info_tsvs(files = tsvf_wext))
  if (inherits(tsvs, "try-error")) {
    stop("Problem with the tsv file(s)")
  }

  # summarize nax
  nax_content <- gsub(cname, "", lfiles, fixed = TRUE)
  bin_nax <- readBin(file, what = "raw", n = finfo$size)
  nax_info <- list(
    content = nax_content,
    size = finfo$size_format,
    raw = bin_nax
  )


  # delete temp dir
  try(unlink(cname, recursive = TRUE), silent = TRUE)

  mnax <- list(
    nax_summary = nax_info,
    nad_info = nad_info,
    cal_info = cal_info,
    rtf_info = rtf_info,
    data = tsvs
  )
  class(mnax) <- c("nax", "list")
  mnax
}

#' @title get file name
#' @param x a file name
#' @description internal
#' @return A character string with the file name without path or extension.
#' @keywords internal
get_fname <- function(x) {
  sub(
    ".*/",
    "",
    tools::file_path_sans_ext(x),
    perl = TRUE
  )
}

#' @title get info from nad files
#' @param file a nad file
#' @description internal
#' @return A list containing metadata extracted from the NAD file, including properties, units, geometry, and measurement mode information.
#' @keywords internal
get_nad_info <- function(file) {
  fs <- file.size(file)
  bindata <- readBin(file, what = "raw", n = fs)
  # nad_info <- readLines(file, warn = FALSE)
  nad_info <- readBin(bindata, what = "character")
  nad_info <- gsub("\"|]", "", nad_info)
  nad_info <- strsplit(nad_info, "},|\\{")[[1]]
  nad_info <- nad_info[nad_info != ""]
  nad_info <- lapply(nad_info, FUN = function(x) {
    x <- gsub("{", "", x[1], fixed = TRUE)
    x <- gsub("}", "", x[1], fixed = TRUE)
    x <- strsplit(x, ",")[[1]]
    spl <- sapply(gregexec(":", x), FUN = function(x) x[1])
    x1 <- substr(x, 1, spl - 1)
    x2 <- substr(x, spl + 1, 10000)
    x <- data.frame(param = x1, value = x2)
    x <- x[!x2 == "", ]
    if (nrow(x) > 0) {
      x
    }
  })
  nad_info <- nad_info[!sapply(nad_info, FUN = is.null)]
  nad_properties <- sapply(nad_info[-1], FUN = function(x) x$value[grep("Name", x$param)])
  nad_prop_units <- sapply(nad_info[-1], FUN = function(x) x$value[grep("Unit", x$param)])
  nad_geometry <- nad_info[[1]]$value[grep("ViewType", nad_info[[1]]$param)]
  nad_mode <- nad_info[[1]]$value[grep("MeasurementMode", nad_info[[1]]$param)]
  nad_created <- nad_info[[1]]$value[grep("Created", nad_info[[1]]$param)]
  nad_name <- nad_info[[1]]$value[grep("Name", nad_info[[1]]$param)][1]

  nad_summary <- list(
    app_name = nad_name,
    properties = list(names = nad_properties, units = nad_prop_units),
    geometry = nad_geometry,
    mode = nad_mode,
    created = nad_created
  )

  return(list(
    summary = nad_summary,
    data = nad_info
    # binary = bindata
  ))
}

#' @title get the tsv info
#' @param files a vector of tsv files with their paths
#' @description internal
#' @return A data frame containing information about the TSV files.
#' @keywords internal
get_info_tsvs <- function(files) {
  files_main <- files[grep("/Data/", files)]
  files_main <- files_main[grep(".tsv", files_main)]
  files_local <- files[grep("/Local/", files)]
  files_local <- files_local[grep(".tsv", files_local)]
  ldata <- NULL
  mfiles <- c(files_main, files_local)
  fsummary <- data.frame(
    Index = rep(NA, length(mfiles)),
    File = rep(NA, length(mfiles))
  )
  fsummary$n <- NA
  fsummary$Location <- NA
  idx <- 1
  for (i in mfiles) {
    is_protected <- grepRaw(
      "^BUCHI [A-Z a-z]{1,}Licensed",
      readBin(i, what = "raw", n = 50)
    ) |> length() > 0

    if (is_protected) {
      message("Protected tsv file(s). These will not be read.")
      return(list(
        summary = "Protected",
        data = NULL
      ))
      break
    }

    check_tsv <- readLines(i, n = 1, warn = FALSE)

    is_tsv <- all(
      c(
        grepl("ROW", check_tsv),
        grepl("Check", check_tsv),
        grepl("ID", check_tsv),
        grepl("#X1", check_tsv),
        grepl("#X3", check_tsv)
      )
    )

    is_empty <- FALSE
    if (length(check_tsv) == 0) {
      is_empty <- TRUE
    } else {
      if (check_tsv == "") {
        is_empty <- TRUE
      }
    }


    fsummary$File[idx] <- i |> get_fname()
    fsummary$Location[idx] <- ifelse(grepl("/Data/", i), "Data", "Local")
    if (!is_empty) {
      if (!is_tsv) {
        stop("Corrupted tsv")
      }
      ldata[[idx]] <- proximate_read_data(i)
      fsummary$n[idx] <- nrow(ldata[[idx]])
      fsummary$True[idx] <- sum(ldata[[idx]]$Check == "True")
    } else {
      ldata[[idx]] <- NA
      fsummary$n[idx] <- 0
    }
    idx <- idx + 1
  }
  # mdata <- merge_nwp_data(ldata)
  names(ldata) <- fsummary$Index <- paste0("Index_", 1:nrow(fsummary))
  return(list(
    summary = fsummary,
    data = ldata
  ))
}

#' @title extract info from rtf calibration reports
#' @param files a vector of rtf files with their paths
#' @description internal
#' @return A list containing extracted information from the RTF calibration reports.
#' @keywords internal
read_rtfs <- function(files) {
  fsummary <- list()
  for (i in seq_along(files)) {
    ith_file <- files[i]
    ith_con <- file(ith_file, "rb")
    irtfbin <- readBin(ith_con, what = "raw", n = file.size(ith_file))

    is_protected <- grepRaw(
      "^BUCHI [A-Z a-z]{1,}Licensed",
      irtfbin
    ) |> length() > 0

    if (is_protected) {
      message("Protected rtf file(s). These will not be read.")
      return(list(
        summary = "Protected"
      ))
      break
    }

    ridx <- c(
      rev(grepRaw("Calibration Results", irtfbin, ignore.case = TRUE, all = TRUE))[1] + 20,
      rev(grepRaw("R\\'b2=", irtfbin, all = TRUE, fixed = TRUE) - 1)[1]
    )

    search_t <- "PLS\\\\tab XVAR\\\\tab SEC\\\\tab|XLS\\\\tab XVAR\\\\tab SEC\\\\tab"
    idxcomp <- rev(grepRaw(search_t, irtfbin, all = TRUE) - 1)[1]
    idxcomp2 <- grepRaw("\\par \r\n\\par \\b", irtfbin, all = TRUE, fixed = TRUE)
    idxcomp2 <- idxcomp2[idxcomp2 > idxcomp][1]
    idxcomp <- c(idxcomp, idxcomp2)

    # read the required chunks of data
    seek(ith_con, where = idxcomp, origin = "start")

    comp_tab_v <- readChar(ith_con, diff(idxcomp))

    seek(ith_con, where = ridx[1], origin = "start")
    irtf <- readChar(ith_con, diff(ridx))
    close(ith_con, type = "rb")

    comp_tab_l <- strsplit(comp_tab_v, "\r\n\\par", fixed = TRUE)[[1]]
    idx_suggested <- grep("^ \\\\b ", comp_tab_l)
    clean_row <- function(x) {
      ispl <- strsplit(x, "\\tab", fixed = TRUE)[[1]]
      ispl <- gsub("^ $", NA, ispl)
      ispl <- gsub("\\b0", "", ispl, fixed = TRUE)
      ispl <- gsub("^ {0, }\\\\b", "", ispl, fixed = FALSE)
      ispl <- gsub("^ ", "", ispl)
      ispl
    }

    comp_tab_l <- lapply(comp_tab_l, FUN = clean_row)
    comp_tab_l <- comp_tab_l[!(is.na(comp_tab_l) | comp_tab_l == "")]
    comp_tab_l <- comp_tab_l[!sapply(comp_tab_l, FUN = function(x) any(grepl("100%", x)))]
    comp_tab <- do.call("rbind", comp_tab_l[-1])
    colnames(comp_tab) <- comp_tab_l[[1]]
    comp_tab <- comp_tab[, -grep("Outliers", colnames(comp_tab), ignore.case = TRUE)]
    comp_tab[, "XVAR"] <- gsub("%", "", comp_tab[, "XVAR"], fixed = TRUE)
    comp_tab <- as.data.frame(comp_tab)
    comp_tab[] <- comp_tab |>
      unlist() |>
      as.numeric()

    if (length(idx_suggested) == 0) {
      # warning("Missing optimal components suggestion in the rtf report")
      suggested_comp <- NA
    } else {
      suggested_comp <- comp_tab[idx_suggested - 1, 1]
    }

    irtf <- substr(irtf, gregexpr("Sample", irtf), nchar(irtf))
    irtf <- strsplit(irtf, "\r\n\\par", fixed = TRUE)[[1]]
    tabr <- irtf[1:(length(irtf) - 1)]
    tabr <- lapply(tabr, FUN = clean_row)

    tabm <- do.call("rbind", tabr[-1]) |>
      apply(MARGIN = 2, FUN = function(x) gsub("\\\\f0|\\\\f1", "", x)) |>
      as.data.frame()
    colnames(tabm) <- tabr[[1]][!is.na(tabr[[1]])]
    tabm <- tabm[, !is.na(colnames(tabm))]

    num_vars <- c(
      "Sample",
      "N",
      "Target",
      "Estimate",
      "Residual",
      "Mahalanobis"
    )

    tabm[, colnames(tabm) %in% num_vars] <- tabm[, colnames(tabm) %in% num_vars] |>
      unlist() |>
      as.numeric()

    # rsq <- cor(tabm$Target, tabm$Estimate, use = "complete.obs")^2
    # rmse <- mean((tabm$Target - tabm$Estimate)^2, rm.na = TRUE)^0.5

    fsummary[[i]] <- list(
      name = get_fname(ith_file),
      description = comp_tab,
      cal_results = tabm,
      ncomp = suggested_comp
    )
  }
  list(summary = fsummary)
}

# get_prj_info <- function(files) {
#   for(i in files) {
#     is_protected <- grepRaw(
#       "^BUCHI [A-Z a-z]{1,}Licensed",
#       readBin(i, what = "raw", n = 50)
#     ) |> length() > 0
#
#     if (is_protected) {
#       message("Protected prj file(s). These will not be read.")
#       return(list(
#         summary = "Protected"
#       ))
#       break
#     }
#
#     bf <- readLines(i, warn = FALSE)
#     tsvs <- bf[grep("Files:File", bf)]
#     tsvs <- tsvs[grep("\\.tsv", tsvs)]
#     tsvs <- tsvs[grep("#TRUE#", tsvs)]
#     tsvs <- gsub("\\\"", "", tsvs)
#     strsplit(tsvs, ",")
#
#   }
#
# }