R/utils.R

In luciorq/luciolib:

#' Normalize Paths
#'
#' Normalize and expand path between different OS's.
#'
#' @param ... Strings to be joined as path.
abs_path <- function(...) {
  path_args <- list(...)
  if (length(path_args) == 0) {
    res_path <- fs::path_abs(fs::path_expand(fs::path(".")))
  } else {
    res_path <- fs::path_abs(fs::path_expand(fs::path(... = ...)))
  }
  return(res_path)
}

#' Capture `cli` Messages
#'
#' Capture `cli::cli_*()` message outputs as strings.
#'
#'  @param msg Message to be captured.
#'  @param remove_cli_style Remove styling introduced by `cli_*`.
capture_cli <- function(msg, remove_cli_style = TRUE) {
  msgs <- character()
  i <- 0
  suppressMessages(withCallingHandlers(
    msg,
    message = function(e) msgs[[i <<- i + 1]] <<- conditionMessage(e)
  ))
  res_msg <- stringr::str_c(msgs, collapse = "")
  if (isTRUE(remove_cli_style)) {
    ansi_regex <- paste0(
      "(?:(?:\\x{001b}\\[)|\\x{009b})",
      "(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])",
      "|\\x{001b}[A-M]"
    )
    res_msg <- gsub(ansi_regex, "", res_msg, perl = TRUE)
  }
  return(res_msg)
}

#' Abort with `cli` message
#'
#' Currently `cli` package don't throw errors,
#' this is `cli::cli_alert_danger()` wrapped with `rlang::abort()`.
#'
#' @param err_msg The message to display.
#' @param .envir Environment to evaluate the glue expressions in.
#' @export
cli_abort <- function(err_msg, .envir = parent.frame()) {
  cli::cli_alert_danger(text = err_msg, .envir = .envir)
  rlang::abort(message = capture_cli(cli::cli_text(err_msg, .envir = .envir)))
}

#' Get project full path
#' Get project full path using heuristics and config files.
#' @inheritParams setup_package
#' @export
get_proj_path <- function(pkg_name = NULL, project_dir = NULL) {
  if (is.null(pkg_name) && is.null(project_dir)) {
    pkg_dir <- usethis::proj_get()
    pkg_name <- basename(pkg_dir)
  } else if (stringr::str_detect(pkg_name, "\\.") && is.null(project_dir)) {
    pkg_dir <- usethis::proj_get()
    pkg_name <- basename(pkg_dir)
  } else if (is.null(pkg_name) && fs::dir_exists(project_dir)) {
    cli_abort("{.arg pkg_name} must be supplied with {.arg project_dir} arg.")
  } else if (is.null(pkg_name) && !fs::dir_exists(project_dir)) {
    cli_abort("{.path { project_dir }} is not a valid path.")
  } else if (fs::dir_exists(pkg_name) && is.null(project_dir)) {
    pkg_dir <- abs_path(pkg_name)
  } else if (!fs::dir_exists(pkg_name) && is.null(project_dir)) {
    cli_abort("{.arg pkg_name} is invalid.")
  } else {
    pkg_dir <- abs_path(project_dir, pkg_name)
  }
  return(pkg_dir)
}

#' Check BioConductor
#' Function to check if package is aiming BioConductor.
#' @inheritParams setup_package
is_bioc <- function(pkg_name = NULL, project_dir = NULL) {
  pkg_dir <- get_proj_path(pkg_name, project_dir)
  suppressMessages({usethis::with_project(
    path = fs::path(pkg_dir),
    code = {
      desc_file <- fs::path(pkg_dir, "DESCRIPTION")
      desc_lines <- readr::read_lines(desc_file)
      result_bool <- any(stringr::str_detect(desc_lines, "^biocViews"))
    },
    force = TRUE,
    quiet = FALSE
  )})
  return(result_bool)
}

#' Check if package is installed
#' If package isn't installed tell user to install.
#' @param package_name package name to query.
#' @param type type of package to query c("r_pkg", "py_module", "shell").
#' @export
is_available <- function(package_name = NULL, type = NULL) {
  if (is.null(package_name)) {
    cli_abort("Argument {.arg package_name} must not be empty.")
  }
  if (is.null(type)) {
    type <- "rstats"
  }
  type <- stringr::str_to_lower(stringr::str_squish(type))
  if (any(stringr::str_detect(type, "py|python"))) {
    type <- "python"
  }
  if (any(stringr::str_detect(type, "r|r_|rstats"))) {
    type <- "rstats"
  }

  if (type == "python") {
    if (is_available("reticulate")) {
      if (reticulate::py_module_available(package_name)) {
        cli::cli_alert("Using {.pkg { package_name }}.")
        return(TRUE)
      } else {
        cli::cli_alert_warning(
          "Python module {.pkg { package_name }} is not installed."
        )
        cli::cli_alert_info(
          "You should install it to use full functionality."
        )
        cli::cli_end()
        return(FALSE)
      }
    }
  }
  if (type == "rstats") {
    if (requireNamespace(package_name, quietly = TRUE)) {
      cli::cli_alert("Using {.pkg {package_name}}.")
      return(TRUE)
    } else {
      cli::cli_alert_warning(
        "Package {.pkg { package_name }} is not installed."
      )
      cli::cli_alert_info(
        "You should install it to use full functionality."
      )
      cli::cli_end()
      return(FALSE)
    }
  }
}

#' Check if text files are equal
#'
#' Compares the contents of two text files.
#'
#' @param path_1 path to file to be compared.
#' @param path_2 path to file to be compared.
#' @return `TRUE` if files are identical, `FALSE` otherwise.
#' @noRd
text_files_are_equal <- function(path_1, path_2) {
  if (!fs::file_exists(path_1)) {
    cli_abort("File {.path { path_1 }} don't exist.")
  }
  if (!fs::file_exists(path_2)) {
    cli_abort("File {.path { path_2 }} don't exist.")
  }
  md5_file_1 <- unname(tools::md5sum(path_1))
  md5_file_2 <- unname(tools::md5sum(path_2))
  return(isTRUE(md5_file_1 == md5_file_2))
}

#' BASH shell exec
#'
#' Execute code in a BASH Shell.
#'
#' @param cmd shell command to be executed
#'   the command is glued accepting variables in curly braces.
#' @param .envir Environment to evaluate the glue expressions in.
#' @export
shell_exec <- function(cmd, .envir = parent.frame()) {
  if (suppressMessages(!is_available("processx"))) {
    cli_abort("{.pkg processx} package is not installed.")
  }
  processx::run(
    command = "bash",
    args = c("-c", glue::glue(cmd, .envir = .envir))
  )
}