R/helpers.R

In freesurferformats: Read and Write 'FreeSurfer' Neuroimaging File Formats

#' @title Find files with the given base name and extensions that exist.
#'
#' @description Note that in the current implementation, the case of the filepath and the extension must match.
#'
#' @param filepath character string, path to a file without extension
#'
#' @param precedence vector of character strings, the file extensions to check. Must include the dot (if you expect one).
#'
#' @param error_if_none logical, whether to raise an error if none of the files exist
#'
#' @param return_all logical, whether to return all readable files instead of just the first one
#'
#' @return character string, the path to the first existing file (or `NULL` if none of them exists).
#'
#' @export
readable.files <- function(filepath, precedence=c('.mgh', '.mgz'), error_if_none=TRUE, return_all=FALSE) {
  candidate_files = paste(filepath, precedence, sep='');
  readable_files = c();
  for(cfile in candidate_files) {
    if(file.exists(cfile)) {
      if(return_all) {
        readable_files = c(readable_files, cfile);
      } else {
        return(cfile);
      }
    }
  }

  if(length(readable_files) == 0 & error_if_none) {
    stop(sprintf("At location '%s' exists no file with any of the %d extensions '%s'.\n", filepath, length(precedence), paste(precedence, collapse=' ')));
  } else {
    return(readable_files);
  }
}


#' @title Check whether filepath ends with extension.
#'
#' @param filepath string. Path to a file, including filename and extension.
#'
#' @param extensions list of strings. A list of suffixes to check. Case does not matter. Example: \code{extensions=c('.gz', '.mgz')}.
#'
#' @return logical, whether the filepath end with one of the extensions.
#'
#' @keywords internal
filepath.ends.with <- function(filepath, extensions) {
  nc = nchar(filepath);
  for (ext in extensions) {
    num_chars_to_inspect = nchar(ext);
    if(nc >= num_chars_to_inspect) {
      this_file_ext = substr(filepath, nchar(filepath)-num_chars_to_inspect+1L, nchar(filepath));
      if(tolower(this_file_ext) == tolower(ext)) {
        return(TRUE);
      }
    }
  }
  return(FALSE);
}


#' @title Get an rgl tmesh3d instance from a brain surface mesh.
#'
#' @description Convert \code{fs.surface} to \code{tmesh} without the \code{rgl} package.
#'
#' @param surface an fs.surface instance, as returned \code{freesurferformats::read.fs.surface}.
#'
#' @return a \code{tmesh3d} instance representing the surface, see \code{rgl::tmesh3d} for details. It has classes \code{mesh3d} and \code{shape3d}.
#'
#' @export
fs.surface.to.tmesh3d <- function(surface) {
  if( ! is.fs.surface(surface)) {
    stop("Parameter 'surface' must be an instance of fs.surface.");
  }
  tmesh = list("material"=list(), "normals"=NULL, "texcoords"=NULL, "meshColor"="vertices");
  class(tmesh) = c("mesh3d", "shape3d");
  tmesh$vb = t(cbind(surface$vertices, 1L)); # Transform vertex coords to homogeneous and swap rows/columns
  tmesh$it = t(surface$faces); # swap only
  return(tmesh);
}


#' @title Check for pandoc availability on system.
#'
#' @return logical, whether Pandoc is available.
#'
#' @keywords internal
has_pandoc <- function() {
  assert_package("rmarkdown")
  return(rmarkdown::pandoc_available());
}


assert_package <- function(pkg) {

  package_installed <- vapply(pkg, function(p) {
    return( system.file(package = p) != "" )
  }, FALSE)
  if( all(package_installed) ) { return(invisible()) }
  pkg <- pkg[!package_installed]

  # the package is missing
  cnd <- structure(list(message = sprintf("Package(s) %s missing. Please install first.", paste(sQuote(pkg), collapse = ", ")), call = NULL),
                   class = c("package_not_found_error", "simpleError", "error", "condition"))

  # check if rlang has been installed, usually yes if people installs any rlib/posit packages
  rlang_is_missing <- system.file(package = "rlang") == ""
  pak_is_missing <- system.file(package = "pak") == ""

  # if not interactive or rlang&pak are missing, per CRAN policy, stop
  if(!interactive() || (rlang_is_missing && pak_is_missing)) {
    stop(cnd)
  }

  if( !rlang_is_missing ) {
    rlang <- asNamespace("rlang")
    rlang$check_installed(pkg)
    return(invisible())
  }

  # using pak
  message(sprintf("Package(s) %s missing, install?", paste(sQuote(pkg), collapse = ", ")))
  if (utils::menu(c("Yes", "No")) != 1) {
    invokeRestart("abort", cnd)
  }
  pak <- asNamespace("pak")
  pak$pkg_install(pkg, ask = FALSE)

  return(invisible())

}