inst/doc/symlink_tool_vignette_intro.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)}

# Make a directory with desired defaults without cluttering the vignette
make_directory <- function(path){
  dir.create(path, recursive = TRUE, showWarnings = FALSE)
}

# print a symlink's target from the file system 
print_symlink <- function(symlink_type, root_input){
  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 = TRUE)
  
  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 = TRUE))) inds <- 0
  
  return(max(as.numeric(inds)))
}

resolve_symlink <- function(path){
   path_resolved <- vmTools:::clean_path(path)
   if(file.exists(path_resolved)) {
      return(path_resolved)
   } else {
      message("Could not resolve symlink: ", path)
   }
}

show_vars <- c("log_id",
               "timestamp",
               "user",
               "version_name",
               # "version_path", # causes ouput to be too wide
               "action",
               "comment")

print_public_methods <- function(class){
  output <- capture.output(print(class))
  idx_private <- which(grepl("Private", output))
  idx_clone <- which(grepl("clone", output))
  idx_custom <- which(grepl("startup guidance messages", output))
  # `initialize` is not the name of the method, may confuse new users
  idx_initialize <- which(grepl("initialize", output))
  output[idx_initialize] <- sub("initialize", "new", output[idx_initialize])
  idx_keep <- c(1:idx_private - 1, idx_custom)
  idx_keep <- setdiff(idx_keep, idx_clone)
  cat(paste0(output[idx_keep], collapse = "\n"))
}

## ----define_root, include = TRUE--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
library(vmTools)
library(data.table)
# Make the root folder
output_root <- file.path(tempdir(), "slt", "output_root")
dir.create(output_root, 
           recursive    = TRUE, 
           showWarnings = FALSE)

## ----call_SLT, eval = FALSE-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# # For this Intro Vignette, we're only showing public methods
# # - for all methods, see the Technical Vignette
# SLT

## ----print_public, echo = FALSE---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# For the intro vignettee, hide private methods
print_public_methods(SLT)

## ----instantiate_slt_prep_display, warning=FALSE, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Instantiate (create) a new Symlink Tool object
slt_prep <- SLT$new(
      user_root_list        = list("output_root" = output_root),
      user_central_log_root = output_root
   )

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

## ----instantiate_slt_prep_display_1, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Look at the directory tree
print_tree(output_root)

## ----baseline_folder_display_1, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
date_vers1 <- get_output_dir(output_root, "2024_02_01")
slt_prep$make_new_version_folder(version_name = date_vers1)

## ----capture_paths_dv1, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
path_log_central <- slt_prep$return_dictionaries()[["LOG_CENTRAL"]][["path"]]
fname_dv_log     <- slt_prep$return_dictionaries()[["log_path"]]
root_dv1         <- slt_prep$return_dynamic_fields()[["VERS_PATHS"]][["output_root"]]
path_log_dv1     <- file.path(root_dv1, fname_dv_log)

## ----baseline_folder_display_2, echo=FALSE, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(output_root)

## ----baseline_folder_display_3, echo=FALSE, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_central <- data.table::fread(path_log_central)[, ..show_vars])

## ----baseline_folder_display_4, echo=FALSE, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_dv1 <- data.table::fread(path_log_dv1)[, ..show_vars])

## ----dummy_results_invis_1, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Make some dummy files
fnames_my_models <- paste0("my_model_", 1:5, ".csv")
invisible(file.create(file.path(root_dv1, fnames_my_models)))

## ----dummy_results_invis_2, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(output_root)

## ----mark_best_dv1, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Mark best, and take note of messaging
slt_prep$mark_best(version_name = date_vers1,
                   user_entry   = list(comment = "Best model GBD2023"))

## ----mark_best_dv1_display_1, echo=FALSE, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_central <- data.table::fread(path_log_central)[, ..show_vars])

## ----mark_best_dv1_display_2, echo=FALSE, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_dv1 <- data.table::fread(path_log_dv1)[, ..show_vars])

## ----mark_best_dv1_display_3, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(output_root)

resolve_symlink(file.path(output_root, "best"))

## ----two_new_runs, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Second run
date_vers2 <- get_output_dir(output_root, "2024_02_01")
slt_prep$make_new_version_folder(version_name = date_vers2)

# note - the dynamic fields update when you make new folders, so we won't see the dv1 path anymore
root_dv2   <- slt_prep$return_dynamic_fields()$VERS_PATHS
invisible(file.create(file.path(root_dv2, fnames_my_models)))

# Third run
date_vers3 <- get_output_dir(output_root, "2024_02_01")
slt_prep$make_new_version_folder(version_name = date_vers3)
root_dv3   <- slt_prep$return_dynamic_fields()$VERS_PATHS
invisible(file.create(file.path(root_dv3, fnames_my_models)))

## ----two_new_runs_display_1, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(output_root)

## ----two_new_runs_display_2, echo=FALSE, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_central <- data.table::fread(path_log_central)[, ..show_vars])

## ----mark_best_dv3, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Mark best, and take note of messaging
slt_prep$mark_best(version_name = date_vers3,
                   user_entry   = list(comment = "New best model GBD2023"))

## ----mark_best_dv3_display_1, echo=FALSE, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_central <- data.table::fread(path_log_central)[, ..show_vars])

## ----mark_best_dv3_second_time, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
slt_prep$mark_best(version_name = date_vers3,
                   user_entry   = list(comment = "New best model GBD2023"))

## ----mark_best_dv3_display_2, echo=FALSE, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_dv1 <- data.table::fread(path_log_dv1)[, ..show_vars])

## ----mark_best_dv3_display_3, echo=FALSE, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_dv2 <- data.table::fread(file.path(root_dv2, fname_dv_log))[, ..show_vars])

## ----mark_best_dv3_display_5, echo=FALSE, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_dv3 <- data.table::fread(file.path(root_dv3, fname_dv_log))[, ..show_vars])

## ----mark_best_dv3_display_4, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(output_root)

resolve_symlink(file.path(output_root, "best"))

## ----mark_keep_dv1, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Mark keep, and take note of messaging
slt_prep$mark_keep(
   version_name = date_vers1,
   user_entry   = list(comment = "Previous best")
)

## ----mark_keep_dv1_display_1, echo=FALSE, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_central <- data.table::fread(path_log_central)[, ..show_vars])

## ----mark_keep_dv1_display_2, echo=FALSE, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_dv1 <- data.table::fread(path_log_dv1)[, ..show_vars])

## ----mark_keep_dv1_display_3, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(output_root)

resolve_symlink(file.path(output_root, "keep_2024_02_01.01"))

## ----mark_remove_dv2, eval = flag_eval_chunk--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Mark remove, and take note of messaging
slt_prep$mark_remove(
   version_name = date_vers2,
   user_entry   = list(comment = "Obsolete dev folder"))

## ----mark_remove_dv2_display_1, echo=FALSE, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_central <- data.table::fread(path_log_central)[, ..show_vars])

## ----mark_remove_dv2_display_3, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(output_root)

resolve_symlink(file.path(output_root, "remove_2024_02_01.02"))

## ----delete_folders, eval = flag_eval_chunk---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(dt_to_remove <- slt_prep$roundup_remove())

## ----delete_folders_2, eval = flag_eval_chunk-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
for(dir_dv_remove in dt_to_remove$output_root$version_name){
   slt_prep$delete_version_folders(
      version_name       = dir_dv_remove,
      user_entry         = list(comment = "Deleting dev folder"),
      require_user_input = FALSE
   )
}

# The default setting prompts user input, but the process can be automated, as for this vignette.
# 
# Do you want to delete the following folders?
#   /tmp/RtmpRmKCTu/slt/output_root/2024_02_01.02
#   /tmp/RtmpRmKCTu/slt/output_root/remove_2024_02_01.02 
# 
# 1: No
# 2: Yes

## ----delete_folders_display_1, echo=FALSE, eval = flag_eval_chunk-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
(log_central <- data.table::fread(path_log_central)[, ..show_vars])

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

## ----reports, eval = flag_eval_chunk----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Generate reports
slt_prep$make_reports()

## ----reports_display_1, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
print_tree(output_root)

## ----reports_display_3, eval = flag_eval_chunk------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

(data.table::fread(file.path(output_root, "report_all_logs.csv")))

## ----clean_up2, include = FALSE, eval = TRUE----------------------------------
system(paste("rm -rf", output_root))
options(.opt_width)
options(.opt_mccores)