envsetup coverage - 85.62%

Files
Source

#' Environment Setup Environment
#'
#' A dedicated environment object used to store and manage path configurations
#' and other setup variables for the envsetup package. This environment provides
#' an isolated namespace for storing path objects that can be retrieved using
#' the package's path management functions.
#'
#' @returns An environment object created with \code{new.env()}.
#'
#' @details
#' This environment serves as the default storage location for path objects
#' when using envsetup package functions. It helps maintain clean separation
#' between user workspace and package-managed paths.
#'
#' @examples
#' # Store a path in the envsetup environment
#' assign("project_root", "/path/to/project", envir = envsetup_environment)
#'
#' # List objects in the environment
#' ls(envir = envsetup_environment)
#'
#' # Check if the environment exists and is an environment
#' exists("envsetup_environment")
#' is.environment(envsetup_environment)
#'
#' @seealso \code{\link{get_path}}, \code{\link[base]{new.env}}
#'
#' @export
envsetup_environment <- new.env()

#' Get Path Object from Environment
#'
#' Retrieves a path object from the specified environment using non-standard
#' evaluation. The function uses `substitute()` to capture the unevaluated
#' expression and `get()` to retrieve the corresponding object.
#'
#' @param path An unquoted name of the path object to retrieve from the environment.
#' @param envir The environment to search for the path object. Defaults to the
#'   value of `getOption("envsetup.path.environment")`.
#'
#' @return The path object stored in the specified environment under the given name.
#'
#' @examples
#' # Create a custom environment and store some paths
#' path_env <- new.env()
#' assign("data_dir", "/home/user/data", envir = path_env)
#' assign("output_dir", "/home/user/output", envir = path_env)
#'
#' # Set up the option to use our custom environment
#' options(envsetup.path.environment = path_env)
#'
#' # Retrieve paths using the function
#' data_path <- get_path(data_dir)
#' output_path <- get_path(output_dir)
#'
#' print(data_path)    # "/home/user/data"
#' print(output_path)  # "/home/user/output"
#'
#' # Using with a different environment
#' temp_env <- new.env()
#' assign("temp_dir", "/tmp/analysis", envir = temp_env)
#' temp_path <- get_path(temp_dir, envir = temp_env)
#' print(temp_path)    # "/tmp/analysis"
#'
#' @seealso \code{\link[base]{get}}, \code{\link[base]{substitute}}
#'
#' @export
get_path <- function(path, envir = getOption("envsetup.path.environment")){
  base::get(substitute(path), envir)
}

#' Read path
#'
#' Check each environment for the file and return the path to the first.
#'
#' The environments searched depends on the current environment.
#' For example, if your workflow contains a development (dev) area and
#' production area (prod), and the code is executing in the dev environment,
#' we search dev and prod. If in prod, we only search prod.
#'
#' @param lib object containing the paths for all environments of a directory
#' @param filename name of the file you would like to read
#' @param full.path logical to return the path including the file name
#' @param envsetup_environ name of the environment you would like to read the file from;
#' default values comes from the value in the system variable ENVSETUP_ENVIRON
#' which can be set by Sys.setenv(ENVSETUP_ENVIRON = "environment name")
#' @param envir The environment to search for the path object. Defaults to the
#'   value of `getOption("envsetup.path.environment")`.
#'
#' @importFrom rlang quo_get_expr enquo is_string
#'
#' @return string containing the path of the first directory the file is found
#' @export
#'
#' @examples
#' tmpdir <- tempdir()
#'
#' # account for windows
#' if (Sys.info()['sysname'] == "Windows") {
#'   tmpdir <- gsub("\\", "\\\\", tmpdir, fixed = TRUE)
#' }
#'
#' # add config for just the data location
#' hierarchy <- paste0("default:
#'   paths:
#'     data: !expr list(
#'       DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'data'),
#'       PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'data'))")
#'
#' # write config file to temp directory
#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
#'
#' config <- config::get(file = file.path(tmpdir, "hierarchy.yml"))
#'
#' # build folder structure from config
#' build_from_config(config)
#'
#' # setup environment based on config
#' rprofile(config::get(file = file.path(tmpdir, "hierarchy.yml")))
#'
#' # place data in prod data folder
#' saveRDS(mtcars, file.path(tmpdir, "demo/PROD/project1/data/mtcars.rds"))
#'
#' # find the location of mtcars.rds
#' read_path(data, "mtcars.rds")
read_path <- function(lib,
                      filename,
                      full.path = TRUE,
                      envsetup_environ = Sys.getenv("ENVSETUP_ENVIRON"),
                      envir = getOption("envsetup.path.environment")) {

  # lib can be a object in a different environment
  # get this directly from envsetup_environment
  lib_arg <- quo_get_expr(enquo(lib))

  if (is_string(lib_arg)) {
    stop(paste(
      "The lib argument should be an object containing the paths",
      "for all environments of a directory, not a string."
    ), call. = FALSE)
  }

  read_lib <- base::get(toString(lib_arg), envir)

  restricted_paths <- read_lib

  if (length(read_lib) > 1 && envsetup_environ == "") {
    stop(paste(
      "The envsetup_environ parameter or ENVSETUP_ENVIRON environment",
      "variable must be used if hierarchical paths are set."
    ), call. = FALSE)
  }

  if (envsetup_environ %in% names(read_lib)) {
    restricted_paths <- read_lib[which(names(read_lib) == envsetup_environ):length(read_lib)]
  } else if (length(read_lib) > 1) {
    warning(paste(
      "The path has named environments",
      usethis::ui_field(names(read_lib)),
      "that do not match with the envsetup_environ parameter",
      "or ENVSETUP_ENVIRON environment variable",
      usethis::ui_field(envsetup_environ)
    ), call. = FALSE)
  }

  # find which paths have the object
  path_has_object <-
    sapply(
      unlist(restricted_paths),
      object_in_path,
      filename,
      simplify = TRUE
    )

  if (any(path_has_object) == FALSE) {
    stop(paste0(filename, " not found in ", substitute(read_lib)))
  }

  # subset and keep the first
  first_directory_found <- unlist(restricted_paths)[path_has_object][[1]]

  if (full.path == TRUE) {
    out_path <- file.path(first_directory_found, filename)
  } else {
    out_path <- first_directory_found
  }

  message("Read Path:", out_path, "\n")
  out_path
}


#' Retrieve a file path from an envsetup object containing paths
#'
#' Paths will be filtered to produce the lowest available level from a hierarchy
#' of paths based on envsetup_environ
#'
#' @param lib Object containing the paths for all environments of a directory
#' @param filename Name of the file you would like to write
#' @param envsetup_environ Name of the environment to which you would like to
#'   write. Defaults to the ENVSETUP_ENVIRON environment variable
#' @param envir The environment to search for the path object. Defaults to the
#'   value of `getOption("envsetup.path.environment")`.
#'
#' @importFrom rlang quo_get_expr enquo is_string
#'
#' @return path to write
#' @export
#'
#' @examples
#' tmpdir <- tempdir()
#'
#' # account for windows
#' if (Sys.info()['sysname'] == "Windows") {
#'   tmpdir <- gsub("\\", "\\\\", tmpdir, fixed = TRUE)
#' }
#'
#' # add config for just the data location
#' hierarchy <- paste0("default:
#'   paths:
#'     data: !expr list(
#'       DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'data'),
#'       PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'data'))")
#'
#' # write config file to temp directory
#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
#'
#' config <- config::get(file = file.path(tmpdir, "hierarchy.yml"))
#'
#' # build folder structure from config
#' build_from_config(config)
#'
#' # setup environment based on config
#' rprofile(config::get(file = file.path(tmpdir, "hierarchy.yml")))
#'
#' # find location to write mtcars.rds
#' write_path(data, "mtcars.rds")
#'
#' # save data in data folder using write_path
#' saveRDS(mtcars, write_path(data, "mtcars.rds"))
write_path <- function(lib, filename = NULL, envsetup_environ = Sys.getenv("ENVSETUP_ENVIRON"),
                       envir = getOption("envsetup.path.environment")) {
  # examine lib to ensure it's not a string
  # if it's a string, you end up with an incorrect path
  lib_arg <- quo_get_expr(enquo(lib))

  if (is_string(lib_arg)) {
    stop(paste(
      "The lib argument should be an object containing the paths",
      "for all environments of a directory, not a string."
    ), call. = FALSE)
  }

  write_path <- base::get(toString(lib_arg), envir)
  path <- write_path

  if (length(write_path) > 1 && envsetup_environ == "") {
    stop(paste(
      "The envsetup_environ parameter or ENVSETUP_ENVIRON environment",
      "variable must be used if hierarchical paths are set."
    ), call. = FALSE)
  }

  if (envsetup_environ %in% names(write_path)) {
    path <- path[[envsetup_environ]]
  } else if (length(write_path) > 1) {
    warning(paste(
      "The path has named environments",
      usethis::ui_field(names(lib)),
      "that do not match with the envsetup_environ parameter",
      "or ENVSETUP_ENVIRON environment variable",
      usethis::ui_field(envsetup_environ)
    ), call. = FALSE)
  }

  out_path <- path

  if (!is.null(filename)) {
    out_path <- file.path(path, filename)
  }

  message("Write Path:", out_path, "\n")
  out_path
}


# return T/F for if the data exists in the directories
object_in_path <- function(path, object) {
  f_path <- file.path(path, object)
  file.exists(f_path)
}




#' Build directory structure from a configuration file
#'
#' @param config configuration object from config::get() containing paths
#' @param root root directory to build from.
#' Leave as NULL if using absolute paths.  Set to working directory if using relative paths.
#'
#' @importFrom fs dir_tree
#' @importFrom usethis ui_done
#'
#' @return Called for its side-effects. The directories build print as a tree-like format from `fs::dir_tree()`.
#' @export
#'
#' @examples
#' tmpdir <- tempdir()
#'
#' hierarchy <- "default:
#'   paths:
#'     data: !expr list(DEV = '/demo/DEV/username/project1/data',
#'                      PROD = '/demo/PROD/project1/data')
#'     output: !expr list(DEV = '/demo/DEV/username/project1/output',
#'                        PROD = '/demo/PROD/project1/output')
#'     programs: !expr list(DEV = '/demo/DEV/username/project1/programs',
#'                          PROD = '/demo/PROD/project1/programs')
#'     docs: !expr list(DEV = 'docs',
#'                      PROD = 'docs')"
#'
#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
#'
#' config <- config::get(file = file.path(tmpdir, "hierarchy.yml"))
#'
#' build_from_config(config, tmpdir)
build_from_config <- function(config, root = NULL) {
  if (!exists("paths", where = config)) {
    usethis::ui_oops("No paths are specified as part of your configuration.  Update your config file to add paths.")
    return(invisible())
  }

  if (is.null(root)) {
    paths <- unlist(config$paths, use.names = FALSE)
  } else {
    paths <- file.path(root, unlist(config$paths, use.names = FALSE))
  }

  walk(paths, ~ {
    if (!dir.exists(.x)) {
      dir.create(.x, recursive = TRUE)
    }
  })

  # find the root of the paths provided in the config
  if (is.null(root)) {
    base_path <- strsplit(paths[1], "")[[1]]

    for (i in seq_along(paths)) {
      compare_path <- strsplit(paths[i], "")[[1]]

      end <- min(length(base_path), length(compare_path))

      tf <- base_path[1:end] == compare_path[1:end]

      first_false <- min(which(tf == FALSE), end + 1)

      base_path <- base_path[1:first_false - 1]
    }

    root <- paste0(base_path, collapse = "")
  }

  ui_done("Directories built")
  dir_tree(root, type = "directory")
}

#' Initialize the R environment with envsetup
#'
#' @param project Character. The path to the project directory.
#' @param config_path Character. The path of the config file. Defaults to NULL.
#' @param create_paths Logical indicating if missing paths should be created. Defaults to NULL.
#' @export
#' @importFrom usethis ui_yeah ui_oops ui_info ui_done
#' @importFrom config get
#' @return Called for its side-effects.
#'
#' @examples
#' tmpdir <- tempdir()
#' print(tmpdir)
#'
#' # account for windows
#' if (Sys.info()['sysname'] == "Windows") {
#'   tmpdir <- gsub("\\", "\\\\", tmpdir, fixed = TRUE)
#' }
#'
#' # Create an example config file\
#' hierarchy <- paste0("default:
#'   paths:
#'     data: !expr list(
#'       DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'data'),
#'       PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'data'))
#'     output: !expr list(
#'       DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'output'),
#'       PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'output'))
#'     programs: !expr list(
#'       DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'programs'),
#'       PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'programs'))")
#'
#'
#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
#'
#' init(project = tmpdir,
#'      config_path = file.path(tmpdir, "hierarchy.yml"),
#'      create_paths = TRUE)
init <- function(project, config_path = NULL, create_paths = NULL) {

  create_config <- FALSE
  config_found <- FALSE

  if (is.null(config_path)) {
    create_config <- ui_yeah("No path to an exisiting configuration file was provided.
                             Would you like us to create a default configuration in your project directory?",
      n_no = 1
    )
  } else {
    if (file.exists(config_path) && !dir.exists(config_path)) {
      config_found <- TRUE

      usethis::ui_done("Configuration file found!")

      # verify directories exist
      config <- config::get(file = config_path)

      if (!exists("paths", where = config)) {
        ui_oops("No paths are specified as part of your configuration.  Update your config file to add paths.")
        return(invisible())
      }

      paths <- unlist(config$paths, use.names = FALSE)

      missing_directories <- !vapply(paths, dir.exists, TRUE)

      if (any(missing_directories)) {
        ui_info(
          c("The following paths in your configuration do not exist:",
            paths[missing_directories])
        )

        # if not, ask if user would like them built
        if (is.null(create_paths)) {
          create_paths <-
            usethis::ui_yeah(
              "Would you like us to create your directories to match your configuration?",
              n_no = 1
            )
        }

        if (!create_paths) {
          ui_info("All path objects will not work since directories are missing.")
        }
      }
    } else {
      stop(paste("No configuration file is found at", config_path), call. = FALSE)
    }
  }

  # if user agrees, write a configuration file to the project directory and create paths
  if (create_config) {
    default_path <- system.file("default_envsetup.yml", package = "envsetup", mustWork = TRUE)

    config_path <- file.path(project, "envsetup.yml")

    file.copy(default_path, config_path, overwrite = TRUE)

    ui_done(paste("Configuration file (envsetup.yml) has been written to", project))

    create_paths <- TRUE
  } else if (config_found <- FALSE) {
    stop("Aborting envsetup initialization.  A configuration file is needed.", call. = FALSE)
  }

  # create the .Rprofile or add envsetup to the bottom
  add <- sprintf(
    '\nlibrary(envsetup)\nrprofile(config::get(file = "%s"))',
    config_path
  )

  envsetup_write_rprofile(
    add    = add,
    file   = file.path(project, ".Rprofile")
  )

  if (create_paths) {
    build_from_config(
      config::get(file = config_path)
    )
  }

  ui_done("envsetup initialization complete")
}

envsetup_write_rprofile <- function(add, file) {
  if (!file.exists(file)) {
    writeLines(add, file)
    ui_done(paste(".Rprofile created"))
    return(TRUE)
  }

  before <- readLines(file, warn = FALSE)

  # if there is a call to `rprofile()` in the .Rprofile, assume setup was already done and exit
  if (any(grepl("rprofile\\(", before))) {
    warning("It looks like your project has already been initialized to use envsetup.
            Manually adjust your .Rprofile if you need to change the environment setup.",
      call. = FALSE
    )
    return(invisible())
  }

  after <- c(before, add)

  writeLines(after, file)

  ui_done(paste(".Rprofile updated"))
}

#' Set the R autos
#'
#' Set the directory paths of any 'autos'. 'Autos' are
#' directory paths that hold .R files containing R functions. These paths may be
#' used when functions apply to an analysis, protocol, or even at a global
#' level, but don't fit in or necessarily require a package or haven't been
#' incorporated into a package.
#'
#' @param autos named list of character vectors
#' @param envsetup_environ name of the environment you would like to read from;
#' default values comes from the value in the system variable ENVSETUP_ENVIRON
#' which can be set by Sys.setenv(ENVSETUP_ENVIRON = "environment name")
#' @param overwrite logical indicating if sourcing of autos should overwrite an object in global if it already exists
#'
#' @return Called for side-effects. Directory paths of the R autos added to search path are printed.
#'
#' @importFrom purrr walk walk2
#' @importFrom rlang is_named
#' @importFrom usethis ui_field
#' @noRd
set_autos <- function(autos, envsetup_environ = Sys.getenv("ENVSETUP_ENVIRON"), overwrite = TRUE) {

  # Must be named list
  if (!is_named(autos)) {
    stop("Paths for autos in your envsetup configuration file must be named", call. = FALSE)
  }

  # remove NULL before further processing
  # NULL is expected for hierarchical paths when running in an environment
  # after the first level of the hierarchy
  autos <- autos[!vapply(autos, is.null, FALSE)]

  for (i in seq_along(autos)) {
    cur_autos <- autos[[i]]

    if (length(cur_autos) > 1) {
      # Hierarchical paths must be named
      if (!is_named(cur_autos)) {
        stop("Hierarchical autos paths in your envsetup configuration file must be named", call. = FALSE)
      }

      # envsetup_environ must be used if using hierarchical paths
      if (envsetup_environ == "") {
        stop(paste(
          "The envsetup_environ parameter or ENVSETUP_ENVIRON environment",
          "variable must be used if hierarchical autos are set."
        ), call. = FALSE)
      }
    }

    if (!is.null(names(cur_autos)) && !envsetup_environ %in% names(cur_autos)
        && envsetup_environ != "") {
      warning(paste(
        "The", ui_field(names(autos[i])), "autos has named",
        "environments",  ui_field(names(cur_autos)),
        "that do not match with the envsetup_environ parameter",
        "or ENVSETUP_ENVIRON environment variable",
        ui_field(envsetup_environ)
      ), call. = FALSE)
    }

    filtered_autos <- cur_autos

    if (envsetup_environ %in% names(cur_autos)) {
      filtered_autos <-
        cur_autos[which(names(cur_autos) == envsetup_environ):length(cur_autos)]
    }

    autos[[i]] <- filtered_autos
  }

  # Flatten the paths to collapse the names down to a single vector
  flattened_paths <- unlist(autos)

  # Check the autos before they're set
  if (!(is.null(flattened_paths) || is.character(flattened_paths))) {
    stop("Paths provided for autos must be directories", call. = FALSE)
  }

  # If there are any existing autos then reset them
  detach_autos()

  # Now source everything
  walk2(
    flattened_paths,
    names(flattened_paths),
    ~ attach_auto(.x, .y, overwrite = overwrite)
  )
}

#' Source scripts and warn of conflicts
#'
#' Source a script, only adding objects to global if they do not already exist
#'
#' @param file path to a script containing object to add to global
#' @param overwrite logical indicating if sourcing should overwrite an object in global if it already exists
#'
#' @importFrom usethis ui_value
#'
#' @return Called for side-effects. Objects are added to the global environment.
#'
#' @noRd
source_warn_conflicts <- function(file, overwrite = TRUE){

  # create a new environment to source into
  new_env <- new.env()

  cat("Sourcing file: ", ui_value(file), "\n")

  # source directory into a this environment
  sys.source(file,
             envir = new_env)

  # compare objects to find unique and non-unique
  objects_in_new_env <- ls(new_env)
  objects_in_global <- ls(.GlobalEnv)

  if (overwrite == FALSE) {
    objects_to_assign <- setdiff(objects_in_new_env, objects_in_global)
    objects_to_skip_assign <- intersect(objects_in_new_env, objects_in_global)
    objects_that_are_overwritten <- NULL
  } else if (overwrite == TRUE) {
    objects_to_assign <- objects_in_new_env
    objects_to_skip_assign <- NULL
    objects_that_are_overwritten <- intersect(objects_in_new_env, objects_in_global)
  } else {
    warning("overwrite must contain a logical")
  }

  for (obj_name in objects_to_assign) {
    assign_and_move_function(obj_name, temp_env = new_env, envir = .GlobalEnv)
    record_function_metadata(obj_name, file)
  }

  if (length(objects_to_assign) != 0) {
    cat("\n The following objects are added to .GlobalEnv:", sep = "\n")
    cat("", sep = "\n")
    cat(paste0("    ", ui_value(objects_to_assign), "\n"))
  }


  if (length(objects_to_skip_assign) != 0) {
    cat("\n The following objects were not added to .GlobalEnv as they already exist:", sep = "\n")
    cat("", sep = "\n")
    cat(paste0("    ", ui_value(objects_to_skip_assign), "\n"))
  }


  if (length(objects_that_are_overwritten) != 0) {
    cat("\n The following objects were overwritten in .GlobalEnv:", sep = "\n")
    cat("", sep = "\n")
    cat(paste0("    ", ui_value(objects_that_are_overwritten), "\n"))
  }

  cat("", sep = "\n")

}


assign_and_move_function <- function(obj_name, temp_env, envir){
  assign(obj_name, base::get(obj_name, envir = temp_env), envir = envir)
}


record_function_metadata <- function(obj_name, file){

  # store the metadata for the objects
  new_record <- data.frame(
    object_name = obj_name,
    script = file
  )

  if (exists("object_metadata", envsetup_environment)) {
    df <- merge(
      base::get("object_metadata", envsetup_environment),
      new_record,
      by = "object_name",
      all = TRUE
      )

    if (any(c("script.x", "script.y") %in% names(df))) {
      df$script <- ifelse(is.na(df$script.y), df$script.x, df$script.y)
      df$script.x <- NULL
      df$script.y <- NULL
    }

    envsetup_environment$object_metadata <- df
  } else {
    envsetup_environment$object_metadata <- new_record
  }

}

#' Source order of functions
#'
#' This function is used to define the sorting order of functions if
#' `@include` is used to define function dependencies.
#'
#' @param path Directory path
#'
#' @importFrom utils getFromNamespace
#'
#' @noRd
collate_func <- function(path){
  r_scripts <- list.files(path,
                          pattern = ".r$",
                          ignore.case = TRUE,
                          full.names = TRUE
  )

  generate_collate <- utils::getFromNamespace("generate_collate", "roxygen2")

  collated_func <- generate_collate(path)

  if (is.null(collated_func)) {
    r_scripts
  } else {
    sapply(1:length(collated_func), function(x) file.path(path, collated_func[[x]]))
  }

}


#' Attach a function directory
#'
#' This function is used to create an rautos path. All .R files from a given
#' path are sourced. Functions are imported into from a directory and returned
#' to an environment. This environment can then be used to attach on to the
#' search path. This function should not be called directly. To apply autos,
#' use `set_autos()`.
#'
#' @param path Directory path
#' @param name Directory name
#' @param overwrite logical indicating if sourcing of autos should overwrite an object in global if it already exists
#' @noRd
#'
#' @return Called for side-effects. Directory paths of the R autos added to search path are printed.
attach_auto <- function(path, name, overwrite = TRUE) {

  if (!(dir.exists(path) || file.exists(path))) {
    # Check if the auto actually exists
    warning(sprintf("An autos path specified in your envsetup configuration file does not exist: %s = %s", name, path),
            call. = FALSE)
  } else if (file.exists(path) && !dir.exists(path)) {
    # if file, source it
    source_warn_conflicts(path, overwrite = overwrite)
  } else {
    collated_r_scripts <- collate_func(path)

    if (!identical(collated_r_scripts, character(0))) {
      walk(collated_r_scripts, source_warn_conflicts, overwrite = overwrite)
    } else {
      message("No files found in ", path, ". Nothing to attach.")
    }
  }
}

#' Detach the autos from the current session
#'
#' This function will remove any autos that have been set from the search path
#'
#' @return Called for its side-effects.
#' @export
#'
#' @examples
#' tmpdir <- tempdir()
#' print(tmpdir)
#'
#' # account for windows
#' if (Sys.info()['sysname'] == "Windows") {
#'   tmpdir <- gsub("\\", "\\\\", tmpdir, fixed = TRUE)
#' }
#'
#' # Create an example config file\
#' hierarchy <- paste0("default:
#'   paths:
#'     functions: !expr list(DEV = file.path('",tmpdir,"',
#'                                           'demo',
#'                                           'DEV',
#'                                           'username',
#'                                           'project1',
#'                                           'functions'),
#'                           PROD = file.path('",tmpdir,"',
#'                                            'demo',
#'                                            'PROD',
#'                                            'project1',
#'                                            'functions'))
#'   autos:
#'      my_functions: !expr list(DEV = file.path('",tmpdir,"',
#'                                               'demo',
#'                                               'DEV',
#'                                               'username',
#'                                               'project1',
#'                                               'functions'),
#'                               PROD = file.path('",tmpdir,"',
#'                                                'demo',
#'                                                'PROD',
#'                                                'project1',
#'                                                'functions'))")
#'
#' # write config
#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
#'
#' config <- config::get(file = file.path(tmpdir, "hierarchy.yml"))
#'
#' build_from_config(config)
#'
#' # write function to DEV
#' writeLines("dev_function <- function() {print(environment(dev_function))}",
#'            file.path(tmpdir, 'demo', 'DEV', 'username', 'project1', 'functions', 'dev_function.r'))
#'
#' # write function to PROD
#' writeLines("prod_function <- function() {print(environment(prod_function))}",
#'            file.path(tmpdir, 'demo', 'PROD', 'project1', 'functions', 'prod_function.r'))
#'
#' # setup the environment
#' Sys.setenv(ENVSETUP_ENVIRON = "DEV")
#' rprofile(config::get(file = file.path(tmpdir, "hierarchy.yml")))
#'
#' # show dev_function() and prod_function() are available and print their location
#' dev_function()
#' prod_function()
#'
#' # remove autos from search
#' detach_autos()
detach_autos <- function() {

  if (exists("object_metadata", envir = envsetup_environment)){
    rm(list = envsetup_environment$object_metadata$object_name, envir = .GlobalEnv)
    rm("object_metadata", envir = envsetup_environment)
  }

}

#' Function used to pass through code to the .Rprofile
#'
#' @param config configuration object from config::get()
#' @param envir The environment to search for the path object. Defaults to the
#'   value of `getOption("envsetup.path.environment")`.
#' @param overwrite logical indicating if sourcing of autos should overwrite an object in global if it already exists
#' @importFrom envnames environment_name
#' @export
#' @return Called for its side effects.  Directory paths and autos are added to the search path based on your config.
#'
#' @examples
#' # temp location to store configuration files
#' tmpdir <- tempdir()
#' print(tmpdir)
#'
#' # Create an example config file
#' hierarchy <- "default:
#'   paths:
#'     data: !expr list(DEV = '/demo/DEV/username/project1/data',
#'                      PROD = '/demo/PROD/project1/data')
#'     output: !expr list(DEV = '/demo/DEV/username/project1/output',
#'                        PROD = '/demo/PROD/project1/output')
#'     programs: !expr list(DEV = '/demo/DEV/username/project1/programs',
#'                          PROD = '/demo/PROD/project1/programs')"
#'
#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
#'
#' rprofile(config::get(file = file.path(tmpdir, "hierarchy.yml")))
rprofile <- function(config,
                     envir = getOption("envsetup.path.environment"),
                     overwrite = TRUE) {

  # remove autos and pass everything else to "envsetup:paths"
  config_minus_autos <- config
  config_minus_autos$autos <- NULL

  walk2(names(config_minus_autos$paths),
        config_minus_autos$paths,
        assign,
        envir = envir)

  message(paste0("Assigned paths to ", environment_name(envir)))

  # store config with a standard name in a standard location
  assign("auto_stored_envsetup_config", config, envir = envir)

  # If autos exist, set them
  if (!is.null(config$autos)) {
    set_autos(config$autos, overwrite = overwrite)
  }
}

#' Validate a configuration file
#'
#' A helper function to help troubleshoot common problems that can occur when
#' building your configuration file.
#'
#' @param config configuration object from config::get()
#'
#' @return Called for its side-effects. Prints findings from validation checks.
#' @export
#'
#' @examples
#' # temp location to store configuration files
#' tmpdir <- tempdir()
#' print(tmpdir)
#'
#' # Each path only points to one location, i.e. there is no hierarchy for a path
#' no_hierarchy <- 'default:
#'   paths:
#'     data: "/demo/DEV/username/project1/data"
#'     output: "/demo/DEV/username/project1/output"
#'     programs: "/demo/DEV/username/project1/programs"'
#'
#' writeLines(no_hierarchy, file.path(tmpdir, "no_hierarchy.yml"))
#'
#' validate_config(config::get(file = file.path(tmpdir, "no_hierarchy.yml")))
#'
#' # A path can point to multiple locations, i.e. there is a hierarchy
#' hierarchy <- "default:
#'   paths:
#'     data: !expr list(DEV = '/demo/DEV/username/project1/data',
#'                      PROD = '/demo/PROD/project1/data')
#'     output: !expr list(DEV = '/demo/DEV/username/project1/output',
#'                        PROD = '/demo/PROD/project1/output')
#'     programs: !expr list(DEV = '/demo/DEV/username/project1/programs',
#'                          PROD = '/demo/PROD/project1/programs')
#'     envsetup_environ: !expr Sys.setenv(ENVSETUP_ENVIRON = 'DEV'); 'DEV'"
#'
#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
#'
#' validate_config(config::get(file = file.path(tmpdir, "hierarchy.yml")))
#'
#' # A hierarchy is present for paths, but they are not named
#' hierarchy_no_names <- "default:
#'   paths:
#'     data: !expr list('/demo/DEV/username/project1/data', '/demo/PROD/project1/data')
#'     output: !expr list('/demo/DEV/username/project1/output', '/demo/PROD/project1/output')
#'     programs: !expr list('/demo/DEV/username/project1/programs', '/demo/PROD/project1/programs')
#'     envsetup_environ: !expr Sys.setenv(ENVSETUP_ENVIRON = 'DEV'); 'DEV'"
#'
#'
#' writeLines(hierarchy_no_names, file.path(tmpdir, "hierarchy_no_names.yml"))
#'
#' validate_config(config::get(file = file.path(tmpdir, "hierarchy_no_names.yml")))
#'
#'
#' # No paths are specified
#' no_paths <- "default:
#'   autos:
#'     my_functions: '/demo/PROD/project1/R'"
#'
#' writeLines(no_paths, file.path(tmpdir, "no_paths.yml"))
#'
#' validate_config(config::get(file = file.path(tmpdir, "no_paths.yml")))
validate_config <- function(config) {
  validate_paths(config)
}


#' Validate the paths in a configuration
#'
#' @param config configuration object from config::get()
#'
#' @importFrom usethis ui_done ui_info
#' @importFrom purrr walk
#'
#' @noRd
validate_paths <- function(config) {
  # does the paths element exist?
  if (exists("paths", where = config)) {
    ui_done("paths are specified as part of your configuration")
  } else {
    ui_info("no paths are specified as part of your configuration, skipping path valiation")
    return(invisible())
  }

  # any hierarchical paths?
  if (is_hierarchical(config$paths)) {
    ui_done(c("hierarchal paths found for:", names(config$paths[sapply(config$paths, is.list)])))
  } else {
    ui_info("no hierarchical paths found")
    return(invisible())
  }

  # are your hierarchical paths named
  has_hierarchy <- sapply(config$paths, is.list)

  check_for_names <- names(config$paths[has_hierarchy])

  has_names <- function(.x) {
    !is.null(names(config$paths[has_hierarchy][[.x]]))
  }

  name_results <- sapply(check_for_names, has_names)

  walk(
    names(name_results[!name_results]),
    ~ usethis::ui_todo(
      paste0(
        usethis::ui_field(.),
        " has a hierarchy but they are not named.  Please update your configuration to name the hierarchy for ",
        usethis::ui_field(.), "."
      )
    )
  )
}

is_hierarchical <- function(x) {
  tf <- sapply(x, is.list)
  any(tf)
}

.onLoad <- function(libname, pkgname) {
  op <- options()
  op.envsetup <- list(
    envsetup.config.path = system.file("_envsetup.yml",
      package = "envsetup",
      mustWork = TRUE
    ),
    envsetup.rprofile.path = system.file(".Rprofile", package = "envsetup"),
    envsetup.renviron.path = system.file(".Renviron", package = "envsetup"),
    envsetup.path.environment = .GlobalEnv
  )

  toset <- !(names(op.envsetup) %in% names(op))
  if (any(toset)) options(op.envsetup[toset])

  invisible()
}

1		#' Initialize the R environment with envsetup
2		#'
3		#' @param project Character. The path to the project directory.
4		#' @param config_path Character. The path of the config file. Defaults to NULL.
5		#' @param create_paths Logical indicating if missing paths should be created. Defaults to NULL.
6		#' @export
7		#' @importFrom usethis ui_yeah ui_oops ui_info ui_done
8		#' @importFrom config get
9		#' @return Called for its side-effects.
10		#'
11		#' @examples
12		#' tmpdir <- tempdir()
13		#' print(tmpdir)
14		#'
15		#' # account for windows
16		#' if (Sys.info()['sysname'] == "Windows") {
17		#' tmpdir <- gsub("\\", "\\\\", tmpdir, fixed = TRUE)
18		#' }
19		#'
20		#' # Create an example config file\
21		#' hierarchy <- paste0("default:
22		#' paths:
23		#' data: !expr list(
24		#' DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'data'),
25		#' PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'data'))
26		#' output: !expr list(
27		#' DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'output'),
28		#' PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'output'))
29		#' programs: !expr list(
30		#' DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'programs'),
31		#' PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'programs'))")
32		#'
33		#'
34		#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
35		#'
36		#' init(project = tmpdir,
37		#' config_path = file.path(tmpdir, "hierarchy.yml"),
38		#' create_paths = TRUE)
39		init <- function(project, config_path = NULL, create_paths = NULL) {
40
41	5x	create_config <- FALSE
42	5x	config_found <- FALSE
43
44	5x	if (is.null(config_path)) {
45	!	create_config <- ui_yeah("No path to an exisiting configuration file was provided.
46	!	Would you like us to create a default configuration in your project directory?",
47	!	n_no = 1
48		)
49		} else {
50	5x	if (file.exists(config_path) && !dir.exists(config_path)) {
51	5x	config_found <- TRUE
52
53	5x	usethis::ui_done("Configuration file found!")
54
55		# verify directories exist
56	5x	config <- config::get(file = config_path)
57
58	5x	if (!exists("paths", where = config)) {
59	!	ui_oops("No paths are specified as part of your configuration. Update your config file to add paths.")
60	!	return(invisible())
61		}
62
63	5x	paths <- unlist(config$paths, use.names = FALSE)
64
65	5x	missing_directories <- !vapply(paths, dir.exists, TRUE)
66
67	5x	if (any(missing_directories)) {
68	5x	ui_info(
69	5x	c("The following paths in your configuration do not exist:",
70	5x	paths[missing_directories])
71		)
72
73		# if not, ask if user would like them built
74	5x	if (is.null(create_paths)) {
75	!	create_paths <-
76	!	usethis::ui_yeah(
77	!	"Would you like us to create your directories to match your configuration?",
78	!	n_no = 1
79		)
80		}
81
82	5x	if (!create_paths) {
83	5x	ui_info("All path objects will not work since directories are missing.")
84		}
85		}
86		} else {
87	!	stop(paste("No configuration file is found at", config_path), call. = FALSE)
88		}
89		}
90
91		# if user agrees, write a configuration file to the project directory and create paths
92	5x	if (create_config) {
93	!	default_path <- system.file("default_envsetup.yml", package = "envsetup", mustWork = TRUE)
94
95	!	config_path <- file.path(project, "envsetup.yml")
96
97	!	file.copy(default_path, config_path, overwrite = TRUE)
98
99	!	ui_done(paste("Configuration file (envsetup.yml) has been written to", project))
100
101	!	create_paths <- TRUE
102	5x	} else if (config_found <- FALSE) {
103	!	stop("Aborting envsetup initialization. A configuration file is needed.", call. = FALSE)
104		}
105
106		# create the .Rprofile or add envsetup to the bottom
107	5x	add <- sprintf(
108	5x	'\nlibrary(envsetup)\nrprofile(config::get(file = "%s"))',
109	5x	config_path
110		)
111
112	5x	envsetup_write_rprofile(
113	5x	add = add,
114	5x	file = file.path(project, ".Rprofile")
115		)
116
117	5x	if (create_paths) {
118	!	build_from_config(
119	!	config::get(file = config_path)
120		)
121		}
122
123	5x	ui_done("envsetup initialization complete")
124		}
125
126		envsetup_write_rprofile <- function(add, file) {
127	5x	if (!file.exists(file)) {
128	3x	writeLines(add, file)
129	3x	ui_done(paste(".Rprofile created"))
130	3x	return(TRUE)
131		}
132
133	2x	before <- readLines(file, warn = FALSE)
134
135		# if there is a call to `rprofile()` in the .Rprofile, assume setup was already done and exit
136	2x	if (any(grepl("rprofile\\(", before))) {
137	1x	warning("It looks like your project has already been initialized to use envsetup.
138	1x	Manually adjust your .Rprofile if you need to change the environment setup.",
139	1x	call. = FALSE
140		)
141	1x	return(invisible())
142		}
143
144	1x	after <- c(before, add)
145
146	1x	writeLines(after, file)
147
148	1x	ui_done(paste(".Rprofile updated"))
149		}

1		#' Function used to pass through code to the .Rprofile
2		#'
3		#' @param config configuration object from config::get()
4		#' @param envir The environment to search for the path object. Defaults to the
5		#' value of `getOption("envsetup.path.environment")`.
6		#' @param overwrite logical indicating if sourcing of autos should overwrite an object in global if it already exists
7		#' @importFrom envnames environment_name
8		#' @export
9		#' @return Called for its side effects. Directory paths and autos are added to the search path based on your config.
10		#'
11		#' @examples
12		#' # temp location to store configuration files
13		#' tmpdir <- tempdir()
14		#' print(tmpdir)
15		#'
16		#' # Create an example config file
17		#' hierarchy <- "default:
18		#' paths:
19		#' data: !expr list(DEV = '/demo/DEV/username/project1/data',
20		#' PROD = '/demo/PROD/project1/data')
21		#' output: !expr list(DEV = '/demo/DEV/username/project1/output',
22		#' PROD = '/demo/PROD/project1/output')
23		#' programs: !expr list(DEV = '/demo/DEV/username/project1/programs',
24		#' PROD = '/demo/PROD/project1/programs')"
25		#'
26		#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
27		#'
28		#' rprofile(config::get(file = file.path(tmpdir, "hierarchy.yml")))
29		rprofile <- function(config,
30		envir = getOption("envsetup.path.environment"),
31		overwrite = TRUE) {
32
33		# remove autos and pass everything else to "envsetup:paths"
34	8x	config_minus_autos <- config
35	8x	config_minus_autos$autos <- NULL
36
37	8x	walk2(names(config_minus_autos$paths),
38	8x	config_minus_autos$paths,
39	8x	assign,
40	8x	envir = envir)
41
42	8x	message(paste0("Assigned paths to ", environment_name(envir)))
43
44		# store config with a standard name in a standard location
45	8x	assign("auto_stored_envsetup_config", config, envir = envir)
46
47		# If autos exist, set them
48	8x	if (!is.null(config$autos)) {
49	5x	set_autos(config$autos, overwrite = overwrite)
50		}
51		}

1		#' Validate a configuration file
2		#'
3		#' A helper function to help troubleshoot common problems that can occur when
4		#' building your configuration file.
5		#'
6		#' @param config configuration object from config::get()
7		#'
8		#' @return Called for its side-effects. Prints findings from validation checks.
9		#' @export
10		#'
11		#' @examples
12		#' # temp location to store configuration files
13		#' tmpdir <- tempdir()
14		#' print(tmpdir)
15		#'
16		#' # Each path only points to one location, i.e. there is no hierarchy for a path
17		#' no_hierarchy <- 'default:
18		#' paths:
19		#' data: "/demo/DEV/username/project1/data"
20		#' output: "/demo/DEV/username/project1/output"
21		#' programs: "/demo/DEV/username/project1/programs"'
22		#'
23		#' writeLines(no_hierarchy, file.path(tmpdir, "no_hierarchy.yml"))
24		#'
25		#' validate_config(config::get(file = file.path(tmpdir, "no_hierarchy.yml")))
26		#'
27		#' # A path can point to multiple locations, i.e. there is a hierarchy
28		#' hierarchy <- "default:
29		#' paths:
30		#' data: !expr list(DEV = '/demo/DEV/username/project1/data',
31		#' PROD = '/demo/PROD/project1/data')
32		#' output: !expr list(DEV = '/demo/DEV/username/project1/output',
33		#' PROD = '/demo/PROD/project1/output')
34		#' programs: !expr list(DEV = '/demo/DEV/username/project1/programs',
35		#' PROD = '/demo/PROD/project1/programs')
36		#' envsetup_environ: !expr Sys.setenv(ENVSETUP_ENVIRON = 'DEV'); 'DEV'"
37		#'
38		#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
39		#'
40		#' validate_config(config::get(file = file.path(tmpdir, "hierarchy.yml")))
41		#'
42		#' # A hierarchy is present for paths, but they are not named
43		#' hierarchy_no_names <- "default:
44		#' paths:
45		#' data: !expr list('/demo/DEV/username/project1/data', '/demo/PROD/project1/data')
46		#' output: !expr list('/demo/DEV/username/project1/output', '/demo/PROD/project1/output')
47		#' programs: !expr list('/demo/DEV/username/project1/programs', '/demo/PROD/project1/programs')
48		#' envsetup_environ: !expr Sys.setenv(ENVSETUP_ENVIRON = 'DEV'); 'DEV'"
49		#'
50		#'
51		#' writeLines(hierarchy_no_names, file.path(tmpdir, "hierarchy_no_names.yml"))
52		#'
53		#' validate_config(config::get(file = file.path(tmpdir, "hierarchy_no_names.yml")))
54		#'
55		#'
56		#' # No paths are specified
57		#' no_paths <- "default:
58		#' autos:
59		#' my_functions: '/demo/PROD/project1/R'"
60		#'
61		#' writeLines(no_paths, file.path(tmpdir, "no_paths.yml"))
62		#'
63		#' validate_config(config::get(file = file.path(tmpdir, "no_paths.yml")))
64		validate_config <- function(config) {
65	4x	validate_paths(config)
66		}
67
68
69		#' Validate the paths in a configuration
70		#'
71		#' @param config configuration object from config::get()
72		#'
73		#' @importFrom usethis ui_done ui_info
74		#' @importFrom purrr walk
75		#'
76		#' @noRd
77		validate_paths <- function(config) {
78		# does the paths element exist?
79	4x	if (exists("paths", where = config)) {
80	3x	ui_done("paths are specified as part of your configuration")
81		} else {
82	1x	ui_info("no paths are specified as part of your configuration, skipping path valiation")
83	1x	return(invisible())
84		}
85
86		# any hierarchical paths?
87	3x	if (is_hierarchical(config$paths)) {
88	2x	ui_done(c("hierarchal paths found for:", names(config$paths[sapply(config$paths, is.list)])))
89		} else {
90	1x	ui_info("no hierarchical paths found")
91	1x	return(invisible())
92		}
93
94		# are your hierarchical paths named
95	2x	has_hierarchy <- sapply(config$paths, is.list)
96
97	2x	check_for_names <- names(config$paths[has_hierarchy])
98
99	2x	has_names <- function(.x) {
100	6x	!is.null(names(config$paths[has_hierarchy][[.x]]))
101		}
102
103	2x	name_results <- sapply(check_for_names, has_names)
104
105	2x	walk(
106	2x	names(name_results[!name_results]),
107	2x	~ usethis::ui_todo(
108	2x	paste0(
109	2x	usethis::ui_field(.),
110	2x	" has a hierarchy but they are not named. Please update your configuration to name the hierarchy for ",
111	2x	usethis::ui_field(.), "."
112		)
113		)
114		)
115		}
116
117		is_hierarchical <- function(x) {
118	3x	tf <- sapply(x, is.list)
119	3x	any(tf)
120		}

1		#' Environment Setup Environment
2		#'
3		#' A dedicated environment object used to store and manage path configurations
4		#' and other setup variables for the envsetup package. This environment provides
5		#' an isolated namespace for storing path objects that can be retrieved using
6		#' the package's path management functions.
7		#'
8		#' @returns An environment object created with \code{new.env()}.
9		#'
10		#' @details
11		#' This environment serves as the default storage location for path objects
12		#' when using envsetup package functions. It helps maintain clean separation
13		#' between user workspace and package-managed paths.
14		#'
15		#' @examples
16		#' # Store a path in the envsetup environment
17		#' assign("project_root", "/path/to/project", envir = envsetup_environment)
18		#'
19		#' # List objects in the environment
20		#' ls(envir = envsetup_environment)
21		#'
22		#' # Check if the environment exists and is an environment
23		#' exists("envsetup_environment")
24		#' is.environment(envsetup_environment)
25		#'
26		#' @seealso \code{\link{get_path}}, \code{\link[base]{new.env}}
27		#'
28		#' @export
29		envsetup_environment <- new.env()
30
31		#' Get Path Object from Environment
32		#'
33		#' Retrieves a path object from the specified environment using non-standard
34		#' evaluation. The function uses `substitute()` to capture the unevaluated
35		#' expression and `get()` to retrieve the corresponding object.
36		#'
37		#' @param path An unquoted name of the path object to retrieve from the environment.
38		#' @param envir The environment to search for the path object. Defaults to the
39		#' value of `getOption("envsetup.path.environment")`.
40		#'
41		#' @return The path object stored in the specified environment under the given name.
42		#'
43		#' @examples
44		#' # Create a custom environment and store some paths
45		#' path_env <- new.env()
46		#' assign("data_dir", "/home/user/data", envir = path_env)
47		#' assign("output_dir", "/home/user/output", envir = path_env)
48		#'
49		#' # Set up the option to use our custom environment
50		#' options(envsetup.path.environment = path_env)
51		#'
52		#' # Retrieve paths using the function
53		#' data_path <- get_path(data_dir)
54		#' output_path <- get_path(output_dir)
55		#'
56		#' print(data_path) # "/home/user/data"
57		#' print(output_path) # "/home/user/output"
58		#'
59		#' # Using with a different environment
60		#' temp_env <- new.env()
61		#' assign("temp_dir", "/tmp/analysis", envir = temp_env)
62		#' temp_path <- get_path(temp_dir, envir = temp_env)
63		#' print(temp_path) # "/tmp/analysis"
64		#'
65		#' @seealso \code{\link[base]{get}}, \code{\link[base]{substitute}}
66		#'
67		#' @export
68		get_path <- function(path, envir = getOption("envsetup.path.environment")){
69	1x	base::get(substitute(path), envir)
70		}
71
72		#' Read path
73		#'
74		#' Check each environment for the file and return the path to the first.
75		#'
76		#' The environments searched depends on the current environment.
77		#' For example, if your workflow contains a development (dev) area and
78		#' production area (prod), and the code is executing in the dev environment,
79		#' we search dev and prod. If in prod, we only search prod.
80		#'
81		#' @param lib object containing the paths for all environments of a directory
82		#' @param filename name of the file you would like to read
83		#' @param full.path logical to return the path including the file name
84		#' @param envsetup_environ name of the environment you would like to read the file from;
85		#' default values comes from the value in the system variable ENVSETUP_ENVIRON
86		#' which can be set by Sys.setenv(ENVSETUP_ENVIRON = "environment name")
87		#' @param envir The environment to search for the path object. Defaults to the
88		#' value of `getOption("envsetup.path.environment")`.
89		#'
90		#' @importFrom rlang quo_get_expr enquo is_string
91		#'
92		#' @return string containing the path of the first directory the file is found
93		#' @export
94		#'
95		#' @examples
96		#' tmpdir <- tempdir()
97		#'
98		#' # account for windows
99		#' if (Sys.info()['sysname'] == "Windows") {
100		#' tmpdir <- gsub("\\", "\\\\", tmpdir, fixed = TRUE)
101		#' }
102		#'
103		#' # add config for just the data location
104		#' hierarchy <- paste0("default:
105		#' paths:
106		#' data: !expr list(
107		#' DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'data'),
108		#' PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'data'))")
109		#'
110		#' # write config file to temp directory
111		#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
112		#'
113		#' config <- config::get(file = file.path(tmpdir, "hierarchy.yml"))
114		#'
115		#' # build folder structure from config
116		#' build_from_config(config)
117		#'
118		#' # setup environment based on config
119		#' rprofile(config::get(file = file.path(tmpdir, "hierarchy.yml")))
120		#'
121		#' # place data in prod data folder
122		#' saveRDS(mtcars, file.path(tmpdir, "demo/PROD/project1/data/mtcars.rds"))
123		#'
124		#' # find the location of mtcars.rds
125		#' read_path(data, "mtcars.rds")
126		read_path <- function(lib,
127		filename,
128		full.path = TRUE,
129		envsetup_environ = Sys.getenv("ENVSETUP_ENVIRON"),
130		envir = getOption("envsetup.path.environment")) {
131
132		# lib can be a object in a different environment
133		# get this directly from envsetup_environment
134	10x	lib_arg <- quo_get_expr(enquo(lib))
135
136	10x	if (is_string(lib_arg)) {
137	1x	stop(paste(
138	1x	"The lib argument should be an object containing the paths",
139	1x	"for all environments of a directory, not a string."
140	1x	), call. = FALSE)
141		}
142
143	9x	read_lib <- base::get(toString(lib_arg), envir)
144
145	9x	restricted_paths <- read_lib
146
147	9x	if (length(read_lib) > 1 && envsetup_environ == "") {
148	1x	stop(paste(
149	1x	"The envsetup_environ parameter or ENVSETUP_ENVIRON environment",
150	1x	"variable must be used if hierarchical paths are set."
151	1x	), call. = FALSE)
152		}
153
154	8x	if (envsetup_environ %in% names(read_lib)) {
155	6x	restricted_paths <- read_lib[which(names(read_lib) == envsetup_environ):length(read_lib)]
156	2x	} else if (length(read_lib) > 1) {
157	1x	warning(paste(
158	1x	"The path has named environments",
159	1x	usethis::ui_field(names(read_lib)),
160	1x	"that do not match with the envsetup_environ parameter",
161	1x	"or ENVSETUP_ENVIRON environment variable",
162	1x	usethis::ui_field(envsetup_environ)
163	1x	), call. = FALSE)
164		}
165
166		# find which paths have the object
167	8x	path_has_object <-
168	8x	sapply(
169	8x	unlist(restricted_paths),
170	8x	object_in_path,
171	8x	filename,
172	8x	simplify = TRUE
173		)
174
175	8x	if (any(path_has_object) == FALSE) {
176	1x	stop(paste0(filename, " not found in ", substitute(read_lib)))
177		}
178
179		# subset and keep the first
180	7x	first_directory_found <- unlist(restricted_paths)[path_has_object][[1]]
181
182	7x	if (full.path == TRUE) {
183	6x	out_path <- file.path(first_directory_found, filename)
184		} else {
185	1x	out_path <- first_directory_found
186		}
187
188	7x	message("Read Path:", out_path, "\n")
189	7x	out_path
190		}
191
192
193		#' Retrieve a file path from an envsetup object containing paths
194		#'
195		#' Paths will be filtered to produce the lowest available level from a hierarchy
196		#' of paths based on envsetup_environ
197		#'
198		#' @param lib Object containing the paths for all environments of a directory
199		#' @param filename Name of the file you would like to write
200		#' @param envsetup_environ Name of the environment to which you would like to
201		#' write. Defaults to the ENVSETUP_ENVIRON environment variable
202		#' @param envir The environment to search for the path object. Defaults to the
203		#' value of `getOption("envsetup.path.environment")`.
204		#'
205		#' @importFrom rlang quo_get_expr enquo is_string
206		#'
207		#' @return path to write
208		#' @export
209		#'
210		#' @examples
211		#' tmpdir <- tempdir()
212		#'
213		#' # account for windows
214		#' if (Sys.info()['sysname'] == "Windows") {
215		#' tmpdir <- gsub("\\", "\\\\", tmpdir, fixed = TRUE)
216		#' }
217		#'
218		#' # add config for just the data location
219		#' hierarchy <- paste0("default:
220		#' paths:
221		#' data: !expr list(
222		#' DEV = file.path('",tmpdir,"', 'demo', 'DEV', 'username', 'project1', 'data'),
223		#' PROD = file.path('",tmpdir,"', 'demo', 'PROD', 'project1', 'data'))")
224		#'
225		#' # write config file to temp directory
226		#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
227		#'
228		#' config <- config::get(file = file.path(tmpdir, "hierarchy.yml"))
229		#'
230		#' # build folder structure from config
231		#' build_from_config(config)
232		#'
233		#' # setup environment based on config
234		#' rprofile(config::get(file = file.path(tmpdir, "hierarchy.yml")))
235		#'
236		#' # find location to write mtcars.rds
237		#' write_path(data, "mtcars.rds")
238		#'
239		#' # save data in data folder using write_path
240		#' saveRDS(mtcars, write_path(data, "mtcars.rds"))
241		write_path <- function(lib, filename = NULL, envsetup_environ = Sys.getenv("ENVSETUP_ENVIRON"),
242		envir = getOption("envsetup.path.environment")) {
243		# examine lib to ensure it's not a string
244		# if it's a string, you end up with an incorrect path
245	6x	lib_arg <- quo_get_expr(enquo(lib))
246
247	6x	if (is_string(lib_arg)) {
248	1x	stop(paste(
249	1x	"The lib argument should be an object containing the paths",
250	1x	"for all environments of a directory, not a string."
251	1x	), call. = FALSE)
252		}
253
254	5x	write_path <- base::get(toString(lib_arg), envir)
255	5x	path <- write_path
256
257	5x	if (length(write_path) > 1 && envsetup_environ == "") {
258	1x	stop(paste(
259	1x	"The envsetup_environ parameter or ENVSETUP_ENVIRON environment",
260	1x	"variable must be used if hierarchical paths are set."
261	1x	), call. = FALSE)
262		}
263
264	4x	if (envsetup_environ %in% names(write_path)) {
265	2x	path <- path[[envsetup_environ]]
266	2x	} else if (length(write_path) > 1) {
267	1x	warning(paste(
268	1x	"The path has named environments",
269	1x	usethis::ui_field(names(lib)),
270	1x	"that do not match with the envsetup_environ parameter",
271	1x	"or ENVSETUP_ENVIRON environment variable",
272	1x	usethis::ui_field(envsetup_environ)
273	1x	), call. = FALSE)
274		}
275
276	4x	out_path <- path
277
278	4x	if (!is.null(filename)) {
279	2x	out_path <- file.path(path, filename)
280		}
281
282	4x	message("Write Path:", out_path, "\n")
283	4x	out_path
284		}
285
286
287		# return T/F for if the data exists in the directories
288		object_in_path <- function(path, object) {
289	20x	f_path <- file.path(path, object)
290	20x	file.exists(f_path)
291		}
292
293
294
295
296		#' Build directory structure from a configuration file
297		#'
298		#' @param config configuration object from config::get() containing paths
299		#' @param root root directory to build from.
300		#' Leave as NULL if using absolute paths. Set to working directory if using relative paths.
301		#'
302		#' @importFrom fs dir_tree
303		#' @importFrom usethis ui_done
304		#'
305		#' @return Called for its side-effects. The directories build print as a tree-like format from `fs::dir_tree()`.
306		#' @export
307		#'
308		#' @examples
309		#' tmpdir <- tempdir()
310		#'
311		#' hierarchy <- "default:
312		#' paths:
313		#' data: !expr list(DEV = '/demo/DEV/username/project1/data',
314		#' PROD = '/demo/PROD/project1/data')
315		#' output: !expr list(DEV = '/demo/DEV/username/project1/output',
316		#' PROD = '/demo/PROD/project1/output')
317		#' programs: !expr list(DEV = '/demo/DEV/username/project1/programs',
318		#' PROD = '/demo/PROD/project1/programs')
319		#' docs: !expr list(DEV = 'docs',
320		#' PROD = 'docs')"
321		#'
322		#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
323		#'
324		#' config <- config::get(file = file.path(tmpdir, "hierarchy.yml"))
325		#'
326		#' build_from_config(config, tmpdir)
327		build_from_config <- function(config, root = NULL) {
328	2x	if (!exists("paths", where = config)) {
329	1x	usethis::ui_oops("No paths are specified as part of your configuration. Update your config file to add paths.")
330	1x	return(invisible())
331		}
332
333	1x	if (is.null(root)) {
334	!	paths <- unlist(config$paths, use.names = FALSE)
335		} else {
336	1x	paths <- file.path(root, unlist(config$paths, use.names = FALSE))
337		}
338
339	1x	walk(paths, ~ {
340	8x	if (!dir.exists(.x)) {
341	7x	dir.create(.x, recursive = TRUE)
342		}
343		})
344
345		# find the root of the paths provided in the config
346	1x	if (is.null(root)) {
347	!	base_path <- strsplit(paths[1], "")[[1]]
348
349	!	for (i in seq_along(paths)) {
350	!	compare_path <- strsplit(paths[i], "")[[1]]
351
352	!	end <- min(length(base_path), length(compare_path))
353
354	!	tf <- base_path[1:end] == compare_path[1:end]
355
356	!	first_false <- min(which(tf == FALSE), end + 1)
357
358	!	base_path <- base_path[1:first_false - 1]
359		}
360
361	!	root <- paste0(base_path, collapse = "")
362		}
363
364	1x	ui_done("Directories built")
365	1x	dir_tree(root, type = "directory")
366		}

1		#' Set the R autos
2		#'
3		#' Set the directory paths of any 'autos'. 'Autos' are
4		#' directory paths that hold .R files containing R functions. These paths may be
5		#' used when functions apply to an analysis, protocol, or even at a global
6		#' level, but don't fit in or necessarily require a package or haven't been
7		#' incorporated into a package.
8		#'
9		#' @param autos named list of character vectors
10		#' @param envsetup_environ name of the environment you would like to read from;
11		#' default values comes from the value in the system variable ENVSETUP_ENVIRON
12		#' which can be set by Sys.setenv(ENVSETUP_ENVIRON = "environment name")
13		#' @param overwrite logical indicating if sourcing of autos should overwrite an object in global if it already exists
14		#'
15		#' @return Called for side-effects. Directory paths of the R autos added to search path are printed.
16		#'
17		#' @importFrom purrr walk walk2
18		#' @importFrom rlang is_named
19		#' @importFrom usethis ui_field
20		#' @noRd
21		set_autos <- function(autos, envsetup_environ = Sys.getenv("ENVSETUP_ENVIRON"), overwrite = TRUE) {
22
23		# Must be named list
24	19x	if (!is_named(autos)) {
25	1x	stop("Paths for autos in your envsetup configuration file must be named", call. = FALSE)
26		}
27
28		# remove NULL before further processing
29		# NULL is expected for hierarchical paths when running in an environment
30		# after the first level of the hierarchy
31	18x	autos <- autos[!vapply(autos, is.null, FALSE)]
32
33	18x	for (i in seq_along(autos)) {
34	45x	cur_autos <- autos[[i]]
35
36	45x	if (length(cur_autos) > 1) {
37		# Hierarchical paths must be named
38	15x	if (!is_named(cur_autos)) {
39	1x	stop("Hierarchical autos paths in your envsetup configuration file must be named", call. = FALSE)
40		}
41
42		# envsetup_environ must be used if using hierarchical paths
43	14x	if (envsetup_environ == "") {
44	1x	stop(paste(
45	1x	"The envsetup_environ parameter or ENVSETUP_ENVIRON environment",
46	1x	"variable must be used if hierarchical autos are set."
47	1x	), call. = FALSE)
48		}
49		}
50
51	43x	if (!is.null(names(cur_autos)) && !envsetup_environ %in% names(cur_autos)
52	43x	&& envsetup_environ != "") {
53	1x	warning(paste(
54	1x	"The", ui_field(names(autos[i])), "autos has named",
55	1x	"environments", ui_field(names(cur_autos)),
56	1x	"that do not match with the envsetup_environ parameter",
57	1x	"or ENVSETUP_ENVIRON environment variable",
58	1x	ui_field(envsetup_environ)
59	1x	), call. = FALSE)
60		}
61
62	43x	filtered_autos <- cur_autos
63
64	43x	if (envsetup_environ %in% names(cur_autos)) {
65	12x	filtered_autos <-
66	12x	cur_autos[which(names(cur_autos) == envsetup_environ):length(cur_autos)]
67		}
68
69	43x	autos[[i]] <- filtered_autos
70		}
71
72		# Flatten the paths to collapse the names down to a single vector
73	16x	flattened_paths <- unlist(autos)
74
75		# Check the autos before they're set
76	16x	if (!(is.null(flattened_paths) \|\| is.character(flattened_paths))) {
77	1x	stop("Paths provided for autos must be directories", call. = FALSE)
78		}
79
80		# If there are any existing autos then reset them
81	15x	detach_autos()
82
83		# Now source everything
84	15x	walk2(
85	15x	flattened_paths,
86	15x	names(flattened_paths),
87	15x	~ attach_auto(.x, .y, overwrite = overwrite)
88		)
89		}
90
91		#' Source scripts and warn of conflicts
92		#'
93		#' Source a script, only adding objects to global if they do not already exist
94		#'
95		#' @param file path to a script containing object to add to global
96		#' @param overwrite logical indicating if sourcing should overwrite an object in global if it already exists
97		#'
98		#' @importFrom usethis ui_value
99		#'
100		#' @return Called for side-effects. Objects are added to the global environment.
101		#'
102		#' @noRd
103		source_warn_conflicts <- function(file, overwrite = TRUE){
104
105		# create a new environment to source into
106	179x	new_env <- new.env()
107
108	179x	cat("Sourcing file: ", ui_value(file), "\n")
109
110		# source directory into a this environment
111	179x	sys.source(file,
112	179x	envir = new_env)
113
114		# compare objects to find unique and non-unique
115	178x	objects_in_new_env <- ls(new_env)
116	178x	objects_in_global <- ls(.GlobalEnv)
117
118	178x	if (overwrite == FALSE) {
119	16x	objects_to_assign <- setdiff(objects_in_new_env, objects_in_global)
120	16x	objects_to_skip_assign <- intersect(objects_in_new_env, objects_in_global)
121	16x	objects_that_are_overwritten <- NULL
122	162x	} else if (overwrite == TRUE) {
123	162x	objects_to_assign <- objects_in_new_env
124	162x	objects_to_skip_assign <- NULL
125	162x	objects_that_are_overwritten <- intersect(objects_in_new_env, objects_in_global)
126		} else {
127	!	warning("overwrite must contain a logical")
128		}
129
130	178x	for (obj_name in objects_to_assign) {
131	229x	assign_and_move_function(obj_name, temp_env = new_env, envir = .GlobalEnv)
132	229x	record_function_metadata(obj_name, file)
133		}
134
135	178x	if (length(objects_to_assign) != 0) {
136	174x	cat("\n The following objects are added to .GlobalEnv:", sep = "\n")
137	174x	cat("", sep = "\n")
138	174x	cat(paste0(" ", ui_value(objects_to_assign), "\n"))
139		}
140
141
142	178x	if (length(objects_to_skip_assign) != 0) {
143	6x	cat("\n The following objects were not added to .GlobalEnv as they already exist:", sep = "\n")
144	6x	cat("", sep = "\n")
145	6x	cat(paste0(" ", ui_value(objects_to_skip_assign), "\n"))
146		}
147
148
149	178x	if (length(objects_that_are_overwritten) != 0) {
150	51x	cat("\n The following objects were overwritten in .GlobalEnv:", sep = "\n")
151	51x	cat("", sep = "\n")
152	51x	cat(paste0(" ", ui_value(objects_that_are_overwritten), "\n"))
153		}
154
155	178x	cat("", sep = "\n")
156
157		}
158
159
160		assign_and_move_function <- function(obj_name, temp_env, envir){
161	229x	assign(obj_name, base::get(obj_name, envir = temp_env), envir = envir)
162		}
163
164
165		record_function_metadata <- function(obj_name, file){
166
167		# store the metadata for the objects
168	229x	new_record <- data.frame(
169	229x	object_name = obj_name,
170	229x	script = file
171		)
172
173	229x	if (exists("object_metadata", envsetup_environment)) {
174	213x	df <- merge(
175	213x	base::get("object_metadata", envsetup_environment),
176	213x	new_record,
177	213x	by = "object_name",
178	213x	all = TRUE
179		)
180
181	213x	if (any(c("script.x", "script.y") %in% names(df))) {
182	213x	df$script <- ifelse(is.na(df$script.y), df$script.x, df$script.y)
183	213x	df$script.x <- NULL
184	213x	df$script.y <- NULL
185		}
186
187	213x	envsetup_environment$object_metadata <- df
188		} else {
189	16x	envsetup_environment$object_metadata <- new_record
190		}
191
192		}
193
194		#' Source order of functions
195		#'
196		#' This function is used to define the sorting order of functions if
197		#' `@include` is used to define function dependencies.
198		#'
199		#' @param path Directory path
200		#'
201		#' @importFrom utils getFromNamespace
202		#'
203		#' @noRd
204		collate_func <- function(path){
205	48x	r_scripts <- list.files(path,
206	48x	pattern = ".r$",
207	48x	ignore.case = TRUE,
208	48x	full.names = TRUE
209		)
210
211	48x	generate_collate <- utils::getFromNamespace("generate_collate", "roxygen2")
212
213	48x	collated_func <- generate_collate(path)
214
215	48x	if (is.null(collated_func)) {
216	39x	r_scripts
217		} else {
218	9x	sapply(1:length(collated_func), function(x) file.path(path, collated_func[[x]]))
219		}
220
221		}
222
223
224		#' Attach a function directory
225		#'
226		#' This function is used to create an rautos path. All .R files from a given
227		#' path are sourced. Functions are imported into from a directory and returned
228		#' to an environment. This environment can then be used to attach on to the
229		#' search path. This function should not be called directly. To apply autos,
230		#' use `set_autos()`.
231		#'
232		#' @param path Directory path
233		#' @param name Directory name
234		#' @param overwrite logical indicating if sourcing of autos should overwrite an object in global if it already exists
235		#' @noRd
236		#'
237		#' @return Called for side-effects. Directory paths of the R autos added to search path are printed.
238		attach_auto <- function(path, name, overwrite = TRUE) {
239
240	61x	if (!(dir.exists(path) \|\| file.exists(path))) {
241		# Check if the auto actually exists
242	1x	warning(sprintf("An autos path specified in your envsetup configuration file does not exist: %s = %s", name, path),
243	1x	call. = FALSE)
244	60x	} else if (file.exists(path) && !dir.exists(path)) {
245		# if file, source it
246	14x	source_warn_conflicts(path, overwrite = overwrite)
247		} else {
248	46x	collated_r_scripts <- collate_func(path)
249
250	46x	if (!identical(collated_r_scripts, character(0))) {
251	46x	walk(collated_r_scripts, source_warn_conflicts, overwrite = overwrite)
252		} else {
253	!	message("No files found in ", path, ". Nothing to attach.")
254		}
255		}
256		}
257
258		#' Detach the autos from the current session
259		#'
260		#' This function will remove any autos that have been set from the search path
261		#'
262		#' @return Called for its side-effects.
263		#' @export
264		#'
265		#' @examples
266		#' tmpdir <- tempdir()
267		#' print(tmpdir)
268		#'
269		#' # account for windows
270		#' if (Sys.info()['sysname'] == "Windows") {
271		#' tmpdir <- gsub("\\", "\\\\", tmpdir, fixed = TRUE)
272		#' }
273		#'
274		#' # Create an example config file\
275		#' hierarchy <- paste0("default:
276		#' paths:
277		#' functions: !expr list(DEV = file.path('",tmpdir,"',
278		#' 'demo',
279		#' 'DEV',
280		#' 'username',
281		#' 'project1',
282		#' 'functions'),
283		#' PROD = file.path('",tmpdir,"',
284		#' 'demo',
285		#' 'PROD',
286		#' 'project1',
287		#' 'functions'))
288		#' autos:
289		#' my_functions: !expr list(DEV = file.path('",tmpdir,"',
290		#' 'demo',
291		#' 'DEV',
292		#' 'username',
293		#' 'project1',
294		#' 'functions'),
295		#' PROD = file.path('",tmpdir,"',
296		#' 'demo',
297		#' 'PROD',
298		#' 'project1',
299		#' 'functions'))")
300		#'
301		#' # write config
302		#' writeLines(hierarchy, file.path(tmpdir, "hierarchy.yml"))
303		#'
304		#' config <- config::get(file = file.path(tmpdir, "hierarchy.yml"))
305		#'
306		#' build_from_config(config)
307		#'
308		#' # write function to DEV
309		#' writeLines("dev_function <- function() {print(environment(dev_function))}",
310		#' file.path(tmpdir, 'demo', 'DEV', 'username', 'project1', 'functions', 'dev_function.r'))
311		#'
312		#' # write function to PROD
313		#' writeLines("prod_function <- function() {print(environment(prod_function))}",
314		#' file.path(tmpdir, 'demo', 'PROD', 'project1', 'functions', 'prod_function.r'))
315		#'
316		#' # setup the environment
317		#' Sys.setenv(ENVSETUP_ENVIRON = "DEV")
318		#' rprofile(config::get(file = file.path(tmpdir, "hierarchy.yml")))
319		#'
320		#' # show dev_function() and prod_function() are available and print their location
321		#' dev_function()
322		#' prod_function()
323		#'
324		#' # remove autos from search
325		#' detach_autos()
326		detach_autos <- function() {
327
328	27x	if (exists("object_metadata", envir = envsetup_environment)){
329	15x	rm(list = envsetup_environment$object_metadata$object_name, envir = .GlobalEnv)
330	15x	rm("object_metadata", envir = envsetup_environment)
331		}
332
333		}

1		.onLoad <- function(libname, pkgname) {
2	!	op <- options()
3	!	op.envsetup <- list(
4	!	envsetup.config.path = system.file("_envsetup.yml",
5	!	package = "envsetup",
6	!	mustWork = TRUE
7		),
8	!	envsetup.rprofile.path = system.file(".Rprofile", package = "envsetup"),
9	!	envsetup.renviron.path = system.file(".Renviron", package = "envsetup"),
10	!	envsetup.path.environment = .GlobalEnv
11		)
12
13	!	toset <- !(names(op.envsetup) %in% names(op))
14	!	if (any(toset)) options(op.envsetup[toset])
15
16	!	invisible()
17		}