Nothing
local({
owd <- getwd()
if (is.null(owd)) {
message("cannot 'chdir' as current directory is unknown")
return(invisible())
} else on.exit(setwd(owd), add = TRUE)
## test for 3 specific cases of sourcing
## * sourcing a file by specifying its basename
## * sourcing a file by specifying its absolute path
## * sourcing a file by specifying one of its relative paths
abs_path_R <- tempfile("test", fileext = ".R")
on.exit(unlink(abs_path_R), add = TRUE)
this.path:::.writeCode({
n <- this.path:::.getframenumber()
if (is.na(n) || n < 1L) stop("invalid traceback")
sym <- ".this.path::document.context"
frame <- sys.frame(n)
if (!exists(sym, envir = frame, inherits = FALSE))
sym <- ".this.path::document.contexts"
stopifnot(bindingIsLocked(sym, frame))
cat("\n> getwd()\n")
print(getwd())
cat("\n> ", paste(deparse(call("dynGet", sym)), collapse = "\n+ "), "\n", sep = "")
print(frame[[sym]])
cat("\n> this.path::sys.path(original = TRUE)\n")
print(this.path::sys.path(original = TRUE))
cat("\n> this.path::sys.path(for.msg = TRUE)\n")
print(this.path::sys.path(for.msg = TRUE))
cat("\n> sys.path(verbose = TRUE)\n")
stopifnot(identical(
print(this.path::sys.path(verbose = TRUE)),
getOption("this.path::sys.path() expectation")
))
cat("\n> this.path::sys.path(original = TRUE)\n")
print(this.path::sys.path(original = TRUE))
cat("\n> this.path::sys.path(for.msg = TRUE)\n")
print(this.path::sys.path(for.msg = TRUE))
}, file = abs_path_R)
abs_path_R <- normalizePath(abs_path_R, "/", TRUE)
abs_path_dir <- normalizePath(R.home(), "/", TRUE)
basename_R <- this.path::basename2(abs_path_R)
basename_dir <- this.path::dirname2(abs_path_R)
rel_path_and_dir <- function(file) {
x <- this.path::path.split.1(file)
n <- length(x)
if (n < 3L) {
c(this.path::dirname2(file), this.path::basename2(file))
} else {
i <- n < seq_len(n) + max(2L, n%/%2L)
c(this.path::path.unsplit(x[!i]), this.path::path.unsplit(x[i]))
}
}
tmp <- rel_path_and_dir(abs_path_R)
rel_path_dir <- tmp[[1L]]
rel_path_R <- tmp[[2L]]
rm(tmp)
## for 'source' and 'debugSource' specifically,
## try sourcing a 'file://' URL
basename_R_URL <- this.path:::.as_file_URL(basename_R)
rel_path_R_URL <- this.path:::.as_file_URL(rel_path_R)
abs_path_R_URL <- this.path:::.as_file_URL(abs_path_R)
fun <- function(expr, envir = parent.frame(),
bquote.envir = envir, eval.envir = envir)
{
if (!is.environment(envir))
stop("not an environment", domain = "R")
expr <- call("bquote", substitute(expr), as.symbol("bquote.envir"))
expr <- eval(expr)
dep <- deparse(expr)
cat("\n\n\n\n\n\n\n\n\n\n")
cat("\n> getwd()\n")
print(getwd())
cat("\n> ")
cat(dep, sep = "\n+ ")
eval(expr, eval.envir)
}
oopt <- options(`this.path::sys.path() expectation` = normalizePath(abs_path_R, "/", TRUE))
on.exit(options(oopt), add = TRUE)
## try using source in all possible manners
setwd(basename_dir)
fun(source(.(basename_R) , local = TRUE, chdir = FALSE)) ## from a basename without changing directory
fun(source(.(basename_R) , local = TRUE, chdir = TRUE )) ## from a basename with changing directory (shouldn't do anything)
fun(source(.(basename_R_URL) , local = TRUE)) ## from a basename 'file://' URL
fun(source(print(conn <- file(open = "r", .(basename_R))), local = TRUE)) ; close(conn) ## from a basename connection
setwd(rel_path_dir)
fun(source(.(rel_path_R) , local = TRUE, chdir = FALSE)) ## from a relative path without changing directory
fun(source(.(rel_path_R) , local = TRUE, chdir = TRUE )) ## from a relative path with changing directory
fun(source(.(rel_path_R_URL) , local = TRUE)) ## from a relative path 'file://' URL
fun(source(print(conn <- file(open = "r", .(rel_path_R))), local = TRUE)) ; close(conn) ## from a relative path connection
setwd(abs_path_dir)
fun(source(.(abs_path_R) , local = TRUE, chdir = FALSE)) ## from an absolute path without changing directory
fun(source(.(abs_path_R) , local = TRUE, chdir = TRUE )) ## from an absolute path with changing directory
fun(source(.(abs_path_R_URL) , local = TRUE)) ## from an absolute path 'file://' URL
fun(source(print(conn <- file(open = "r", .(abs_path_R))), local = TRUE)) ; close(conn) ## from an absolute path connection
## 'sys.source' cannot handle 'file://' URLs nor connections
setwd(basename_dir)
fun(sys.source(.(basename_R), envir = environment(), chdir = FALSE))
fun(sys.source(.(basename_R), envir = environment(), chdir = TRUE ))
setwd(rel_path_dir)
fun(sys.source(.(rel_path_R), envir = environment(), chdir = FALSE))
fun(sys.source(.(rel_path_R), envir = environment(), chdir = TRUE ))
setwd(abs_path_dir)
fun(sys.source(.(abs_path_R), envir = environment(), chdir = FALSE))
fun(sys.source(.(abs_path_R), envir = environment(), chdir = TRUE ))
## 'debugSource' cannot handle connections
if (.Platform$GUI == "RStudio") {
debugSource <- get("debugSource", "tools:rstudio", inherits = FALSE)
setwd(basename_dir)
fun(debugSource(.(basename_R) ))
fun(debugSource(.(basename_R_URL)))
setwd(rel_path_dir)
fun(debugSource(.(rel_path_R) ))
fun(debugSource(.(rel_path_R_URL)))
setwd(abs_path_dir)
fun(debugSource(.(abs_path_R) ))
fun(debugSource(.(abs_path_R_URL)))
}
## 'compiler::loadcmp' cannot handle 'file://' URLs nor connections
if (requireNamespace("compiler", quietly = TRUE)) {
basename_Rc <- basename_R; this.path::ext(basename_Rc) <- ".Rc"
rel_path_Rc <- rel_path_R; this.path::ext(rel_path_Rc) <- ".Rc"
abs_path_Rc <- abs_path_R; this.path::ext(abs_path_Rc) <- ".Rc"
on.exit(unlink(abs_path_Rc), add = TRUE)
compiler::cmpfile(abs_path_R, abs_path_Rc)
opt2 <- options(`this.path::sys.path() expectation` = normalizePath(abs_path_Rc, "/", TRUE))
setwd(basename_dir)
fun(compiler::loadcmp(.(basename_Rc), envir = environment(), chdir = FALSE))
fun(compiler::loadcmp(.(basename_Rc), envir = environment(), chdir = TRUE ))
setwd(rel_path_dir)
fun(compiler::loadcmp(.(rel_path_Rc), envir = environment(), chdir = FALSE))
fun(compiler::loadcmp(.(rel_path_Rc), envir = environment(), chdir = TRUE ))
setwd(abs_path_dir)
fun(compiler::loadcmp(.(abs_path_Rc), envir = environment(), chdir = FALSE))
fun(compiler::loadcmp(.(abs_path_Rc), envir = environment(), chdir = TRUE ))
options(opt2)
}
## 'utils::Sweave' cannot handle 'file://' URLs nor connections
if (requireNamespace("utils", quietly = TRUE)) {
basename_Rnw <- basename_R; this.path::ext(basename_Rnw) <- ".Rnw"
abs_path_Rnw <- abs_path_R; this.path::ext(abs_path_Rnw) <- ".Rnw"
on.exit(unlink(abs_path_Rnw), add = TRUE)
writeLines(c(
"\\documentclass{article}",
"",
"\\begin{document}",
"",
"<<>>=",
## remove expressions starting with 'cat'
{
exprs <- parse(abs_path_R)
exprs <- exprs[!vapply(exprs, function(expr) {
is.call(expr) && identical(expr[[1L]], as.symbol("cat"))
}, NA, USE.NAMES = FALSE)]
this.path:::.writeCode(exprs, NULL)
},
"@",
"",
"\\end{document}"
), abs_path_Rnw)
opt2 <- options(`this.path::sys.path() expectation` = normalizePath(abs_path_Rnw, "/", TRUE))
setwd(basename_dir)
outputname <- fun(utils::Sweave(.(basename_Rnw)))
writeLines(readLines(outputname))
unlink(outputname)
tmpdir <- tempfile("dir")
on.exit(unlink(tmpdir, recursive = TRUE, force = TRUE), add = TRUE)
dir.create(tmpdir)
setwd(tmpdir)
writeLines(readLines(fun(utils::Sweave(.(this.path::path.join("..", basename_Rnw))))))
options(opt2)
}
## 'box::use' cannot handle 'file://' URLs nor connections nor absolute paths
if (requireNamespace("box", quietly = TRUE)) {
tmp <- c(sub("\\.R$", ".r", abs_path_R), abs_path_R)
tmp <- tmp[[match(TRUE, file.exists(tmp))]]
opt2 <- options(`this.path::sys.path() expectation` = normalizePath(tmp, "/", TRUE))
setwd(basename_dir); box::set_script_path(this.path::path.join(basename_dir, "."))
fun(box::use(module = ./.(as.symbol(sub("\\.R$", "", basename_R))))); box::unload(module)
if (!this.path:::.is_abs_path(rel_path_R)) {
tmp_fun <- function(x) {
n <- length(x)
if (n > 1L)
call("/", tmp_fun(x[-n]), as.symbol(x[[n]]))
else as.symbol(x[[1L]])
}
tmp <- tmp_fun(c(".", this.path::path.split.1(sub("\\.R$", "", rel_path_R))))
setwd(rel_path_dir); box::set_script_path(this.path::path.join(rel_path_dir, "."))
fun(box::use(module = .(tmp))); box::unload(module)
rm(tmp, tmp_fun)
}
options(opt2)
}
## 'knitr::knit' cannot handle 'file://' URLs
if (requireNamespace("knitr", quietly = TRUE)) {
basename_Rmd <- basename_R; this.path::ext(basename_Rmd) <- ".Rmd"
rel_path_Rmd <- rel_path_R; this.path::ext(rel_path_Rmd) <- ".Rmd"
abs_path_Rmd <- abs_path_R; this.path::ext(abs_path_Rmd) <- ".Rmd"
on.exit(unlink(abs_path_Rmd), add = TRUE)
writeLines(c(
"```{r}",
## remove expressions starting with 'cat'
{
exprs <- parse(abs_path_R)
exprs <- exprs[!vapply(exprs, function(expr) {
is.call(expr) && identical(expr[[1L]], as.symbol("cat"))
}, NA, USE.NAMES = FALSE)]
this.path:::.writeCode(exprs, NULL)
},
"```"
), abs_path_Rmd)
opt2 <- options(`this.path::sys.path() expectation` = normalizePath(abs_path_Rmd, "/", TRUE))
setwd(basename_dir)
fun(knitr::knit(.(basename_Rmd) , output = stdout(), quiet = TRUE))
fun(knitr::knit(print(conn <- file(.(basename_Rmd))), output = stdout(), quiet = TRUE)); close(conn)
setwd(rel_path_dir)
fun(knitr::knit(.(rel_path_Rmd) , output = stdout(), quiet = TRUE))
fun(knitr::knit(print(conn <- file(.(rel_path_Rmd))), output = stdout(), quiet = TRUE)); close(conn)
setwd(abs_path_dir)
fun(knitr::knit(.(abs_path_Rmd) , output = stdout(), quiet = TRUE))
fun(knitr::knit(print(conn <- file(.(abs_path_Rmd))), output = stdout(), quiet = TRUE)); close(conn)
options(opt2)
}
## 'plumber::plumb' cannot handle 'file://' URLs nor connections
if (requireNamespace("plumber", quietly = TRUE)) {
opt2 <- options(`this.path::sys.path() expectation` = normalizePath(abs_path_R, "/", TRUE))
setwd(basename_dir)
fun(plumber::plumb(.(basename_R)))
setwd(rel_path_dir)
fun(plumber::plumb(.(rel_path_R)))
setwd(abs_path_dir)
fun(plumber::plumb(.(abs_path_R)))
options(opt2)
entrypoint_R <- this.path::path.join(basename_dir, "entrypoint.R")
on.exit(unlink(entrypoint_R), add = TRUE)
writeLines(c(
readLines(abs_path_R),
"plumber::Plumber$new()"
), entrypoint_R)
opt2 <- options(`this.path::sys.path() expectation` = normalizePath(entrypoint_R, "/", TRUE))
setwd(basename_dir)
fun(plumber::plumb())
setwd(rel_path_dir)
fun(plumber::plumb(dir = .(dirname(rel_path_R))))
setwd(abs_path_dir)
fun(plumber::plumb(dir = .(dirname(abs_path_R))))
options(opt2)
}
## 'shiny::runApp'
if (requireNamespace("shiny", quietly = TRUE)) {
shinytmp <- tempfile("shinytmp", tmpdir = basename_dir)
on.exit(unlink(shinytmp, recursive = TRUE, force = TRUE), add = TRUE)
dir.create(shinytmp)
file <- this.path::path.join(shinytmp, "app.R")
writeLines(c(
readLines(abs_path_R),
"stop(structure(list(message = \"\", call = NULL), class = c(\"this_path_tests_R_catch_this_error\", \"error\", \"condition\")))"
), file)
opt2 <- options(`this.path::sys.path() expectation` = normalizePath(file, "/", TRUE))
rm(file)
abs_path_app_R <- normalizePath(shinytmp, "/", TRUE)
abs_path_app_dir <- abs_path_dir
basename_app_R <- "."
basename_app_dir <- abs_path_app_R
tmp <- rel_path_and_dir(abs_path_app_R)
rel_path_app_dir <- tmp[[1L]]
rel_path_app_R <- tmp[[2L]]
rm(tmp)
setwd(basename_app_dir)
this.path::tryCatch3({
fun(shiny::runApp(.(basename_app_R)))
}, this_path_tests_R_catch_this_error = )
setwd(rel_path_app_dir)
this.path::tryCatch3({
fun(shiny::runApp(.(rel_path_app_R)))
}, this_path_tests_R_catch_this_error = )
setwd(abs_path_app_dir)
this.path::tryCatch3({
fun(shiny::runApp(.(abs_path_app_R)))
}, this_path_tests_R_catch_this_error = )
options(opt2)
}
## 'testthat::source_file' cannot handle 'file://' URLs nor connections
if (requireNamespace("testthat", quietly = TRUE)) {
setwd(basename_dir)
fun(testthat::source_file(.(basename_R), env = environment(), chdir = FALSE, wrap = FALSE))
fun(testthat::source_file(.(basename_R), env = environment(), chdir = FALSE, wrap = TRUE ))
fun(testthat::source_file(.(basename_R), env = environment(), chdir = TRUE , wrap = FALSE))
fun(testthat::source_file(.(basename_R), env = environment(), chdir = TRUE , wrap = TRUE ))
setwd(rel_path_dir)
fun(testthat::source_file(.(rel_path_R), env = environment(), chdir = FALSE, wrap = FALSE))
fun(testthat::source_file(.(rel_path_R), env = environment(), chdir = FALSE, wrap = TRUE ))
fun(testthat::source_file(.(rel_path_R), env = environment(), chdir = TRUE , wrap = FALSE))
fun(testthat::source_file(.(rel_path_R), env = environment(), chdir = TRUE , wrap = TRUE ))
setwd(abs_path_dir)
fun(testthat::source_file(.(abs_path_R), env = environment(), chdir = FALSE, wrap = FALSE))
fun(testthat::source_file(.(abs_path_R), env = environment(), chdir = FALSE, wrap = TRUE ))
fun(testthat::source_file(.(abs_path_R), env = environment(), chdir = TRUE , wrap = FALSE))
fun(testthat::source_file(.(abs_path_R), env = environment(), chdir = TRUE , wrap = TRUE ))
}
invisible()
})
local({
FILE.R <- tempfile(fileext = ".R")
on.exit(unlink(FILE.R))
this.path:::.writeCode({
stopifnot(identical(
this.path::this.path(),
getOption("this.path::this.path() expectation")
))
}, FILE.R)
oopt <- options(
`this.path::this.path() expectation` = normalizePath(FILE.R, "/", TRUE),
keep.source = TRUE
)
on.exit(options(oopt), add = TRUE)
eval(
parse(FILE.R),
structure(list2env(list(.packageName = FILE.R), parent = .BaseNamespaceEnv), path = FILE.R)
)
eval(parse(FILE.R))
})
local({
FILE.R <- tempfile(fileext = ".R")
on.exit(unlink(FILE.R))
this.path:::.writeCode({
list(
this.path::src.path(original = TRUE),
this.path::src.path(original = NA),
this.path::src.path(),
this.path::src.path(original = TRUE),
this.path::src.path(original = NA)
)
}, FILE.R)
oopt <- options(keep.source = TRUE)
on.exit(options(oopt), add = TRUE)
stopifnot(identical(
eval(parse(FILE.R)),
list(FILE.R, normalizePath(FILE.R, "/", TRUE))[c(1L, 1L, 2L, 1L, 2L)]
))
})
local({
FILE1.R <- tempfile(pattern = "file1_", fileext = ".R")
on.exit(unlink(FILE1.R), add = TRUE)
this.path:::.writeCode({
fun <- function(x) x
fun1 <- function() fun(this.path::src.path())
}, FILE1.R)
source(FILE1.R, environment(), keep.source = TRUE)
FILE2.R <- tempfile(pattern = "file2_", fileext = ".R")
on.exit(unlink(FILE2.R), add = TRUE)
this.path:::.writeCode({
fun2 <- function() fun(this.path::src.path())
}, FILE2.R)
source(FILE2.R, environment(), keep.source = TRUE)
## it might seem weird to use eval(expression())
## it is just to prevent the expressions from having source references
stopifnot(identical(eval(expression(fun1())), normalizePath(FILE1.R, "/", TRUE)))
stopifnot(identical(eval(expression(fun2())), normalizePath(FILE2.R, "/", TRUE)))
FILE3.R <- tempfile("file3_", fileext = ".R")
on.exit(unlink(FILE3.R), add = TRUE)
this.path:::.writeCode({
x <- list(fun1(), fun2(), fun(this.path::src.path()))
}, FILE3.R)
source(FILE3.R, environment(), keep.source = TRUE)
stopifnot(identical(x, as.list(normalizePath(c(FILE1.R, FILE2.R, FILE3.R), "/", TRUE))))
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.