Skip to content

Commit

Permalink
Add Sys.path.experimental
Browse files Browse the repository at this point in the history
  • Loading branch information
dbosak01 committed Jul 3, 2023
1 parent 6e9b0b3 commit 1675572
Show file tree
Hide file tree
Showing 10 changed files with 326 additions and 2 deletions.
5 changes: 3 additions & 2 deletions DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: common
Type: Package
Title: Solutions for Common Problems in Base R
Version: 1.0.7
Version: 1.0.8
Authors@R: c(
person(given = "David",
family = "Bosak",
Expand All @@ -25,7 +25,8 @@ Suggests:
knitr,
rmarkdown,
testthat (>= 3.0.0),
glue
glue,
box
Enhances: base
Imports: this.path (< 2.0),
utils
Expand Down
1 change: 1 addition & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,7 @@ export("%eq%")
export("%p%")
export("labels<-")
export(Sys.path)
export(Sys.path.experimental)
export(copy.attributes)
export(dir.find)
export(file.find)
Expand Down
4 changes: 4 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,7 @@
# common 1.0.8

* Remove dependency on this.path().

# common 1.0.7

* Changes to prevent breakage of this.path().
Expand Down
262 changes: 262 additions & 0 deletions R/syspath.R
Original file line number Diff line number Diff line change
Expand Up @@ -21,3 +21,265 @@ Sys.path.internal <- function() {
return(ppth)

}




#' @title EXPERIMENTAL: Returns the path of the current program
#' @description A function that gets the full path of the currently running
#' program. If the function fails to retrieve the path for some reason,
#' it will return a NULL. The function takes no parameters.
#' @returns The full path of the currently running program, or a NULL.
#' @family fileops
#' @examples
#' # Get current path
#' pth <- Sys.path.experimental()
#' pth
#' # [1] "C:/programs/myprogram.R"
#' @export
Sys.path.experimental <- function() {

ret <- NULL

debug <- FALSE
if (!is.null(options()[["common.debug"]])) {
debug <- options("common.debug")[[1]]
}

# Get list of installed packages
si <- sessionInfo()
pkglst <- names(si$otherPkgs)

# Assign debugSource. This is used when running RStudio in debug mode.
debugSource <- if (.Platform$GUI == "RStudio")
get("debugSource", "tools:rstudio", inherits = FALSE)


# Check call stack to see if this program is being sourced in some way.
# There are several different sourcing functions. If one of them is called,
# pull the file name from the appropriate variable inside that function.
for (n in seq.int(to = 1, by = -1, length.out = sys.nframe() - 1)) {

if (identical(sys.function(n), base::source)) {
if (exists("ofile", envir = sys.frame(n), inherits = FALSE)) {

ret <- get("ofile", envir = sys.frame(n), inherits = FALSE)

if (!is.character(ret))
ret <- summary.connection(ret)$description

}

if (debug)
message("base::source() call identified:" %p% ret)

}

if (identical(sys.function(n), base::sys.source)) {

if (exists("exprs", envir = sys.frame(n), inherits = FALSE)) {

ret <- get("file", envir = sys.frame(n), inherits = FALSE)

}

if (debug)
message("base::sys.source() call identified:" %p% ret)

}

if ("testthat" %in% pkglst) {
if (identical(sys.function(n), testthat::source_file)) {

if (exists("path", envir = sys.frame(n), inherits = FALSE)) {

ret <- get("path", envir = sys.frame(n), inherits = FALSE)

}

if (debug)
message("testthat::source_file() call identified:" %p% ret)

}
}

if ("rmarkdown" %in% pkglst) {
if (identical(sys.function(n), rmarkdown::render)) {

if (exists("input", envir = sys.frame(n), inherits = FALSE)) {

ret <- get("input", envir = sys.frame(n), inherits = FALSE)

}

if (debug)
message("rmarkdown::render() call identified:" %p% ret)

}
}

if ("knitr" %in% pkglst) {
if (identical(sys.function(n), knitr::knit)) {

if (exists("input", envir = sys.frame(n), inherits = FALSE)) {

ret <- get("input", envir = sys.frame(n), inherits = FALSE)

}

if (debug)
message("knitr::knit() call identified:" %p% ret)

}
}

if ("compiler" %in% pkglst) {
if (identical(sys.function(n), compiler::loadcmp)) {

if (exists("file", envir = sys.frame(n), inherits = FALSE)) {

ret <- get("file", envir = sys.frame(n), inherits = FALSE)

}

if (debug)
message("compiler::loadcmp() call identified:" %p% ret)
}
}

if ("box" %in% pkglst) {
if (identical(sys.function(n), box::use)) {
tryCatch({

ret <- box::file(mustWork = FALSE)

}, error = function(e) {ret <- NULL})

if (debug)
message("box::use() call identified:" %p% ret)

}
}

if (identical(sys.function(n), debugSource)) {

tryCatch({

ret <- get("fileName", envir = sys.frame(n), inherits = FALSE)

}, error = function(e) {ret <- NULL})

if (debug)
message("debugSource() call identified:" %p% ret)

}

# If assigned above, bail out of for loop
if (!is.null(ret)) {

if (debug)
message("source call found:" %p% ret)

break()

}
}

# If no source call, check for interactive session or command line
if (is.null(ret)) {

# Running from RStudio
if (.Platform$GUI == "RStudio") {


# This variable contains information about the currently open document
tryCatch({

context <- get(".rs.api.getSourceEditorContext",
"tools:rstudio", inherits = FALSE)()

if (!is.null(context)) {

ret <- context[["path"]]

if (nzchar(ret)) {
Encoding(ret) <- "UTF-8"

}
}
}, error = function(e) {ret <- NULL})

if (debug)
message("RStudio interactive call found:" %p% ret)
}

# Check for shells
else if (.Platform$OS.type == "windows" && .Platform$GUI == "RTerm" ||
.Platform$OS.type == "unix" && .Platform$GUI == "X11")
{

# Parse command line to pull out file argument
argv <- paste(commandArgs(), collapse = " ")
startpos <- regexpr("--args", argv, fixed = TRUE)
if (startpos > 0) {
argv <- substr(argv, 1, startpos - 1)

}

ret <- trimws(sub("--file=", "", argv, fixed = TRUE))

if (length(ret) == 0)
ret <- NULL

if (debug)
message("Shell call found:" %p% ret)

}

# Running from RGui on Windows
else if (.Platform$OS.type == "windows" && .Platform$GUI == "Rgui") {

if (debug)
message("Windows Rgui call found:" %p% ret)

}

# Running from RGui on macOS
else if (.Platform$OS.type == "unix" && .Platform$GUI == "AQUA") {

if (debug)
message("Unix Rgui call found:" %p% ret)

}

}

# Clean up and normalize path
if (!is.null(ret)) {

if (debug)
message("Path found:" %p% ret)

ret <- sub("file:///", "", ret, fixed = TRUE)

# Try to normalize. If can't, just ignore
ret <- normalizePath(ret, "/", FALSE)

} else {


if (debug)
message(paste0("Path not found. Platform: ", .Platform$OS.type,
" GUI: ", .Platform$GUI))

}


return(ret)

}





1 change: 1 addition & 0 deletions _pkgdown.yml
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@ reference:
desc: Functions that help with file management.
contents:
- Sys.path
- Sys.path.experimental
- file.find
- dir.find

Expand Down
1 change: 1 addition & 0 deletions man/Sys.path.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

29 changes: 29 additions & 0 deletions man/Sys.path.experimental.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

1 change: 1 addition & 0 deletions man/dir.find.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

1 change: 1 addition & 0 deletions man/file.find.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

23 changes: 23 additions & 0 deletions tests/testthat/test-file_functions.R
Original file line number Diff line number Diff line change
Expand Up @@ -248,3 +248,26 @@ test_that("file7: dir.find() works as expect.", {

})


test_that("file8: Sys.path() works as expect.", {


res <- Sys.path()

expect_equal(is.null(res), FALSE)

})


test_that("file9: Sys.path.experimental() works as expect.", {


res <- Sys.path.experimental()

expect_equal(is.null(res), FALSE)

})




0 comments on commit 1675572

Please sign in to comment.