inst/doc/symlink_tool_vignette_technical.R

In vmTools: Version Management Tools on the File System

## ----setup, include = FALSE-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)

# for debugging
# knitr::opts_chunk$set(
#   echo = TRUE,
#   message = TRUE,
#   warning = TRUE,
#   error = TRUE
# )

# Chunk options
.opt_width <- options(width = 450)

# save the built-in output hook
hook_output <- knitr::knit_hooks$get("output")
# flags to determine output
flag_eval_chunk <- if (vmTools:::is_windows_admin() | .Platform$OS.type %in% c("unix", "linux")) TRUE else FALSE

# set a new output hook to truncate text output
# - set a chunk option as e.g. : `{r chunk_name, out.lines = 15}`
# if the output is too long, it will be truncated like:
# 
# top output
# ...
# bottom output
knitr::knit_hooks$set(output = function(x, options) {
  if (!is.null(n <- options$out.lines)) {
    x <- vmTools:::split_line_breaks(x)
    if (length(x) > n) {
      # truncate the output
      # x <- c(head(x, n), "....\n")
      x <- c(head(x, n/2), '....', tail(x, n/2 + 1))
    }
    x <- paste(x, collapse = "\n")
  }
  hook_output(x, options)
})


## ----windows_non_admin, echo=FALSE------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
if(!flag_eval_chunk){

 knitr::asis_output("
> **Note:** This vignette demonstrates symbolic link creation, which requires administrator privileges on Windows.
> 
> On systems without these privileges, code chunks are not evaluated, but all code is shown.
> 
> To fully run this vignette, use a Unix-based system or Windows with administrator rights.
")

} 


## ----utils, include = FALSE-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

# Defining a couple vignette utilities

print_tree <- function(x) {vmTools:::dir_tree(x)}

# print a symlink's target from the file system 
print_symlink <- function(symlink_type){
  print(grep(symlink_type, system(paste("ls -alt", root_input), intern = TRUE), value = TRUE))
}

#' Get output directory for results to save in.
#'
#' Returns a path to save results in of the form "YYYY_MM_DD.VV".
#'
#' @param root path to root of output results
#' @param date character date in form of "YYYY_MM_DD" or "today". "today" will be interpreted as today's date.
get_output_dir <- function(root, date) {
  if (date == "today") {
    date <- format(Sys.Date(), "%Y_%m_%d")
  }
  cur.version <- get_latest_output_date_index(root, date = date)
  
  dir.name <- sprintf("%s.%02i", date, cur.version + 1)
  return(dir.name)
}

#' get the latest index for given an output dir and a date
#'
#' directories are assumed to be named in YYYY_MM_DD.VV format with sane
#' year/month/date/version values.
#'
#' @param dir path to directory with versioned dirs
#' @param date character in be YYYY_MM_DD format
#'
#' @return largest version in directory tree or 0 if there are no version OR
#' the directory tree does not exist
get_latest_output_date_index <- function(root, date) {
  currentfolders <- list.files(root)
  
  # subset to date
  pat <- sprintf("^%s[.]\\d{2}$", date)
  date_dirs <- grep(pat, currentfolders, value = T)
  
  if (length(date_dirs) == 0) {
    return(0)
  }
  
  # get the index after day
  date_list <- strsplit(date_dirs, "[.]")
  
  inds <- unlist(lapply(date_list, function(x) x[2]))
  if (is.na(max(inds, na.rm = T))) inds <- 0
  
  return(max(as.numeric(inds)))
}

print_public_methods <- function(SLT){
  output <- capture.output(print(SLT))
  idx_private <- which(output %like% "Private")
  idx_clone <- which(output %like% "clone")
  idx_custom <- which(output %like% "startup guidance messages") # can't get this to print - frustrating
  # idx_custom <- which(output %like% "foo")
  idx_keep <- c(1:idx_private - 1, idx_custom)
  idx_keep <- setdiff(idx_keep, idx_clone)
  cat(paste0(output[idx_keep], collapse = "\n"))
}

## ----naive_tool, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
library(vmTools)
library(data.table)
slt <- try(SLT$new())

## ----first_tool, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# a safe temporary directory every user has access to, that we'll clean up later
root_base   <- file.path(tempdir(), "slt")
root_input  <- file.path(root_base, "to_model")
root_output <- file.path(root_base, "modeled")

PATHS       <- list(
  log_cent       = file.path(root_base, "log_symlinks_central.csv"),
  log_2024_02_02 = file.path(root_input, "2024_02_02", "logs/log_version_history.csv"),
  log_2024_02_10 = file.path(root_input, "2024_02_10", "logs/log_version_history.csv")
)

## ----first_tool2, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
slt <- try(SLT$new(
  user_root_list = list(
    root_input  = root_input,
    root_output = root_output
  )
  , user_central_log_root = root_base
))

## ----first_tool3, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# We need to ensure all output folders exist first
dir.create(root_input, recursive = TRUE, showWarnings = FALSE)
dir.create(root_output, recursive = TRUE, showWarnings = FALSE)

# Now everything should work
suppressWarnings({ # idiosyncratic and benign cluster message
  
  slt <- SLT$new(
    user_root_list = list(
      root_input  = root_input,
      root_output = root_output
    )
    , user_central_log_root = root_base
  )
  
})

## ----reset_cores, include=FALSE---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# multithreading can cause github actions issues
.opt_mccores <- options(mc.cores = 1)

## ----first_tool4, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(root_base)

## ----mark_best2, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
dir.create(file.path(root_input, "2024_02_02"), recursive = TRUE, showWarnings = FALSE)
dir.create(file.path(root_output, "2024_02_02"), recursive = TRUE, showWarnings = FALSE)
dir.create(file.path(root_input, "2024_02_10"), recursive = TRUE, showWarnings = FALSE)
dir.create(file.path(root_output, "2024_02_10"), recursive = TRUE, showWarnings = FALSE)

print_tree(root_base)

## ----mark_best3, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
slt$mark_best(version_name = "2024_02_02", user_entry = list(comment = "testing mark_best"))

## ----mark_best_tree, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(root_base)

## ----mark_best3.1, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_symlink("best")

## ----mark_best4, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# The tool is chatty by default at the console, but it's easy to make it quite if it's part of a pipeline.
suppressMessages({
  slt$mark_best(version_name = "2024_02_10", user_entry = list(comment = "testing mark_best"))
})

## ----mark_best_tree2, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(root_base)

## ----mark_best_tree3, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_symlink("best")

## ----mark_best_logs1, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(PATHS$log_cent)

## ----mark_best_logs2, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(PATHS$log_2024_02_02)

## ----mark_best_logs3, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(PATHS$log_2024_02_10)

## ----reports, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(file.path(root_input, "report_key_versions.csv"))

## ----reports2, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(file.path(root_output, "report_key_versions.csv"))

## ----create_new_folders, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Let's use a programmatic example to build a new `version_name.`
version_name_input  <- get_output_dir(root_input,  "today")
version_name_output <- get_output_dir(root_output, "today")
if(!version_name_input == version_name_output) {
  stop("version_name_input and version_name_output must be the same")
}
version_name_today  <- intersect(version_name_input, version_name_output)

# This creates folders safely, and will not overwrite existing folders if called twice.
slt$make_new_version_folder(version_name = version_name_today)
slt$make_new_version_folder(version_name = version_name_today)

## ----create_new_folders2, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(root_base)

## ----create_new_folders3, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(file.path(root_input, version_name_today, "logs/log_version_history.csv"))

## ----create_new_folders4, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
suppressMessages({
  slt$mark_best(version_name = version_name_today, user_entry = list(comment = "testing mark_best"))
})
data.table::fread(PATHS$log_cent)

## ----create_new_folders5, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(PATHS$log_2024_02_10)

## ----demote_best, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
suppressMessages({
  slt$unmark(version_name = version_name_today, user_entry = list(comment = "testing unmark_best"))
})
print_tree(root_base)

## ----demote_best2, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(PATHS$log_cent)

## ----demote_best3, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(file.path(root_input, version_name_today, "logs/log_version_history.csv"))

## ----demote_report, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(file.path(root_input, "report_key_versions.csv"))

## ----mark_remove, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
suppressMessages({
  slt$mark_remove(version_name = version_name_today, user_entry = list(comment = "testing mark_remove"))
})

## ----mark_remove2, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(root_base)

## ----mark_remove3, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_symlink("remove")

## ----mark_remove4, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(file.path(root_input, version_name_today, "logs/log_version_history.csv"))

## ----mark_remove5, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(file.path(root_input, "report_key_versions.csv"))

## ----delete_folder, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
slt$delete_version_folders(
  version_name = "2024_02_02",
  user_entry   = list(comment = "testing delete_version_folders")
)

## ----delete_folder2, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
slt$delete_version_folders(
  version_name       = version_name_today,
  user_entry         = list(comment = "testing delete_version_folders"),
  require_user_input = FALSE
)

## ----delete_folder4, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(root_base)

## ----delete_folder3, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(PATHS$log_cent)

## ----delete_folder5, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
data.table::fread(file.path(root_input, "report_key_versions.csv"))

## ----mark_keep, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
suppressMessages(
  slt$mark_keep(version_name = "2024_02_10", user_entry = list(comment = "testing mark_keep"))
)

## ----mark_keep2, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(root_base)

## ----mark_keep3, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_symlink("keep")

## ----reports_pt2, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Show the types of reports currently available
slt$make_reports

## ----reports_pt2b, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Run the reports
suppressMessages({
  slt$make_reports()
})
print_tree(root_base)

## ----reports_pt2d, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# View an example report - logs for folders with no active symlink
# - you can see this folder was previously marked 'best'
data.table::fread(file.path(root_input, "report_all_logs_non_symlink.csv"))

## ----reports_pt2e, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Expect this to be absent for the vignette
try(data.table::fread(file.path(root_input, "REPORT_DISCREPANCIES.csv")))

## ----roundup, eval = flag_eval_chunk, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Make a set of dummy folders
dv1  <- get_output_dir(root_input,  "today")
slt$make_new_version_folder(dv1)
dv2  <- get_output_dir(root_input,  "today")
slt$make_new_version_folder(dv2)
dv3  <- get_output_dir(root_input,  "today")
slt$make_new_version_folder(dv3)
dv4  <- get_output_dir(root_input,  "today")
slt$make_new_version_folder(dv4)

print_tree(root_base)

## ----roundup2, eval = flag_eval_chunk, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Mark some as 'remove_'
suppressMessages({
  for(dv in c(dv1, dv2)){
    slt$mark_remove(dv, user_entry = list(comment = "mark_remove for roundup"))
  }
})

## ----roundup3, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Round up and delete
roundup_remove_list <- slt$roundup_remove()

## ----roundup3.1, include = FALSE, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
if(! identical(roundup_remove_list$root_input$version_name, 
               roundup_remove_list$root_output$version_name)){
  
  stop("roundup_remove found different version_names in each `root` folder")
}

## ----roundup4, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
suppressMessages({
  for(dv in roundup_remove_list$root_input$version_name){
    slt$delete_version_folders(
      version_name       = dv,
      user_entry         = list(comment = "roundup_remove"),
      require_user_input = FALSE
    )
  }
})
print_tree(root_base)

## ----roundup6, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
my_date <- format(Sys.Date(), "%Y_%m_%d")
roundup_date_list <- slt$roundup_by_date(
  user_date     = my_date,
  date_selector = "lte" # less than or equal to today's date
)

## ----roundup7, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# mark all our dummy folders (with the ".VV" pattern) as keepers
dv_keep <- grep(
  pattern = "\\.\\d\\d"
  , x     = roundup_date_list$root_input$version_name
  , value = TRUE
)
suppressMessages({
  for(dv in dv_keep){
    slt$mark_keep(dv, user_entry = list(comment = "roundup_by_date"))
  }
})
print_tree(root_base)

## ----make_new_log, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Make a naive folder without a log
dir.create(file.path(root_output, "2024_02_10_naive"))
try(slt$make_new_log(version_name = "2024_02_10_naive"))

## ----make_new_log2, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(root_base)

## ----print, out.lines = 22, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Print all static fields (output truncated)
slt$return_dictionaries()

## ----print2, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# ROOTS are likely most interesting to the user.
slt$return_dictionaries(item_names = "ROOTS")

## ----print3, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Show the last 'action' the tool performed
# - these fields are set as part of each 'marking' new action.
slt$return_dynamic_fields()

## ----clean_up, eval = FALSE, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Finally, clean up all our temporary folders
system(paste("rm -rf", root_base))

## ----clean_up2, include = FALSE, eval = TRUE----------------------------------
options(.opt_width)
options(.opt_mccores)