R/path.R

In dipterix/raveutils: Utility Toolbox for RAVE package

# path-related functions



#' Simple Hard Disk Speed Test
#' @param path an existing directory where to test speed
#' @param file_size in bytes, default is 10 MB
#' @param quiet should verbose messages be suppressed?
#' @return A vector of two: writing and reading speed in MB per seconds.
#' @export
test_hdspeed <- function(path, file_size = 1e7, quiet = FALSE){

  if(!dir.exists(path)){
    rave_error("{path} does not exist.")
    return(c(NA, NA))
  }

  # create tempdir for testing
  test_dir = file.path(path, '.rave_hd_test_', rand_string(8))
  on.exit({
    unlink(test_dir, recursive = TRUE)
  })
  dir_create(test_dir)

  progress = dipsaus::progress2(title = 'Testing read/write speed', max = 2, quiet = quiet)

  progress$inc('Write to disk...')

  # generate 10M file, tested
  file = tempfile(tmpdir = test_dir)
  dat = rand_string(file_size - 1)
  upload = system.time(writeLines(dat, file, useBytes = T))

  progress$inc('Read from disk...')
  download = system.time({dat_c = readLines(file)})

  if(exists('dat_c') && dat_c != dat){
    rave_warn('Uploaded data is broken...')
  }

  ratio = file.info(file)$size / 1000000

  speed = ratio / c(upload[3], download[3])
  names(speed) = NULL
  class(speed) <- 'rave-units'
  attr(speed, 'unit') = 'MB/s'
  attr(speed, 'labels') = c('Write - ', 'Read - ')
  return(speed)
}



#' Try to find path along the root directory
#' @description Try to find \code{path} under root directory even
#' if the original path is missing
#' @param path path to a file. It's fine if the file is missing
#' @param root_dir root directory of the file
#' @return The absolute path of file if exists, or \code{NULL} if
#' missing/failed.
#' @details When file is absent, \code{find_path} concatenates the
#' root directory and path combined to find the file. For example,
#' if the root directory is \code{"~/"}, and path is \code{"a/b/c/d"},
#' the function first seek for existence of \code{"~/a/b/c/d"}. If failed,
#' then \code{"~/b/c/d"}, and then \code{"~/c/d"} until reaching
#' top (root directory).
#'
#' @examples
#' \dontrun{
#' # This example runs when demo (YAB) data are installed
#'
#' # Case 1: path exists from root directory
#' find_path('demo/YAB/rave/meta/electrodes.csv',
#'           root_dir = '~/rave_data/data_dir')
#'
#' # Case 2: path missing from root directory
#' find_path('random/folder/not/exists/demo/YAB/rave/meta/electrodes.csv',
#'           root_dir = '~/rave_data/data_dir')
#'
#' }
#'
#'
#' @export
find_path <- function(path, root_dir){
  if(file.exists(path)){
    return(path)
  }
  # root_dir %?<-% rave_options('data_dir')
  path = unlist(stringr::str_split(path, '(/)|(\\\\)|(\\~)'))
  path = path[path != '']

  for(ii in 1:length(path)){
    tmp_path = do.call(file.path, as.list(c(root_dir, path[ii:length(path)])))
    if(file.exists(tmp_path)){
      return(normalizePath(tmp_path))
    }
  }

  # No path found
  return(NULL)
}


#' @export
package_file <- rave_context_generics('package_file', alist(path=, package=NULL))

#' @export
package_file.default <- function(path, package=NULL){
  package %?<-% from_rave_context('package')
  stopifnot2(length(package), msg = 'package_file: package must be specified or in current context')
  find_path(path, system.file('', package = package, mustWork = TRUE))
}

#' @export
package_file.rave_module_debug <- function(path, package = NULL){
  if(!length(package)){
    package <- from_rave_context('package')
    stopifnot2(requireNamespace('rstudioapi'), msg = 'Please install `rstudioapi` to debug RAVE modules')
    proj <- rstudioapi::getActiveProject()
    proj <- stringr::str_split(proj, '/|\\\\', simplify = TRUE)
    proj <- proj[length(proj)]
    stopifnot2(isTRUE(package == proj), msg = 'package_file: package must be specified or in current context')
    return(normalizePath(file.path(path), mustWork = TRUE))
  }
  find_path(path, system.file('', package = package, mustWork = TRUE))
}



#' @title Force creating directory with checks
#' @param x path to create
#' @param showWarnings,recursive,... passed to \code{\link{dir.create}}
#' @param check whether to check the directory after creation
#' @return Normalized path
#' @export
dir_create <- function(x, showWarnings = FALSE, recursive = TRUE, check = TRUE, ...) {
  if (!dir.exists(x)) {
    dir.create(x, showWarnings = showWarnings, recursive = recursive, ...)
  }
  if (check && !dir.exists(x)) {
    rave_fatal('Cannot create directory at {shQuote(x)}')
  }
  invisible(normalizePath(x))
}


#' Print Directory Tree
#' @param target target directory path, relative to \code{root}
#' @param root root directory, default is \code{'~'}
#' @param child child files in target; is missing, then list all files
#' @param dir_only whether to display directory children only
#' @param ... pass to \code{\link[base]{list.files}} when list all files
#' @return Print-friendly directory tree
#' @export
print_directory_tree <- function(target, root = '~', child, dir_only = FALSE, ...){
  root <- normalizePath(root, winslash = '/', mustWork = FALSE)
  target <- file.path(root, target)
  target <- stringr::str_replace_all(target, '\\\\', '/')
  target <- normalizePath(target, mustWork = FALSE, winslash = '/')

  paths <- stringr::str_split(target, '\\\\|/', simplify = TRUE)
  rpath <- stringr::str_split(root, '\\\\|/', simplify = TRUE)

  tree_id <- cbind(paste(rpath, collapse = '/'), paths[, -seq_along(rpath)])

  df <- list('...' = character(0))

  for(i in seq_len(nrow(tree_id))){

    if(i == 1){
      if( missing(child) ){
        # child is only for the first target
        dir <- target[[i]]
        if( dir.exists(dir) ){
          child <- list.dirs(dir, full.names = FALSE, recursive = FALSE)
          if(!dir_only){
            child <- c(child, list.files(dir, full.names = FALSE, include.dirs = FALSE, ...))
          }
          df[child] <- lapply(child, function(o){ character(0) })
        } else {
          child <- '...'
        }
      } else if(!length(child)){
        child <- character(0)
      } else {
        df[child] <- lapply(child, function(o){ character(0) })
      }
    } else {
      child = '...'
    }

    x <- c(as.list(tree_id[i, ]), list(child), list(''))
    Reduce(function(a,b){
      if(a != '' && length(a) == 1){
        df[[a]] <<- c(df[[a]], b)
      }
      b
    }, x)
  }

  cli::tree(data.frame(names(df), I(unname(lapply(df, function(x){
    x <- x[x!='']
    if(!length(x)){
      x <- character(0)
    }else {
      x <- unique(x)
    }
    x
  })))), root = root)
}