# Load a module at a given location.
.load_module <- function(path, name = NULL, check = TRUE) {
if (!is.null(path)) {
.modulr_env$injector$.__name__ <- name
on.exit(rm(list = ".__name__", pos = .modulr_env$injector))
loaded <- FALSE
registry <- .modulr_env$injector$registry
.Last.name <- .modulr_env$injector$.Last.name
config <- .modulr_env$injector$config
verbosity <- .modulr_env$injector$verbosity
stash <- .modulr_env$injector$stash
rollback <- function() {
.modulr_env$injector$registry <- registry
.modulr_env$injector$.Last.name <- .Last.name
.modulr_env$injector$config <- config
.modulr_env$injector$verbosity <- verbosity
.modulr_env$injector$stash <- stash
}
wrapper_env <- new.env()
wrapper_env$.__name__ <- if (is.null(name)) "__noname__" else name
if (tolower(tools::file_ext(path)) == "r") {
if (interactive() && requireNamespace("rstudioapi", quietly = TRUE) &&
rstudioapi::isAvailable()) {
# nocov start
tryCatch({
# Seems that tryCatch is unable to catch errors happening in an
# RStudio's debugSource call (version 0.98.1103).
try(stop("fake error", call. = FALSE), silent = TRUE)
last_error <- geterrmessage()
local(do.call("debugSource", args = list(path, echo = FALSE)),
envir = wrapper_env) # nocov
if (last_error != geterrmessage()) {
stop(sub("\n$", "", geterrmessage()), call. = FALSE)
} else {
try(stop(last_error, call. = FALSE), silent = TRUE)
}
loaded <- TRUE
},
error = function(e) {
rollback()
e$message <- sprintf("%s Rolling back.", e$message)
on.exit(try(stop(e), silent = TRUE))
stop("Rolling back.", call. = FALSE)
})
# nocov end
} else {
tryCatch({
local(source(path, local = TRUE, echo = FALSE, keep.source = TRUE),
envir = wrapper_env)
loaded <- TRUE
},
error = function(e) {
rollback()
e$message <- sprintf("%s Rolling back.", e$message)
stop(e)
})
}
} else if (tolower(tools::file_ext(path)) %in% c("rmd", "rnw")) {
opat <- knitr::knit_patterns$get()
oopts_knit <- knitr::opts_knit$get()
oopts_template <- knitr::opts_template$get()
oopts_hooks <- knitr::opts_hooks$get()
oopts_chunk <- knitr::opts_chunk$get()
oopts_current <- knitr::opts_current$get()
knitr::knit_patterns$restore()
on.exit(knitr::knit_patterns$set(opat), add = TRUE)
knitr::opts_knit$restore()
on.exit(knitr::opts_knit$set(oopts_knit), add = TRUE)
knitr::opts_template$restore()
on.exit(knitr::opts_template$set(oopts_template), add = TRUE)
knitr::opts_hooks$restore()
on.exit(knitr::opts_hooks$set(oopts_hooks), add = TRUE)
knitr::opts_chunk$restore()
on.exit(knitr::opts_chunk$set(oopts_chunk), add = TRUE)
knitr::opts_current$restore()
on.exit(knitr::opts_current$set(oopts_current), add = TRUE)
knitr::opts_knit$set("unnamed.chunk.label" =
paste("modulr", path, sep = "-"))
script <-
knitr::knit(text = readChar(path, file.info(path)[["size"]]),
tangle = TRUE, quiet = TRUE)
tryCatch({
local(eval(parse(text = script, keep.source = TRUE)),
envir = wrapper_env)
loaded <- TRUE
},
error = function(e) {
rollback()
e$message <- sprintf("%s Rolling back.", e$message)
stop(e)
})
}
loaded_names <-
setdiff(names(.modulr_env$injector$registry), names(registry))
if (loaded)
loaded_names <- c(name, loaded_names)
loaded_names <- unique(loaded_names)
along <- NA_character_
if (length(loaded_names) > 1L) {
along <- if (is.null(name)) {
parsed_names <- lapply(loaded_names, .parse_name)
finals <- do.call(c, lapply(parsed_names, `[[`, "final"))
file_final <-
.parse_name(basename(tools::file_path_sans_ext(path)))[["final"]]
along_ <- loaded_names[finals == file_final]
if (length(along_) > 0L) along_[1L] else loaded_names[1L]
} else name
}
Map(function(name_) {
.modulr_env$injector$registry[[c(name_, "storage")]] <- "on-disk"
.modulr_env$injector$registry[[c(name_, "filepath")]] <- path
.modulr_env$injector$registry[[c(name_, "along")]] <-
ifelse(isTRUE(name_ != along), along, NA_character_)
},
loaded_names)
}
if (check)
assert_that(.is_defined(name))
return(path)
}
#' Load a Module.
#'
#' Load or reload a module which is defined in an R, R Markdown or R Sweave
#' file stored on disk.
#'
#' @inheritParams define
#'
#' @return The absolute file name of the loaded module.
#'
#' @details
#'
#' As described in \code{\link{define}} under \emph{Implicit Definition}, the
#' module name is resolved into a file location by applying the rules accessed
#' by \code{\link{root_config}}, \code{\link{paths_config}}, and
#' \code{\link{maps_config}}. R Markdown and R Sweave files are accordingly
#' tangled into R code, which is in turn evaluated.
#'
#' @section Warning:
#' It is considered a very bad practice to define, touch, undefine, load, make,
#' reset, or perform any other operation from within a module definition that
#' may alterate the internal state of modulr.
#'
#' @seealso \code{\link{.Last.name}}, \code{\link{make}},
#' \code{\link{maps_config}}, \code{\link{paths_config}}, and
#' \code{\link{reset}}.
#'
#' @examples
#' reset()
#' tmp_dir <- tempfile("modulr_")
#' dir.create(tmp_dir)
#' tmp_file <- file.path(tmp_dir, "foo.R")
#' cat('define("foo", NULL, function() "Hello World!")', file = tmp_file)
#' root_config$set(tmp_dir)
#' load_module("foo")
#' make()
#' unlink(tmp_dir, recursive = TRUE)
#' load_module("foo")
#'
#' @export
load_module <- function(name = .Last.name) {
.message_meta(sprintf("Entering load_module() for '%s' ...", name),
verbosity = +Inf)
assert_that(.is_conform(name))
if (.is_called_from_within_module()) {
warning("load_module is called from within a module.",
call. = FALSE, immediate. = TRUE)
}
if (.is_nested_load()) {
warning("loading calls are nested. Stopping recursion.",
call. = FALSE, immediate. = TRUE)
return(invisible(NULL))
}
module <- find_module(name, absolute = FALSE)
loaded_module <- NA
if (!is.null(module)) {
name <- module[["name"]]
if (module[["storage"]] == "on-disk" && file.exists(module[["filepath"]])) {
loaded_module <-
.load_module(path = module[["filepath"]], name = name,
check = TRUE)
}
}
assert_that(.is_defined(name))
stats::setNames(loaded_module, name)
}
#' Load All Modules.
#'
#' Load or reload all modules which are defined in the named directory.
#'
#' @inheritParams base::list.files
#' @param ... Further arguments to be passed to \code{base::\link[base]{list.files}}.
#'
#' @section Warning:
#' It is considered a very bad practice to define, touch, undefine, load, make,
#' reset, or perform any other operation from within a module definition that
#' may alterate the internal state of modulr.
#'
#' @seealso \code{\link{load_module}}, \code{\link{make_all}}, and
#' \code{\link{reset}}.
#'
#' @examples
#' reset()
#' tmp_dir <- tempfile("modulr_")
#' dir.create(tmp_dir)
#' tmp_file <- file.path(tmp_dir, "foo.R")
#' cat('define("foo", NULL, function() print("Hello World!"))', file = tmp_file)
#' tmp_file <- file.path(tmp_dir, "bar.R")
#' cat('define("bar", NULL, function() print("hELLO wORLD?"))', file = tmp_file)
#' load_all_modules(tmp_dir)
#' make_all()
#' unlink(tmp_dir, recursive = TRUE)
#'
#' @export
load_all_modules <- function(
path = c("lib", "libs", "module", "modules", "."),
pattern = "[^_]\\.[rR][(?:md)|(?:nw)]?$",
full.names = TRUE,
recursive = TRUE, ...) {
.message_meta("Entering load_all_modules() ...",
verbosity = +Inf)
if (.is_called_from_within_module()) {
warning("load_all_modules is called from within a module.",
call. = FALSE, immediate. = TRUE)
}
files <- list.files(
path = path, pattern = pattern,
full.names = full.names, recursive = recursive, ...)
if (length(files) > 0L)
Map(.load_module, files, check = FALSE)
invisible(NULL)
}
# We need to make sure all dependent modules of a given module are defined.
.define_all_dependent_modules <- function(group) {
assert_that(is.character(group))
visited_dependencies <- c()
iteration <- function(name, scope_name = NULL) {
if (!(name %in% visited_dependencies)) {
loaded_module <- stats::setNames(names(load_module(name)), name)
visited_dependencies <<- c(visited_dependencies, loaded_module)
Map(function(dependency) iteration(dependency, name),
.modulr_env$injector$registry[[c(loaded_module, "dependencies")]])
}
}
for (name in group)
iteration(name)
visited_dependencies
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.