# NOT RUN {
The following will create a temporary R script containing
calls to 'this.path'. You should see that 'this.path' works
through a call to 'source', a call to 'sys.source', a call
to 'debugSource' (if running from 'RStudio'), and when
running R from the command-line / / terminal.
Unfortunately, it is impossible to use 'example(this.path)'
to demonstrate the functionality of 'this.path' in 'RStudio'
and 'RGui'. If you would like to see this functionality, you
could try this:
* make a new R script containing just this one command:
this.path::this.path(verbose = TRUE)
* open this script in 'RStudio' or 'RGui'
* run that command directly from the script
(both should print "Source: active document ..." along
with the script's path)
* copy and paste that command into the R Console and run
that command again
(both should print "Source: source document ..." along
with the script's path)
* try closing all your documents and run that same command
in the R Console
(both should raise an error "R is being run ... with no
documents open")
# }
# NOT RUN {
tryCatch((function() {
.interactive <- interactive()
if (.interactive) {
cat("\n")
prompt <- "Would you like to run this example interactively? (Yes/No/Cancel): "
repeat {
response <- tolower(substr(readline(prompt), 1, 1))
if (response %in% c("y", "n", "c"))
break
}
if (response == "c") {
cat("\n")
return(invisible())
}
.interactive <- response == "y"
}
if (.interactive) {
pressEnter2Continue <- function(x = "\n") {
readline("Hit <Return> to continue: ")
cat(x)
}
}
else pressEnter2Continue <- function(...) NULL
oopt <- options(useFancyQuotes = TRUE)
on.exit(options(oopt))
tryCatch({
tmp.R.script <- normalizePath(tempfile(
pattern = "this.path.example.R.script.",
tmpdir = tempdir(check = TRUE), fileext = ".R"
), mustWork = FALSE)
on.exit(suppressWarnings(file.remove(tmp.R.script)), add = TRUE)
}, condition = function(c) {
stop(errorCondition(paste0(conditionMessage(c),
"\nunable to create temporary R script"),
call = conditionCall(c)))
})
results.file <- tryCatch({
.Sys.time <- format(Sys.time(), format = "%Y-%m-%d_%H.%M.%OS.")
normalizePath(tempfile(
pattern = paste0("this.path.example.results.", .Sys.time),
tmpdir = dirname(tmp.R.script), fileext = ".txt"
), mustWork = FALSE)
}, condition = as.null)
write.results <- function(expr) {
if (!is.null(results.file)) {
sink(file = results.file, append = TRUE)
on.exit(sink())
}
expr
}
tmp.R.script.code <- substitute({
options(useFancyQuotes = TRUE)
results.file <- `results.file sub`
write.results <- `write.results sub`
cat("\n")
write.results({
x <- tryCatch({
this.path::this.path(verbose = TRUE)
TRUE
}, condition = force)
cat("this.path status : ")
})
if (!isTRUE(x)) {
msg <- conditionMessage(x)
call <- conditionCall(x)
write.results({
if (!is.null(call))
cat("Error in ", deparse(call), " :\n ", msg, "\n",
sep = "")
else cat("Error: ", msg, "\n", sep = "")
})
if (!is.null(call))
cat("Error in ", deparse(call), " :\n ", msg, "\n", sep = "")
else cat("Error: ", msg, "\n", sep = "")
cat(sQuote("this.path"), " could not determine the executing ",
"script's filename\n", sep = "")
}
else {
cat("Executing script's filename:\n")
cat(sQuote(`tmp.R.script sub`), "\n\n", sep = "")
cat("Executing script's filename (as determined by ",
sQuote("this.path"), "):\n", sep = "")
cat(sQuote(this.path::this.path(verbose = TRUE)), "\n", sep = "")
if (`tmp.R.script sub` != this.path::this.path(verbose = FALSE)) {
write.results({
cat("Error: ", sQuote("this.path"), " could not correctly ",
"determine the executing script's filename\n", sep = "")
})
cat("\nError: ", sQuote("this.path"), " could not correctly ",
"determine the executing script's filename\n", sep = "")
}
else write.results(cat("success\n"))
}
}, list(
`write.results sub` = write.results,
`tmp.R.script sub` = tmp.R.script,
`results.file sub` = results.file
))
writeRcode2file <- function(x, file) {
tryCatch({
lines <- vapply(as.list(x[-1]), function(y) {
paste0(deparse(y), collapse = "\n")
}, FUN.VALUE = "")
writeLines(lines, con = file)
}, condition = function(c) {
stop(errorCondition(paste0(conditionMessage(c),
"\nunable to write R code to file ", sQuote(file)),
call = conditionCall(c)))
})
}
writeRcode2file(tmp.R.script.code, tmp.R.script)
cat2 <- function(msg, ..., appendLF = TRUE) {
cat(if (appendLF) "\n", paste0(strwrap(msg, exdent = 2),
"\n", collapse = ""), ..., sep = "")
}
cat2(paste0("Created an example R script. This script will be run in ",
"all possible ways that are compatible with ", sQuote("this.path"),
" that are currently available."))
if (.interactive) {
cat2(paste0("Attempting to open the example R script. If the ",
"script did not open automatically, the script's path is:"),
sQuote(tmp.R.script), "\n")
tryCatch({
this.path:::file.open(tmp.R.script)
}, condition = invisible)
pressEnter2Continue("")
}
write.results(cat2(paste0("Attempting to use ", sQuote("this.path"),
" when using ", sQuote("source")), appendLF = FALSE))
tryCatch({
cat("\n* first, using ", sQuote("source"), "\n", sep = "")
source(tmp.R.script, local = TRUE)
pressEnter2Continue("")
}, condition = function(c) {
msg <- paste0(conditionMessage(c), "\nunable to source file ",
sQuote(tmp.R.script))
call <- conditionCall(c)
if (!is.null(call))
cat("Error in ", deparse(call), " :\n ", msg, "\n", sep = "")
else cat("Error: ", msg, "\n", sep = "")
})
write.results(cat2(paste0("Attempting to use ", sQuote("this.path"),
" when using ", sQuote("sys.source"))))
tryCatch({
cat("\n* second, using ", sQuote("sys.source"), "\n", sep = "")
sys.source(tmp.R.script, envir = environment())
pressEnter2Continue("")
}, condition = function(c) {
msg <- paste0(conditionMessage(c), "\nunable to source file ",
sQuote(tmp.R.script))
call <- conditionCall(c)
if (!is.null(call))
cat("Error in ", deparse(call), " :\n ", msg, "\n", sep = "")
else cat("Error: ", msg, "\n", sep = "")
})
if (.Platform$GUI == "RStudio") {
write.results(cat2(paste0("Attempting to use ", sQuote("this.path"),
" when using ", sQuote("debugSource"))))
tryCatch({
cat("\n* third, using ", sQuote("debugSource"),
" from ", sQuote("RStudio"), "\n", sep = "")
dbs <- get("debugSource", mode = "function", "tools:rstudio",
inherits = FALSE)
dbs(tmp.R.script, local = TRUE)
pressEnter2Continue("")
}, condition = function(c) {
msg <- paste0(conditionMessage(c), "\nunable to source file ",
sQuote(tmp.R.script))
call <- conditionCall(c)
if (!is.null(call))
cat("Error in ", deparse(call), " :\n ", msg, "\n", sep = "")
else cat("Error: ", msg, "\n", sep = "")
})
}
else write.results({
cat2(paste0("Unfortunately, it is impossible to demonstrate the ",
"functionality of ", sQuote("this.path"), " when using ",
sQuote("debugSource"), " because ", sQuote("RStudio"), " is not ",
"presently running."))
})
if (!isNamespaceLoaded("testthat")) {
if (.interactive) {
cat2(paste0(sQuote("this.path"), " also works with function ",
sQuote("source_file"), " from package ", sQuote("testthat"),
", but this package is not presently loaded."))
prompt <- "Would you like to load this package? (Yes/No/Cancel): "
repeat {
response <- tolower(substr(readline(prompt), 1, 1))
if (response %in% c("y", "n", "c"))
break
}
}
else response <- "y"
if (response == "y") {
if (requireNamespace("testthat", quietly = TRUE)) {
on.exit(unloadNamespace("testthat"), add = TRUE)
cat2(paste0("Package ", sQuote("testthat"), " will be ",
"unloaded once the example concludes."))
}
else cat2(paste0("Package ", sQuote("testthat"), " was not ",
"successfully loaded."))
}
}
if (isNamespaceLoaded("testthat")) {
write.results(cat2(paste0("Attempting to use ", sQuote("this.path"),
" when using ", sQuote("testthat::source_file"))))
tryCatch({
cat("\n* ", if (.Platform$GUI != "RStudio")
"third"
else "fourth", ", using ", sQuote("testthat::source_file"), "\n",
sep = "")
testthat::source_file(tmp.R.script)
pressEnter2Continue("")
}, condition = function(c) {
msg <- paste0(conditionMessage(c), "\nunable to source file ",
sQuote(tmp.R.script))
call <- conditionCall(c)
if (!is.null(call))
cat("Error in ", deparse(call), " :\n ", msg, "\n", sep = "")
else cat("Error: ", msg, "\n", sep = "")
})
}
else write.results({
cat2(paste0("Unfortunately, it is impossible to demonstrate the ",
"functionality of ", sQuote("this.path"), " when using ",
sQuote("source_file"), " because package ", sQuote("testthat"),
" is not presently loaded."))
})
cmt <- if (.Platform$OS.type == "windows")
"Windows command-line"
else "Unix terminal"
write.results(cat2(paste0("Attempting to use ", sQuote("this.path"),
" when running from the ", cmt)))
command <- sprintf("Rterm --no-echo --no-restore --file=%s",
this.path:::file.encode(tmp.R.script))
tryCatch({
cat("\n* last, running from the ", cmt, "\n", sep = "")
cat("\nProcess finished with exit code ",
system(command), "\n", sep = "")
pressEnter2Continue()
}, condition = function(c) {
msg <- paste0(conditionMessage(c), "\nunable to run file ",
sQuote(tmp.R.script), "\n from the ", cmt)
call <- conditionCall(c)
if (!is.null(call))
cat("Error in ", deparse(call), " :\n ", msg, "\n", sep = "")
else cat("Error: ", msg, "\n", sep = "")
})
write.results({
cat2(paste0("Unfortunately, it is impossible to use ",
sQuote("example(this.path)"), " to demonstrate the functionality ",
"of ", sQuote("this.path"), " in ", sQuote("RStudio"), " and ",
sQuote("RGui"), ". If you would like to see this functionality, ",
"you could try this:"),
"* make a new R script containing just this one command:\n",
" this.path::this.path(verbose = TRUE)\n",
"* open this script in ", sQuote("RStudio"), " or ", sQuote("RGui"),
"\n",
"* run that command directly from the script\n",
" (both should print \"Source: active document ...\" along ",
"with the script's path)\n",
"* copy and paste that command into the R Console and run that ",
"command again\n",
" (both should print \"Source: source document ...\" along ",
"with the script's path)\n",
"* try closing all your documents and run that same command in ",
"the R Console\n",
" (both should raise an error \"R is being run ... with no ",
"documents open\")\n")
})
write.results({
cat2(paste0("If ", sQuote("this.path"), " did not correctly determine ",
"the executing script's filename, please send a bug report to the ",
"package maintainer, ",
utils::packageDescription("this.path")$Maintainer, ". Please ",
"include your session information in your bug report, which can ",
"be found with the following command:"), "utils::sessionInfo()\n")
})
if (.interactive) {
tryCatch({
this.path:::file.open(results.file)
}, condition = function(c) {
cat("\n")
cat("* results\n", readLines(results.file), sep = "\n")
})
}
else if (!is.null(results.file)) {
cat("\n")
cat("* results\n", readLines(results.file), sep = "\n")
}
invisible()
})(), condition = function(c) {
msg <- conditionMessage(c)
call <- conditionCall(c)
if (!is.null(call))
cat("Error in ", deparse(call), " :\n ", msg, "\n", sep = "")
else cat("Error: ", msg, "\n", sep = "")
})
# }
Run the code above in your browser using DataLab