My Rprofile.site

Rprofile-site.R

# Things you might want to change

# options(papersize="a4")
# options(editor="notepad")
# options(pager="internal")

# set the default help type
# options(help_type="text")
  options(help_type="html")
  options(askYesNo = function(msg, default = NA, prompts, ...) {
    switch(menu(title = msg, 
                choices = c("Yes", "No", "Cancel"),
                graphics = FALSE),
           switch(TRUE, FALSE, NA))
  })
  
  
  bench_mark <- function(...) {
    if (requireNamespace("bench", quietly = TRUE) &&
        requireNamespace("microbenchmark", quietly = TRUE)) {
      print(bench <- bench::mark(..., check = FALSE))
      
      microbenchmark::microbenchmark(..., times = as.integer(sum(bench$n_itr) / ...length()))
    }
  }
  
  file_size <- function(...) {
    o <- file.info(..., extra_cols = FALSE)
    s <- o$size
    out <- as.character(s)
    wkb <- s >= 1024 & s <= 1024^2
    out[wkb] <- paste0(round(s[wkb] / 1024, 2), " KB")
    wmb <- s >= 1024^2 & s <= 1024^3
    out[wmb] <- paste0(round(s[wmb] / 1024^2, 2), " MB")
    wgb <- s >= 1024^3
    out[wgb] <- paste0(round(s[wgb] / 1024^3, 2), " GB")
    o$Size <- out
    o[, "Size", drop = FALSE]
  }
  
  
  rcmdcheck <- function(pkg = ".", tests = TRUE, vignettes = TRUE) {
    if (!requireNamespace("magrittr", quietly = TRUE)) {
      message("Unable to run rcmdcheck due to package:magrittr being unavailable.")
      return(NULL)
    }
    tempf <- tempfile("")
    dir.create(tempf)
    pkg_copy(pkg, dest = tempf)
    cat("\nMoved to ", normalizePath(tempf, winslash = "/"), ".\n")
    rcmdcheck::rcmdcheck(path = tempf,
                         build_args = if (!vignettes) "--no-build-vignettes",
                         args = if (!tests && !vignettes) {
                           "--no-tests --no-vignettes" 
                         } else if (!tests) {
                           "--no-tests"
                         } else if (!vignettes) {
                           "--no-vignettes"
                         })
  }
  
  pkg_copy <- function(path = ".", dest, use.robocopy = TRUE) {
    get_wd <- getwd()
    on.exit(setwd(get_wd))
    
    robocopy <- function(from = ".", to, recursive = FALSE, ..., J = FALSE) {
      if (!dir.exists(to)) dir.create(to)
      if (use.robocopy && .Platform$OS == "windows" && !identical(from, ".")) {
        shell(paste0("(", 
                     paste("robocopy",
                           from,
                           to, 
                           "*.*", 
                           if (recursive) "/S",
                           if (J) "/J",
                           # Don't print output
                           "> NUL"),
                     ") ",
                     "^& IF %ERRORLEVEL% LEQ 1 exit 0"))
        
      } else {
        base::file.copy(from, to, recursive = recursive, ...)
      }
    }
    
    setwd(path)
    top_level_dirs <- list.dirs(recursive = FALSE, full.names = FALSE)
    ignore_dirs <-
      if (!file.exists(file.path(path, ".Rbuildignore"))) {
        invisible(NULL)
      } else {
        rbuildignore <- readLines(file.path(path, ".Rbuildignore"))
        rbuildignore_unescaped <- sub("^\\^(.*)\\$$", "\\1", rbuildignore)
        rbuildignore_unescaped <-
          gsub("\\.", ".", rbuildignore_unescaped, fixed = TRUE)
        
        igds <- vapply(rbuildignore_unescaped, dir.exists, FALSE)
        igds <- names(igds[igds])
      }
    
    dirs_to_copy <- top_level_dirs 
    dirs_to_copy <- setdiff(dirs_to_copy, ignore_dirs)
    dirs_to_copy <- setdiff(dirs_to_copy, ".git")
    
    dirs_not_yet_excluded <- setdiff(ignore_dirs, top_level_dirs)
    
    # Provide the directory:
    if (!dir.exists(dest)) {
      dir.create(dest)
    }
    
    # Copy the top-level files (regardless of build status)
    '%notin%' <- function(x, y) match(x, y, nomatch = 0L) == 0L
    top_level_files <- dir() 
    top_level_files <- top_level_files[top_level_files %notin% top_level_dirs]
    
    for (i in top_level_files) {
      base::file.copy(i, file.path(dest, i))
    }
    
    for (a in dirs_to_copy) {
      dest_a <- file.path(dest, a)
      if (dir.exists(dest_a)) {
        if (length(dir(dest_a))) {
          stop(normalizePath(dest_a), " exists but is not empty.")
        }
      } else {
        dir.create(dest_a)
      }
      
      
      
      robocopy(a, dest_a, recursive = TRUE)
    }
    setwd(dest)
    
    # It seems quicker to copy then remove than to 
    # try to copy only those needed
    for (file.ignore in rbuildignore_unescaped) {
      if (dir.exists(file.ignore)) {
        unlink(file.ignore, recursive = TRUE)
      }
      
      if (file.exists(file.ignore)) {
        unlink(file.ignore, recursive = TRUE)
      }
    }
    
    
    setwd(get_wd)
    dest
  }
  
  extract_dirs <- function(path = ".", exclude = NULL, at_top_level_now = TRUE) {
    if (at_top_level_now) {
      if (!file.exists(flie.path(path, ".Rbuildignore"))) {
        warning("No .Rbuildignore file so returning NULL")
        invisible(NULL)
      }
      rbuildignore <- readLines(file.path(path, ".Rbuildignore"))
      rbuildignore_unescaped <- sub("^\\^(.*)\\$$", "\\1", rbuildignore)
      rbuildignore_unescaped <-
        gsub("\\.", ".", rbuildignore_unescaped, fixed = TRUE)
    }
  }
  
  robocopy_except <- function(from, to, except = NULL) {
    if (!is.null(except)) {
      current_dirs <- list.dirs(recursive = FALSE, full.names = FALSE)
      except_parents <- dirname(except)
      
      if (any(vapply(except_parents, dir.exists, FALSE))) {
        
      }
    }
  }
  
  robocopy <- function(from, to, recursive, J) {
    shell(paste0("(", 
                 paste("robocopy",
                       from,
                       to, 
                       "*.*", 
                       if (recursive) "/S",
                       if (J) "/J",
                       # Don't print output
                       "> NUL"),
                 ") ",
                 "^& IF %ERRORLEVEL% LEQ 1 exit 0"))
  }
  
  detach_and_unload <- function(pkgname, and_revdeps = FALSE) {
    if (!isNamespaceLoaded(pkgname)) {
      message(pkgname, " was not loaded.")
      return(invisible(NULL))
    }
    
    if (length(revdeps <- getNamespaceUsers(asNamespace(pkgname)))) {
      if (and_revdeps) {
        for (pkg in revdeps) {
          detach(paste0("package:", pkg), unload = TRUE, character.only = TRUE)
        }
        
      } else {
        if (!interactive()) {
          stop("Package '", pkgname, "' is currently being used by the following so won't be unloaded.\n\t", 
               paste0(revdeps, collapse = "\n\t"))
        }
        menu_response <-
          menu(title = paste0("Do you wish to also unload ",
                              paste0(revdeps, collapse = ", "), 
                              "?"),
               choices = c("Yes", "No"),
               graphics = FALSE)
        if (menu_response == 2L) {
          message("Not detached or unloaded.")
          return(invisible(NULL))
        }
        if (menu_response == 1L) {
          for (pkg in revdeps) {
            # cat(paste0("package:", pkg))
            detach_and_unload(pkg)
          }
        }
        
      }
    }
    if (pkgname %in% .packages()) {
      detach(paste0("package:", pkgname), unload = TRUE, character.only = TRUE)
    } else {
      unloadNamespace(pkgname)
    }
  }
  
  
  
  
  
  
  
  # set a site library
  # .Library.site <- file.path(chartr("\\", "/", R.home()), "site-library")

# set a CRAN mirror
# local({r <- getOption("repos")
#       r["CRAN"] <- "http://my.local.cran"
#       options(repos=r)})

# Give a fortune cookie, but only to interactive sessions
# (This would need the fortunes package to be installed.)
#  if (interactive()) 
#    fortunes::fortune()