R/box_utils.R

In hemoshear/assayr2: Tools for analyzing assay data

##' A kind wrapper around `boxr::box_push()``
#'
#' Only uploads files in `local_dir`, not folders or hidden/temporary files.
#' @md
#' @param box_dir A integer specifying a Box folder id.
#' @param local_dir Character. Local directory path.
#' @examples
#' \dontrun{
#' box_push2(box_dir) # pushes current working directory
#' }
#' @importFrom purrr walk
#' @export
box_push2 <- function(box_dir, local_dir = ".") {
  local_dir <- normalizePath(local_dir)

  files <- der(local_dir, full.names = TRUE)
  files <- files[grepl("\\.", files)] # keep only files
  purrr::walk(files, ~ boxr::box_ul(box_dir, .))
}

#' A kind wrapper on `boxr::box_fetch()`.`
#'
#' Only downloads files matching specific patterns from a Box folder. Useful for
#' only downloading certain file types. Also saves a .csv with version information
#' for the downloaded files.
#' @md
#' @param box_dir A integer specifying a Box folder id.
#' @param local_dir Character. Local directory path.
#' @param files Character. File extensions to be downloaded.
#' @param ... ... Arguments passed to `boxr::box_dl()`.
#' @examples
#' \dontrun{
#' box_fetch2(box_dir)
#' }
#' @importFrom boxr box_dl box_ls
#' @importFrom utils write.csv
#' @export
box_fetch2 <- function(box_dir, local_dir = ".", files = c("xls", "csv", "txt"),
                       ...) {
  local_dir_path <- normalizePath(local_dir)
  pattern <- paste(files, collapse = "|") %>% paste0(
    "(", .,
    ")"
  )
  box_files <- as.data.frame(boxr::box_ls(box_dir))
  box_files <- box_files[c("name", "id", "version", "modified_at")]
  box_files <- box_files[grepl(pattern, box_files$name), ]
  unlist(box_files$id) %>% purrr::walk(function(x, ...) {
    boxr::box_dl(x, local_dir, ...)
  }, ...)
  if (local_dir == ".") {
    version_file_name <- "box_versions.csv"
  }
  else {
    local_dir_path <- gsub("/$", "", local_dir_path)
    version_file_name <- paste0("/", local_dir_path, "_box_versions.csv")
  }
  write.csv(box_files, version_file_name)
}


#' Compress files needed to reproduce an analysis and
#'   upload to folder on Box
#'
#' @param box_dir (integer) box folder ID where contents of current
#'   directory (recursive) should be uploaded as a ZIP archive
#' @param outfile (character) File path for ZIP archive
#' @param description (character) Box description
#' @param indir (character) Directory files needed to reproduce
#'  an analysis
#' @param max_size (integer) Maximum size of input files in gigabytes
#' @importFrom devtools session_info
#' @importFrom utils zip write.csv
#' @importFrom boxr box_ul
#' @examples
#' \dontrun{
#' # box_archive(51480857605, outfile='HEM0303-3-SMAA.zip',
#' # description = 'Analysis for HEM0303-3 SMAA',
#' # max_size=1e-16)
#' }
#' @export
box_archive <- function(box_dir, outfile, description = "",
                        indir = ".", max_size = 5) {
  # Get total size of files
  size <- sum(file.size(dir(indir)))
  if (size / 1e9 > max_size * 1e9) {
    stop(paste0(
      "Size of files exceeds max_size ", max_size * 1e9,
      " gigabytes."
    ))
  }
  # Write package dependencies
  infiles <- c(dir(indir), "session-info.csv")
  write.csv(as.data.frame(devtools::session_info()$packages), "session-info.csv")
  # Compress files and upload to Box
  zip(zipfile = outfile, files = infiles)
  boxr::box_ul(dir_id = box_dir, file = outfile, description = description)
}

#' Open a browser window via `browseURL()` to look at a Box directory.
#'
#' @md
#' @param box_dir A integer specifying a Box folder id.
#' @examples
#' \dontrun{
#' box_browse(box_dir)
#' }
#' @importFrom utils browseURL
#' @export
box_browse <- function(box_dir) {
  url <- paste0("https://hemoshear.app.box.com/folder/", box_dir)
  browseURL(url)
}

#' Find common files on Box from R with a run ID.
#'
#' Uses `boxr::box_search()` to find the Box IDs for a run of interest.
#' @md
#' @details The return value is intened for a read-in function like `boxr::box_read()`
#' or `assayr2::device_reader()` directly. These 
#' 
#' The Box.com search index does not populate instantly when a new file is uploaded, so
#' recently added (~10-15 minutes) files may not be found by these functions.
#' @param run Character. A HemoShear study id like 'BGA0502-5'
#' @return Numeric, the Box file ID named with the `run` argument.
#' @examples
#' \dontrun{
#' ## Requires BoxR credentials
#' library(boxr)
#' library(magrittr)
#' 
#' box_auth()
#' 
#' find_layout("HEM0401-2")
#'   
#' find_nucs("PAH0363-2")
#' 
#' # this is deprecated in favor of `find_layout()`
#' device_finder("HEM0303-7")
#' 
#' # this is deprecated in favor ot `find_nucs()`
#' nuc_finder("PAH0362-3")
#' }
#' @importFrom stats na.omit setNames
#' @importFrom dplyr filter
#' @importFrom boxr box_search
#' @export
find_layout <- function(run) {
  search_term <- paste(run, "AND Layout")

  search_results <- box_search(search_term,
    content_types = "name",
    file_extensions = c("xls", "xlsx"), max = 10
  ) %>%
    as.data.frame() %>%
    filter(grepl(run, name, ignore.case = T), grepl("(layout)|(experiment)",
      path,
      ignore.case = T
    )) # this seems reasonable, but might cause un-intended problems depending on future folder structure/syntax

  # ask user what file they want
  if (nrow(search_results) > 1) {
    print(select(search_results, name, modified_at))
    user_response <- readline("Select device layout by number: ")
    search_results <- search_results[user_response, ]
  }
  as.numeric(search_results$id) %>% setNames(search_results$name)
}

#' @rdname find_layout
#' @export
find_nucs <- function(run) {
  search_term <- paste(run, "AND nuc AND count")
  search_results <- box_search(search_term,
    content_types = "name",
    file_extensions = c("RDS"), max = 10
  ) %>%
    as.data.frame()
  if (nrow(search_results) > 1) {
    print(select(search_results, name, modified_at))
    user_response <- readline("Select nuc-count by number: ")
    search_results <- search_results[user_response, ]
  }
  as.numeric(search_results$id) %>% setNames(search_results$name)
}

#' @rdname find_layout
#' @md
#' @export
device_finder <- find_layout

#' @rdname find_layout
#' @md
#' @export
nuc_finder <- find_nucs