R/general.R

In iamamutt/mejr: General Purpose R Functions

#' Auto load and install a list of package names
#'
#' This will automatically download a character vector of package names. If they
#' are already installed, it will update them (optional).
#'
#' This will only try to retreive packages from CRAN. It is good to load this at
#' the beginning of a script If you want others to automatically download
#' packages or give a script for someone to run with dependencies You can set
#' \code{update.all} to \code{FALSE} if you don't want to try and update the
#' packages each time it is run.
#'
#' @return NULL
#'
#' @param ...  unquoted package names
#' @param update.all  If TRUE (default), will update all named packages
#' automatically when run.
#' @param pkgs character vector of package names.
#' @param repos Mirror to use for obtaining package
#'
#' @examples
#' auto_load(ggplot2, "data.table")
#' @export
auto_load <- function(..., pkgs=NULL, update.all=FALSE, repos=getOption("repos")) {
  pkgs <- c(kwargs_keys(..., named_only=FALSE), pkgs)
  pkgs <- gsub("[\"']", "", pkgs)

  # find old packages
  if (update.all) {
    old <- unique(unlist(lapply(.libPaths(), function(l) {
      old.packages(l, repos=repos)[, "Package"]
    })))
  } else {
    old <- NULL
  }

  all_pkgs <- .packages(all.available=TRUE)

  for (pkg in pkgs) {
    # first check if package is already installed
    if (isTRUE(pkg %in% all_pkgs)) {
      # attempt to update
      if (pkg %in% old) {
        # only update if it's old
        update.packages(ask=FALSE, oldPkgs=pkg, repos=repos)
        suppressPackageStartupMessages(library(pkg, character.only=TRUE))
        message(paste("\nmejr::auto_load", pkg, "was updated\n"))
      } else {
        # load if no update needed
        library(pkg, character.only=TRUE)
      }
    } else {
      # install and load packages not found
      install.packages(pkg, repos=repos)
      suppressPackageStartupMessages(library(pkg, character.only=TRUE))
      message(paste("\nmejr::auto_load", pkg, "was installed\n"))
    }
  }
  return(invisible(NULL))
}


#' Clear workspace
#'
#' This will clear all objects found in the Global Environment by default. It
#' also clears hidden objects (anything with a \code{.})
#'
#' If you wanted to clear anything else besides Global, specify the environment
#' with the \code{env} argument
#'
#' @return NA
#' @param hidden Removes hidden objects. Logical value. DEFAULT=\code{TRUE}.
#' @param env Specify environment which to remove objects from.
#' DEFAULT=\code{.GlobalEnv}.
#' @family helpers
#' @examples
#' clear_ws()
#' @export
clear_ws <- function(hidden=TRUE, env=.GlobalEnv) {
  rm(list=ls(name=env, all.names=hidden), envir=env)
}


#' Unload package(s)
#'
#' This will force unload a character vector of packages
#'
#' You can use a vector to name more than one package to unload.
#'
#' @return NULL
#' @param ... unquoted package names
#' @family helpers
#' @examples
#' library(tools)
#' library(mejr)
#' unload_pkg(c("tools", "mejr"))
#' @export
unload_pkg <- function(...) {
  pkgs <- unlist(symbol2char(...))
  for (p in pkgs) {
    pos <- grep(paste0("package:", p), search())[1]
    if (!is.na(pos)) {
      detach(pos=pos, unload=TRUE, force=TRUE)
    } else {
      warn_txt <- paste(
        "Cannot find package with name", paste0("package:", p),
        "\nMake sure it has been loaded.\n"
      )
      warning(simpleWarning(warn_txt))
    }
  }
}



#' Override column classes
#'
#' @param x a data.frame or data.table
#' @param class_list a list of class names with each list item containing column
#' names to assign classes to
#'
#' @return same x but with new classes. If data.table, does not copy.
#' @export
#' @examples
#' class_list <- list(character = c("V1", "V2"), double = "V3")
#' x <- data.frame(V1 = letters[3:1], V2 = 1:3, V3 = 1:3)
#'
#' # view current classes, note V1 is a factor
#' sapply(x, class)
#'
#' x$V1 <- as.character(x$V1)
#'
#' # change classes
#' x <- class_override(x, class_list)
#'
#' # view again
#' sapply(x, class)
class_override <- function(x, class_list) {
  cnames <- names(x)
  classes <- names(class_list)
  not_exist <- c()
  for (i in 1:length(class_list)) {
    for (j in class_list[[i]]) {
      if (j %in% cnames) {
        suppressWarnings(mode(x[[j]]) <- classes[i])
      } else {
        not_exist <- c(not_exist, j)
      }
    }
  }
  if (length(not_exist) > 0) {
    warnText <- paste0(
      "The following columns were not found: ", paste0(not_exist, collapse=", ")
    )
    warning(simpleWarning(warnText))
  }
  return(x)
}


#' Prints a section title to console
#'
#' When printing contents to a file, use this to mark sections of code
#'
#' @param x  Section title
#' @param docwidth  Character width (line width)
#' @return NULL, prints to console or sink
#' @family helpers
#' @examples
#' print_sec()
#'
#' print_sec("Results")
#' @keywords section
#' @export
print_sec <- function(x, docwidth=75, console=TRUE) {
  if (missing(x)) {
    x <- ""
  }

  n_char <- nchar(x)
  n_dashes <- docwidth - (n_char + 3)

  if (n_dashes < 0) {
    n_dashes <- 0
  }

  txt <- paste0(c("\n# ", gsub("\n", "", x), " ", rep("-", n_dashes)), collapse="")

  if (!console) {
    return(txt)
  }

  cat(txt, sep="")
}


#' list.files wrapper
#'
#' List all files in a directory recursively using full paths
#'
#' @param x directory string
#' @param ext file extension to search for
#' @param recursive include subdirectories
#'
#' @return character vector
#' @export
#'
#' @examples
#' list_files()
#' list_files(ext='.R')
list_files <- function(x=".", ext=".*", recursive=TRUE) {
  pathstr <- normalizePath(x)
  files <- list.files(pathstr,
    pattern=paste0("\\", ext, "$"), full.names=TRUE,
    recursive=recursive, include.dirs=TRUE, ignore.case=TRUE)
  sort(unlist(lapply(files, abs_path)))
}


#' Check if a character string/vec is empty
#'
#' Checks include NULL, "", or character vectors of length 0.
#'
#' @param x character string or vector of strings
#'
#' @return logical value
#' @export
#'
#' @examples
#' # all empty
#' empty_str(NULL)
#' empty_str("")
#' empty_str(character())
#' empty_str(c("", ""))
#'
#' # not empty, one string contains a space
#' empty_str(c("", " "))
empty_str <- function(x) {
  if (!all(is.character(x) | is.null(x))) {
    stop("must contain characters")
  }

  if (is.null(x) | length(x) == 0) {
    return(TRUE)
  }

  all(!nzchar(x))
}

#' Get current R file path
#'
#' @param parent Return R file parent directory. Logical.
#'
#' @return character
#' @export
#'
#' @examples
#' # to return directory of file the function is being called from.
#' getcrf()
#'
#' # to return file path
#' getcrf(FALSE)
getcrf <- function(parent=TRUE, pos=1L) {
  # 1. check if file is sourced
  frame_files <- lapply(sys.frames(), function(x) {
    unique(c(x$ofile, x$filename))
  })
  frame_files <- Filter(Negate(is.null), frame_files)
  if (length(frame_files) > 0L) {
    # get most recent call from stack
    path <- rev(frame_files)[[pos]]
    if (parent) {
      return(fs::path_dir(path))
    } else {
      return(fs::path_real(path))
    }
  }

  # 2. check if using Rscript executable
  argv <- commandArgs(trailingOnly=FALSE)
  arg_found <- grepl("--file=", argv)
  if (any(arg_found)) {
    path <- fs::path_rel(sub("--file=", "", argv[arg_found]))
    message("Rscript --file=", path)
    if (parent) {
      return(fs::path_dir(path))
    } else {
      return(fs::path(path))
    }
  }

  # 3. check if interactive session
  if (requireNamespace("rstudioapi", quietly=TRUE)) {
    path <- tryCatch(rstudioapi::getActiveDocumentContext()$path, error=function(e) {
      message(e)
      return("")
    })
    if (!empty_str(path)) {
      if (parent) {
        return(fs::path_dir(path))
      } else {
        return(fs::path(path))
      }
    } else {
      return(fs::path())
    }
  }

  # ran out of methods to check R file
  return(fs::path())
}

#' Make absolute path from file/dir path parts
#'
#' @param ... Character vectors of path parts.
#'
#' @return Character string
#' @export
#' @seealso \code{\link{file.path}}, \code{\link{normalizePath}}
#' @examples
#' abs_path(".")
#' abs_path("..", "..")
abs_path <- function(...) {
  normalizePath(file.path(...), mustWork=TRUE, winslash="/")
}


#' Source R files from a directory recursively
#'
#' @param x Character pointing to a valid directory path
#' @param ... Additional arguments passed to \code{\link{source}}
#'
#' @return NULL
#' @export
#' @seealso \code{\link{source}}
#' @examples
#' source_dir("path/to/some/folder")
source_dir <- function(x=NULL, ...) {
  caller_file <- getcrf(parent=FALSE)
  if (is.null(x) || length(x) == 0L) x <- fs::path_dir(caller_file)
  x <- fs::path_real(x)
  src_files <- fs::path_real(list_files(x, ".R", recursive = FALSE))

  # don't source calling file
  if (!empty_str(caller_file)) {
    caller_file <- fs::path_real(caller_file)
    same_dir <- fs::path_dir(src_files) == fs::path_dir(caller_file)
    same_file <- fs::path_file(src_files) == fs::path_file(caller_file)
    src_files <- src_files[!(same_dir & same_file)]
  }

  lapply(src_files, function(i) {
    message(sprintf("Sourcing file: %s", i))
    source(i, ...)
  })

  return(invisible())
}


shuffle_vec <- function(x, k) {
  n <- length(x)

  if (n == 1) {
    x <- seq_len(n)
  }

  k <- as.integer(k)

  if (k < n) {
    shuffled <- unlist(lapply(seq(1L, n, k), function(j) {
      sample(seq(j, j + k - 1))
    }))
    x <- rev(x[shuffled[shuffled %in% seq_len(n)]])
    shuffle_vec(x, k=k * 2)
  } else {
    return(x)
  }
}

wrap_index <- function(i, max) {
  ((i - 1) %% max) + 1
}


#' Get OS abbreviation name
#'
#' @return `character`, one of `WIN` for Windows, `MAC` for Darwin, `LNX` for Linux
#' @export
#'
#' @examples
#' os_name()
os_name <- function() {
  OS <- Sys.info()["sysname"]
  switch(tolower(OS), #
    windows="WIN", #
    darwin="MAC", #
    linux="LNX", #
    stop("Unknown OS abbreviation: ", OS))
}

#' @export
console_str <- function(x) {
  cat('c("', paste0(x, collapse='", "'), '")', sep="")
}