Nothing
R/System.R
In R.utils: Various Programming Utilities
###########################################################################/**
# @RdocClass System
#
# @title "Static class to query information about the system"
#
# \description{
# @classhierarchy
#
# The System class contains several useful class fields and methods. It
# cannot be instantiated.
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#*/###########################################################################
setConstructorS3("System", function() {
extend(Object(), "System")
})
########################################################################/**
# @RdocMethod getHostname
#
# @title "Retrieves the computer name of the current host"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \value{
# Returns a @character string.
# }
#
# \details{
# First, this function checks the system environment variables \code{HOST},
# \code{HOSTNAME}, and \code{COMPUTERNAME}.
# Second, it checks \code{Sys.info()["nodename"]} for host name details.
# Finally, it tries to query the system command \code{uname -n}.
# }
#
# \seealso{
# @seemethod "getUsername".
# }
#**/#######################################################################
setMethodS3("getHostname", "System", function(static, ...) {
host <- Sys.getenv(c("HOST", "HOSTNAME", "COMPUTERNAME"))
host <- host[host != ""]
if (length(host) == 0) {
# Sys.info() is not implemented on all machines, if not it returns NULL,
# which the below code will handle properly.
host <- Sys.info()["nodename"]
host <- host[host != ""]
if (length(host) == 0) {
host <- readLines(pipe("/usr/bin/env uname -n"))
}
}
host[1]
}, static=TRUE)
########################################################################/**
# @RdocMethod getUsername
#
# @title "Retrieves the name of the user running R"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \value{
# Returns a @character string.
# }
#
# \details{
# First, this function checks the system environment variables \code{USER},
# and \code{USERNAME}.
# Second, it checks \code{Sys.info()["user"]} for user name details.
# Finally, it tries to query the system command \code{whoami}.
# }
#
# \seealso{
# @seemethod "getHostname".
# }
#**/#######################################################################
setMethodS3("getUsername", "System", function(static, ...) {
user <- Sys.getenv(c("USER", "USERNAME"))
user <- user[user != ""]
if (length(user) == 0) {
# Sys.info() is not implemented on all machines, if not it returns NULL,
# which the below code will handle properly.
user <- Sys.info()["user"]
user <- user[user != "" & user != "unknown"]
if (length(user) == 0) {
user <- readLines(pipe("/usr/bin/env whoami"))
}
}
user[1]
}, static=TRUE)
###########################################################################/**
# @RdocMethod currentTimeMillis
#
# @title "Get the current time in milliseconds"
#
# @synopsis
#
# \description{
# @get "title".
# }
#
# \value{
# Returns an @integer.
# }
#
# @author
#
# \seealso{
# @see "base::Sys.time".
# @see "base::proc.time".
# @seeclass
# }
#*/###########################################################################
setMethodS3("currentTimeMillis", "System", function(this, ...) {
secs <- as.numeric(Sys.time())
times <- proc.time()
time <- times[2]; # System CPU time
# CPU time is not available on Win 98/Me
if (is.na(time))
time <- times[3]; # Total elapsed times
(secs + time %% 1)*1000
}, static=TRUE)
###########################################################################/**
# @RdocMethod parseDebian
#
# @title "Parses a string, file or connection for Debian formatted parameters"
#
# @synopsis
#
# \arguments{
# \item{text}{The text to be parsed. Default value is @NULL.}
# \item{file}{Name file, a \code{File} object or connection to be parsed.
# Default value is @NULL.}
# \item{keys}{The keys (names of the parameters) to be retrieved.
# If @NULL all fields are returned. Default value is @NULL.}
#
# Either, \code{text} or \code{file} must be given.
# }
#
# \description{
# Parses a text, file or a connection for Debian formatted parameters.
# A file in Debian format contains rows with parameters of the form
# \code{KEY=VALUE}. It is allowed to have duplicated keys.
# }
#
# \value{
# Returns a named @list of parameter values.
# }
#
# \examples{
# file <- file.path(Package("R.utils")$path, "DESCRIPTION")
# l <- System$parseDebian(file=file)
# print(l)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("parseDebian", "System", function(this, text=NULL, file=NULL, keys=NULL, ...) {
if (is.null(text) && is.null(file))
throw("Either argument text or argument file must be specified.")
# Retrieve the text to be parsed.
if (is.null(text)) {
file <- as.character(file)
text <- scan(file=file, what="", sep="\n", quiet=TRUE)
text <- paste(text, "", sep="")
} else {
text <- unlist(text)
text <- strsplit(text, "\n")
text <- unlist(text)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Get the keys (names) and values of the parameters
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
nbrOfLines <- length(text)
keyMatches <- regexpr("^[^:]*:", text)
keyLines <- which(keyMatches == 1)
keyLengths <- attr(keyMatches, "match.length")[keyLines]-1
pkeys <- substring(text[keyLines], 1, keyLengths)
text[keyLines] <- substring(text[keyLines], keyLengths+2)
valueNbrOfLines <- c(keyLines, 0) - c(0, keyLines)
valueNbrOfLines <- valueNbrOfLines[-length(valueNbrOfLines)]
valueNbrOfLines <- valueNbrOfLines[-1]
len <- length(valueNbrOfLines)
valueNbrOfLines[len+1] <- keyLines[len+1]-length(text)+1
values <- c()
for (k in 1:length(keyLines)) {
valueLines <- keyLines[k] + 1:valueNbrOfLines[k] - 1
value <- paste(text[valueLines], sep="", collapse="\n")
values <- c(values, value)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Some cleanup of values
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# 1. Replace all '\r' with '\n'.
values <- gsub("\r", "\n", values)
# 2. At the end of each line, remove all whitespaces and add a space.
values <- gsub("[ \t]*\n", " \n", values)
# 3. At the beginning of each line, remove all whitespaces.
values <- gsub("\n[ \t]*", "\n", values)
# 4. Replace all lines that contains a single '.' with '\r'.
values <- gsub("\n[.] \n", "\n\r\n", values)
values <- gsub("\n[.] \n", "\n\r\n", values); # since we miss every second!
# 4. Remove all '\n'.
values <- gsub("\n", "", values)
# 1. Replace all '\r' with '\n' (single '.' lines).
values <- gsub("\r", "\n", values)
# 4. Removes prefix whitespaces
values <- gsub("^[ \t]", "", values)
# 5. Removes suffix whitespaces
# For some reason, the gsub below crashes once in a while, i.e. once every
# 20:th time. Strange! But, I think I tracked it down to happen when one
# of the strings in values has zero length. So, by making all zero length
# strings equal to " " the gsub call won't crash. I think! /hb 2001-05-11
values[nchar(values) == 0] <- " "
values <- gsub("[ \t]*$", "", values)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Return the wanted parameters
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (is.null(keys)) {
parameters <- as.list(values)
names(parameters) <- pkeys
} else {
idx <- na.omit(match(keys, pkeys))
parameters <- as.list(values[idx])
names(parameters) <- pkeys[idx]
}
parameters
}, static=TRUE)
###########################################################################/**
# @RdocMethod openBrowser
#
# @title "Opens an HTML document using the OS default HTML browser"
#
# @synopsis
#
# \arguments{
# \item{query}{The path to document to be opened by the browser.}
# }
#
# \description{
# @get "title". Note that this
# call is dependent on the operating system (currently only Windows and
# Unix are supported).
# The document given by \code{query} can either be a local file or a
# web page. If the \code{query} was given as non-url string, i.e. as a
# standard file pathname, the method will automatically check if the
# file exists and conform the query to a correct url starting with
# \code{file:}. The used url will be returned as a string.
#
# Any suggestion how implement this on Apple system are welcome!
# }
#
# \value{
# Returns the url of the \code{query}.
# }
#
# \details{
# It is hard to create a good cross-platform \code{openBrowser()} method,
# but here is one try.
#
# In the following text \code{<browser>} is the value returned by
# \code{getOption("browser")} and \code{<url>} is the URL conformed
# query, which starts with either \code{file:} or \code{http:}.
#
# On a \emph{Windows} system, if \code{<browser>} is not @NULL,
# first
#
# \code{shell.exec(<browser> <url>)}
#
# is tried. If this fails, then
#
# \code{shell.exec(<url>)}
#
# is tried. Using this latter approach will \emph{not} guarantee that
# an HTML browser will open the url, e.g. depending on the Windows file
# associations, a \code{*.txt} file might be opened by NotePad. However,
# it will most likely open something.
# If \code{<browser>} contains spaces, make sure it is quoted.
#
# On \emph{Unix} systems, \code{system()} will be used to call:
#
# \code{ <browser> -remote "openURL(<url>)" 2> /dev/null || <browser> <url> &}
#
# }
#
# \examples{\dontrun{
# System$openBrowser("https://www.r-project.org/")
# }}
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("openBrowser", "System", function(this, query, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
startsWith <- function(prefix, s, ...) {
res <- regexpr(paste("^", prefix, sep=""), as.character(s))
(res[[1]] != -1)
}
endsWith <- function(suffix, s, ...) {
res <- regexpr(paste(suffix, "$", sep=""), as.character(s))
(res[[1]] != -1)
}
url <- as.character(query)
if (regexpr("^[abcdefghijklmnopqrstuvwxyz]+:", url) == -1) {
# Assume we are dealing with a file
file <- filePath(url)
if (!file.exists(file))
throw("File not found: ", file)
url <- toUrl(file)
}
browser <- getOption("browser")
if (!is.null(browser)) {
# Check if 'browser' contains spaces, but the user forgot to quote it.
if (regexpr(" ", browser) != -1) {
if (regexpr("^\"", browser) == -1 || regexpr("\"$", browser) == -1) {
browser <- paste("\"", browser, "\"", sep="")
msg <- paste("getOption(\"browser\") contains spaces, but it is not quoted:", browser)
warning(msg)
}
}
}
OST <- .Platform$OS.type
# ---------------------------------------------------------------------
# W i n d o w s
# ---------------------------------------------------------------------
if (OST == "windows") {
first <- 1
tmp <- tolower(url)
if (is.null(browser) &&
!startsWith(tmp, "http:") && !startsWith(tmp, "file:") &&
!endsWith(tmp, ".html") && !endsWith(tmp, ".htm")) {
first <- 2
msg <- paste("The extension of the URL might not be opened in a HTML browser on your Windows system: ", url, sep="")
warning(msg)
}
if (first == 1) {
# 1. Try to call <url>
shell.exec(url)
} else {
# 2a. Try to call <browser> <url>
loaded <- FALSE
if (!is.null(browser)) {
# 2a.i.
cmd <- paste(browser, url)
res <- system(cmd, wait=FALSE)
loaded <- (res == 0)
if (!loaded) {
# 2a.ii. Check if "start" exists, because that might help us
start <- "start /minimized"
tryCatch({
system(start, intern=TRUE)
}, error = function(ex) {
start <<- NULL
})
cmd <- paste(start, browser, url)
res <- system(cmd, wait=FALSE)
loaded <- (res == 0)
}
if (!loaded) {
warning("Could not find the browser specified in options(). Please make sure it is specified with the absolute path *and* if it contains spaces, it has to be quoted.")
}
}
# 2b. Try to call <url>
if (!loaded)
shell.exec(url)
}
}
# ---------------------------------------------------------------------
# U n i x
# ---------------------------------------------------------------------
else if (OST == "unix") {
if (is.null(browser))
throw("options(\"browser\") not set.")
# 1. Try to call <browser> -remote "openURL(<url>)", which opens the
# document in an already existing browser.
cmd1 <- paste(browser, " -remote \"openURL(", url, ")\" 2>/dev/null", sep="")
# 2. Try to call <browser> <url>, which opens the document in a new
# browser.
cmd2 <- paste(browser, url)
# If 1 fails, try 2.
cmd <- paste(cmd1, "||", cmd2)
system(cmd)
} else {
throw("Don't know how to open the browser on", OST)
}
# Return the url, which was tried to be opened.
invisible(url)
}, static=TRUE)
#########################################################################/**
# @RdocMethod findGhostscript
#
# @title "Searches for a Ghostview executable on the current system"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{updateRGSCMD}{If @TRUE and Ghostscript is found, then the system
# environment variable @see "base::R_GSCMD" is set to the (first) path
# found.}
# \item{firstOnly}{If @TRUE, only the first executable is returned.}
# \item{force}{If @TRUE, existing @see "base::R_GSCMD" is ignored,
# otherwise not.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns a @character @vector of full and normalized pathnames
# where Ghostscript executables are found.
# }
#
# \examples{\dontrun{
# print(System$findGhostscript())
# }}
#
# @author
#
# \references{
# [1] \emph{How to use Ghostscript}, Ghostscript, 2022
# \url{https://ghostscript.com/docs/9.55.0/Use.htm}\cr
# [2] \emph{Environment variable}, Wikipedia, 2013.
# \url{https://en.wikipedia.org/wiki/Environment_variable}\cr
# [3] \emph{Environment.SpecialFolder Enumeration},
# Microsoft, 2013.
# \url{https://docs.microsoft.com/en-us/dotnet/api/system.environment.specialfolder}\cr
# }
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("findGhostscript", "System", function(static, updateRGSCMD=TRUE, firstOnly=TRUE, force=FALSE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
isFileX <- function(pathname, ...) {
if (length(pathname) == 0L) return(logical(0L))
(nchar(pathname, type="chars") > 0L) & sapply(pathname, FUN=isFile)
} # isFileX()
isDirectoryX <- function(path, ...) {
if (length(path) == 0L) return(logical(0L))
(nchar(path, type="chars") > 0L) & sapply(path, FUN=isDirectory)
} # isDirectoryX()
findGSBySysEnv <- function(names=c("R_GSCMD"), ...) {
pathnames <- Sys.getenv(names, "")
pathnames <- pathnames[isFileX(pathnames)]
pathnames
} # findGSBySysEnv()
findGSByWhich <- function(names=c("gswin64c", "gswin32c", "gs"), ...) {
pathnames <- Sys.which(names)
pathnames <- pathnames[isFileX(pathnames)]
pathnames
} # findGSByWhich()
findGSOnWindows <- function(patterns=c("^gswin64c.exe$", "^gswin32c.exe$"), ...) {
# (a) Look in "Program Files" directories
paths <- Sys.getenv(c("ProgramFiles(X86)", "ProgramFiles", "Programs"))
# (b) Look also in C:\ and %SystemDrive%
paths <- c(paths, "C:", Sys.getenv("SystemDrive"))
# (c) Drop non-existing directories
paths <- unique(paths)
paths <- paths[isDirectoryX(paths)]
if (length(paths) == 0L) return(NULL)
# Assume Ghostscript is installed under <path>\gs\
paths <- file.path(paths, "gs")
paths <- paths[isDirectoryX(paths)]
if (length(paths) == 0L) return(NULL)
# Now search each of the directories for Ghostscript executables
pathnames <- NULL
for (pattern in patterns) {
for (path in paths) {
pathnamesT <- list.files(pattern=pattern, ignore.case=TRUE,
path=path, recursive=TRUE, full.names=TRUE)
pathnamesT <- pathnamesT[isFileX(pathnamesT)]
pathnames <- c(pathnames, pathnamesT)
} # for (path ...)
} # for (pattern ...)
pathnames
} # findGSOnWindows()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Check environment variable 'R_GSCMD'
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
pathnames <- findGSBySysEnv("R_GSCMD")
if (!force && firstOnly && length(pathnames) > 0L) {
return(pathnames[1L])
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Search for Ghostscript
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
OST <- .Platform$OS.type
if (OST == "windows") {
# (1) Check environment variable 'GSC'
pathnames <- findGSBySysEnv("GSC")
# (2) Search executable on the system PATH
pathnames <- c(pathnames, findGSByWhich(c("gswin64c", "gswin32c")))
# (3) Search known Windows locations
pathnames <- c(pathnames, findGSOnWindows())
} else {
# Search executable on the system PATH
pathnames <- c(pathnames, findGSByWhich("gs"))
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Found Ghostscript?
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Cleanup and normalize paths
if (length(pathnames) > 0L) {
pathnames <- unique(pathnames)
pathnames <- normalizePath(pathnames)
}
# Return only first one found?
if (firstOnly && length(pathnames) > 0L) {
pathnames <- pathnames[1L]
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Update environment variable R_GSCMD?
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (updateRGSCMD) {
if (length(pathnames) > 0L) {
pathnameT <- pathnames[1L]
if (OST == "windows" && exists("shortPathName", mode="function")) {
# To please R CMD check
shortPathName <- NULL; rm(list="shortPathName")
pathnameT <- shortPathName(pathnameT)
}
Sys.setenv("R_GSCMD"=pathnameT)
} else {
warning("R_GSCMD not set, because Ghostscript was not found.")
}
}
pathnames
}, static=TRUE)
#########################################################################/**
# @RdocMethod findGraphicsDevice
#
# @title "Searches for a working PNG device"
#
# \description{
# @get "title".
#
# On Unix, the png device requires that X11 is available, which it is not
# when running batch scripts or running \R remotely. In such cases, an
# alternative is to use the \code{bitmap()} device, which generates an
# EPS file and the uses Ghostscript to transform it to a PNG file.
#
# Moreover, if identical looking bitmap and vector graphics (EPS) files
# are wanted for the same figures, in practice, \code{bitmap()} has
# to be used.
#
# By default, this method tests a list of potential graphical devices and
# returns the first that successfully creates an image file.
# By default, it tries to create a PNG image file via the built-in
# \code{png()} device.
# }
#
# @synopsis
#
# \arguments{
# \item{devices}{A @list of graphics device driver @functions to be
# tested.}
# \item{maxCount}{The maximum number of subsequent tests for the
# the existences of \code{bitmap()} generated image files.}
# \item{sleepInterval}{The time in seconds between above subsequent
# tests.}
# \item{findGhostscript}{If @TRUE, Ghostscript, which is needed by
# the \code{bitmap()} device, is searched for on the current system.
# If found, its location is recorded.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @function that generates images, or @NULL.
# }
#
# @author
#
# \examples{
# fcn <- System$findGraphicsDevice()
# if (identical(fcn, png)) {
# cat("PNG device found: png()")
# } else if (identical(fcn, bitmap)) {
# cat("PNG device found: bitmap()")
# } else {
# cat("PNG device not found.")
# }
# }
#
# \seealso{
# For supported graphical devices, see @see "capabilities".
# @see "grDevices::png",
# \code{bitmap()} and @see "grDevices::dev2bitmap".
# @seemethod "findGhostscript".
# @seeclass
# }
#
# @keyword device
#*/#########################################################################
setMethodS3("findGraphicsDevice", "System", function(static, devices=list(png), maxCount=100, sleepInterval=0.1, findGhostscript=TRUE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'devices':
devices <- as.list(devices)
for (device in devices) {
if (!is.function(device)) {
throw("Argument 'devices' specifies a non-function element: ",
mode(device))
}
}
# Argument 'maxCount':
maxCount <- Arguments$getInteger(maxCount, range=c(1,Inf))
# Argument 'sleepInterval':
sleepInterval <- Arguments$getDouble(sleepInterval, range=c(0,60))
# Argument 'findGhostscript':
findGhostscript <- Arguments$getLogical(findGhostscript)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Check for a valid ghostscript installation
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (findGhostscript)
System$findGhostscript()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Temporary output file for testing
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
file <- tempfile("findGraphicsDevice-testFile")
on.exit({
if (file.exists(file)) {
file.remove(file)
}
})
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Find the first functional device
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
for (device in devices) {
# Check capabilities
if (identical(device, png)) {
if (!capabilities("png"))
next
}
if (identical(device, jpeg)) {
if (!capabilities("jpeg"))
next
}
tryCatch({
device(file)
plot(0)
dev.off()
# The following wait-and-poll code is typically only necessary for
# the bitmap() device since it calls Ghostscript, which is called
# without waiting for it to finish. The default is to poll for the
# dummy image file for 10 seconds in intervals of 0.1 seconds.
# If not found by then, the device is considered not to be found.
# Hopefully, this is never the case.
count <- 0L
while (count < maxCount) {
if (file.exists(file)) {
size <- file.info2(file)$size
if (!is.na(size) && size > 0L) {
return(device)
}
}
Sys.sleep(sleepInterval)
count <- count + 1L
}
}, error = function(error) {
})
} # for (device in ...)
NULL
}, static=TRUE)
setMethodS3("mapDriveOnWindows", "System", function(static, drive, path=getwd(), ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
isWindowsUncPath <- function(path, ...) {
(regexpr("^(//|\\\\)", path) != -1L)
} # isWindowsUncPath()
getWindowsDrivePattern <- function(fmtstr, ...) {
# Windows drive letters
drives <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
# Support also lower case
drives <- paste(c(drives, tolower(drives)), collapse="")
sprintf(fmtstr, drives)
} # getWindowsDrivePattern()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'drive':
drive <- Arguments$getCharacter(drive, length=c(1L,1L), nchar=2L)
pattern <- getWindowsDrivePattern("[%s]:")
if (regexpr(pattern, toupper(drive)) == -1L) {
drive0 <- drive
# Add a colon, in case user forgot
drive <- sprintf("%s:", drive)
if (regexpr(pattern, toupper(drive)) == -1L) {
throw("Argument 'drive' is not a valid drive (e.g. 'Y:'): ", drive0)
}
}
# Argument 'path':
if (isWindowsUncPath(path)) {
path <- gsub("\\", "/", path, fixed=TRUE)
# Network drives cannot have trailing slashes
path <- gsub("[/\\\\]*$", "", path)
} else {
path <- Arguments$getReadablePath(path, mustExist=TRUE)
}
# New path, if successful
newPath <- sprintf("%s/", drive)
# Already mapped?
mapped <- System$getMappedDrivesOnWindows()
mappedTo <- mapped[drive]
if (!is.na(mappedTo)) {
if (!isWindowsUncPath(path)) {
mappedTo <- Arguments$getReadablePath(mappedTo)
}
if (path != mappedTo) {
throw(sprintf("Drive letter %s is already mapped to another path ('%s'), which is different from the requested one: %s", drive, mappedTo, path))
}
# If mapped to the same path, nothing to do
return(invisible(newPath))
}
# UNC paths should be mapped by 'net',
# cf. http://support.microsoft.com/kb/218740
if (isWindowsUncPath(path)) {
# Map using 'net use', which:
# (i) only recognized backslashes
pathT <- gsub("/", "\\", path, fixed=TRUE)
cmd <- sprintf("net use %s \"%s\"", toupper(drive), pathT)
res <- system(cmd, intern=FALSE)
if (res != 0L) {
res <- "???"
throw(sprintf("Failed to map drive '%s' to path '%s': %s (using '%s')",
drive, path, res, cmd))
}
} else {
# Map using 'subst'
cmd <- sprintf("subst %s \"%s\"", toupper(drive), path)
res <- system(cmd, intern=TRUE)
if (length(res) > 0L) {
throw(sprintf("Failed to map drive '%s' to path '%s': %s (using '%s')",
drive, path, res, cmd))
}
}
# Return new path
invisible(newPath)
}, static=TRUE)
setMethodS3("unmapDriveOnWindows", "System", function(static, drive, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
isWindowsUncPath <- function(path, ...) {
(regexpr("^(//|\\\\)", path) != -1L)
} # isWindowsUncPath()
getWindowsDrivePattern <- function(fmtstr, ...) {
# Windows drive letters
drives <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
# Support also lower case
drives <- paste(c(drives, tolower(drives)), collapse="")
sprintf(fmtstr, drives)
} # getWindowsDrivePattern()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'drive':
drive <- Arguments$getCharacter(drive, length=c(1L,1L), nchar=2L)
pattern <- getWindowsDrivePattern("[%s]:")
if (regexpr(pattern, toupper(drive)) == -1L) {
drive0 <- drive
# Add a colon, in case user forgot
drive <- sprintf("%s:", drive)
if (regexpr(pattern, toupper(drive)) == -1L) {
throw("Argument 'drive' is not a valid drive (e.g. 'Y:'): ", drive)
}
}
# Get old paths
maps <- getMappedDrivesOnWindows(static)
oldPath <- maps[toupper(drive)]
if (is.na(oldPath)) {
return(invisible(NULL))
}
# Unmap
if (isWindowsUncPath(oldPath)) {
# Unmap using 'net use'
cmd <- sprintf("net use /delete \"%s\"", toupper(drive))
res <- system(cmd, intern=FALSE)
if (res != 0L) {
res <- "???"
throw(sprintf("Failed to unmap drive '%s': %s (using '%s')",
drive, res, cmd))
}
} else {
# Unmap using 'subst'
cmd <- sprintf("subst \"%s\" /D", toupper(drive))
res <- system(cmd, intern=TRUE)
if (length(res) > 0L) {
throw(sprintf("Failed to unmap drive '%s': %s (using '%s')",
drive, res, cmd))
}
}
# Return old path
invisible(oldPath)
}, static=TRUE)
setMethodS3("getMappedDrivesOnWindows", "System", function(static, ...) {
# (1) By 'subst'
mounts <- system("subst", intern=TRUE)
pattern <- "^(.:).*[ ]*=>[ ]*(.*)[ ]*"
drives <- gsub(pattern, "\\1", mounts)
paths <- gsub(pattern, "\\2", mounts)
paths <- trim(paths)
names(paths) <- drives
paths1 <- paths
# (1) By 'net use'
mounts <- system("net use", intern=TRUE)
pattern <- "^(.*)[ ]+(.:)[ ]+(.*)[ ]+(.*)$"
mounts <- grep(pattern, mounts, value=TRUE)
drives <- gsub(pattern, "\\2", mounts)
paths <- gsub(pattern, "\\3", mounts)
paths <- trim(paths)
names(paths) <- drives
paths2 <- paths
paths <- c(paths1, paths2)
# Standardize
paths <- gsub("\\", "/", paths, fixed=TRUE)
# Order by drive letters
if (length(paths) > 1L) {
o <- order(names(paths))
paths <- paths[o]
}
paths
}, static=TRUE)
Try the R.utils package in your browser
Any scripts or data that you put into this service are public.
R.utils documentation built on Nov. 18, 2023, 1:09 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
###########################################################################/**
# @RdocClass System
#
# @title "Static class to query information about the system"
#
# \description{
# @classhierarchy
#
# The System class contains several useful class fields and methods. It
# cannot be instantiated.
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#*/###########################################################################
setConstructorS3("System", function() {
extend(Object(), "System")
})
########################################################################/**
# @RdocMethod getHostname
#
# @title "Retrieves the computer name of the current host"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \value{
# Returns a @character string.
# }
#
# \details{
# First, this function checks the system environment variables \code{HOST},
# \code{HOSTNAME}, and \code{COMPUTERNAME}.
# Second, it checks \code{Sys.info()["nodename"]} for host name details.
# Finally, it tries to query the system command \code{uname -n}.
# }
#
# \seealso{
# @seemethod "getUsername".
# }
#**/#######################################################################
setMethodS3("getHostname", "System", function(static, ...) {
host <- Sys.getenv(c("HOST", "HOSTNAME", "COMPUTERNAME"))
host <- host[host != ""]
if (length(host) == 0) {
# Sys.info() is not implemented on all machines, if not it returns NULL,
# which the below code will handle properly.
host <- Sys.info()["nodename"]
host <- host[host != ""]
if (length(host) == 0) {
host <- readLines(pipe("/usr/bin/env uname -n"))
}
}
host[1]
}, static=TRUE)
########################################################################/**
# @RdocMethod getUsername
#
# @title "Retrieves the name of the user running R"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \value{
# Returns a @character string.
# }
#
# \details{
# First, this function checks the system environment variables \code{USER},
# and \code{USERNAME}.
# Second, it checks \code{Sys.info()["user"]} for user name details.
# Finally, it tries to query the system command \code{whoami}.
# }
#
# \seealso{
# @seemethod "getHostname".
# }
#**/#######################################################################
setMethodS3("getUsername", "System", function(static, ...) {
user <- Sys.getenv(c("USER", "USERNAME"))
user <- user[user != ""]
if (length(user) == 0) {
# Sys.info() is not implemented on all machines, if not it returns NULL,
# which the below code will handle properly.
user <- Sys.info()["user"]
user <- user[user != "" & user != "unknown"]
if (length(user) == 0) {
user <- readLines(pipe("/usr/bin/env whoami"))
}
}
user[1]
}, static=TRUE)
###########################################################################/**
# @RdocMethod currentTimeMillis
#
# @title "Get the current time in milliseconds"
#
# @synopsis
#
# \description{
# @get "title".
# }
#
# \value{
# Returns an @integer.
# }
#
# @author
#
# \seealso{
# @see "base::Sys.time".
# @see "base::proc.time".
# @seeclass
# }
#*/###########################################################################
setMethodS3("currentTimeMillis", "System", function(this, ...) {
secs <- as.numeric(Sys.time())
times <- proc.time()
time <- times[2]; # System CPU time
# CPU time is not available on Win 98/Me
if (is.na(time))
time <- times[3]; # Total elapsed times
(secs + time %% 1)*1000
}, static=TRUE)
###########################################################################/**
# @RdocMethod parseDebian
#
# @title "Parses a string, file or connection for Debian formatted parameters"
#
# @synopsis
#
# \arguments{
# \item{text}{The text to be parsed. Default value is @NULL.}
# \item{file}{Name file, a \code{File} object or connection to be parsed.
# Default value is @NULL.}
# \item{keys}{The keys (names of the parameters) to be retrieved.
# If @NULL all fields are returned. Default value is @NULL.}
#
# Either, \code{text} or \code{file} must be given.
# }
#
# \description{
# Parses a text, file or a connection for Debian formatted parameters.
# A file in Debian format contains rows with parameters of the form
# \code{KEY=VALUE}. It is allowed to have duplicated keys.
# }
#
# \value{
# Returns a named @list of parameter values.
# }
#
# \examples{
# file <- file.path(Package("R.utils")$path, "DESCRIPTION")
# l <- System$parseDebian(file=file)
# print(l)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("parseDebian", "System", function(this, text=NULL, file=NULL, keys=NULL, ...) {
if (is.null(text) && is.null(file))
throw("Either argument text or argument file must be specified.")
# Retrieve the text to be parsed.
if (is.null(text)) {
file <- as.character(file)
text <- scan(file=file, what="", sep="\n", quiet=TRUE)
text <- paste(text, "", sep="")
} else {
text <- unlist(text)
text <- strsplit(text, "\n")
text <- unlist(text)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Get the keys (names) and values of the parameters
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
nbrOfLines <- length(text)
keyMatches <- regexpr("^[^:]*:", text)
keyLines <- which(keyMatches == 1)
keyLengths <- attr(keyMatches, "match.length")[keyLines]-1
pkeys <- substring(text[keyLines], 1, keyLengths)
text[keyLines] <- substring(text[keyLines], keyLengths+2)
valueNbrOfLines <- c(keyLines, 0) - c(0, keyLines)
valueNbrOfLines <- valueNbrOfLines[-length(valueNbrOfLines)]
valueNbrOfLines <- valueNbrOfLines[-1]
len <- length(valueNbrOfLines)
valueNbrOfLines[len+1] <- keyLines[len+1]-length(text)+1
values <- c()
for (k in 1:length(keyLines)) {
valueLines <- keyLines[k] + 1:valueNbrOfLines[k] - 1
value <- paste(text[valueLines], sep="", collapse="\n")
values <- c(values, value)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Some cleanup of values
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# 1. Replace all '\r' with '\n'.
values <- gsub("\r", "\n", values)
# 2. At the end of each line, remove all whitespaces and add a space.
values <- gsub("[ \t]*\n", " \n", values)
# 3. At the beginning of each line, remove all whitespaces.
values <- gsub("\n[ \t]*", "\n", values)
# 4. Replace all lines that contains a single '.' with '\r'.
values <- gsub("\n[.] \n", "\n\r\n", values)
values <- gsub("\n[.] \n", "\n\r\n", values); # since we miss every second!
# 4. Remove all '\n'.
values <- gsub("\n", "", values)
# 1. Replace all '\r' with '\n' (single '.' lines).
values <- gsub("\r", "\n", values)
# 4. Removes prefix whitespaces
values <- gsub("^[ \t]", "", values)
# 5. Removes suffix whitespaces
# For some reason, the gsub below crashes once in a while, i.e. once every
# 20:th time. Strange! But, I think I tracked it down to happen when one
# of the strings in values has zero length. So, by making all zero length
# strings equal to " " the gsub call won't crash. I think! /hb 2001-05-11
values[nchar(values) == 0] <- " "
values <- gsub("[ \t]*$", "", values)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Return the wanted parameters
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (is.null(keys)) {
parameters <- as.list(values)
names(parameters) <- pkeys
} else {
idx <- na.omit(match(keys, pkeys))
parameters <- as.list(values[idx])
names(parameters) <- pkeys[idx]
}
parameters
}, static=TRUE)
###########################################################################/**
# @RdocMethod openBrowser
#
# @title "Opens an HTML document using the OS default HTML browser"
#
# @synopsis
#
# \arguments{
# \item{query}{The path to document to be opened by the browser.}
# }
#
# \description{
# @get "title". Note that this
# call is dependent on the operating system (currently only Windows and
# Unix are supported).
# The document given by \code{query} can either be a local file or a
# web page. If the \code{query} was given as non-url string, i.e. as a
# standard file pathname, the method will automatically check if the
# file exists and conform the query to a correct url starting with
# \code{file:}. The used url will be returned as a string.
#
# Any suggestion how implement this on Apple system are welcome!
# }
#
# \value{
# Returns the url of the \code{query}.
# }
#
# \details{
# It is hard to create a good cross-platform \code{openBrowser()} method,
# but here is one try.
#
# In the following text \code{<browser>} is the value returned by
# \code{getOption("browser")} and \code{<url>} is the URL conformed
# query, which starts with either \code{file:} or \code{http:}.
#
# On a \emph{Windows} system, if \code{<browser>} is not @NULL,
# first
#
# \code{shell.exec(<browser> <url>)}
#
# is tried. If this fails, then
#
# \code{shell.exec(<url>)}
#
# is tried. Using this latter approach will \emph{not} guarantee that
# an HTML browser will open the url, e.g. depending on the Windows file
# associations, a \code{*.txt} file might be opened by NotePad. However,
# it will most likely open something.
# If \code{<browser>} contains spaces, make sure it is quoted.
#
# On \emph{Unix} systems, \code{system()} will be used to call:
#
# \code{ <browser> -remote "openURL(<url>)" 2> /dev/null || <browser> <url> &}
#
# }
#
# \examples{\dontrun{
# System$openBrowser("https://www.r-project.org/")
# }}
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("openBrowser", "System", function(this, query, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
startsWith <- function(prefix, s, ...) {
res <- regexpr(paste("^", prefix, sep=""), as.character(s))
(res[[1]] != -1)
}
endsWith <- function(suffix, s, ...) {
res <- regexpr(paste(suffix, "$", sep=""), as.character(s))
(res[[1]] != -1)
}
url <- as.character(query)
if (regexpr("^[abcdefghijklmnopqrstuvwxyz]+:", url) == -1) {
# Assume we are dealing with a file
file <- filePath(url)
if (!file.exists(file))
throw("File not found: ", file)
url <- toUrl(file)
}
browser <- getOption("browser")
if (!is.null(browser)) {
# Check if 'browser' contains spaces, but the user forgot to quote it.
if (regexpr(" ", browser) != -1) {
if (regexpr("^\"", browser) == -1 || regexpr("\"$", browser) == -1) {
browser <- paste("\"", browser, "\"", sep="")
msg <- paste("getOption(\"browser\") contains spaces, but it is not quoted:", browser)
warning(msg)
}
}
}
OST <- .Platform$OS.type
# ---------------------------------------------------------------------
# W i n d o w s
# ---------------------------------------------------------------------
if (OST == "windows") {
first <- 1
tmp <- tolower(url)
if (is.null(browser) &&
!startsWith(tmp, "http:") && !startsWith(tmp, "file:") &&
!endsWith(tmp, ".html") && !endsWith(tmp, ".htm")) {
first <- 2
msg <- paste("The extension of the URL might not be opened in a HTML browser on your Windows system: ", url, sep="")
warning(msg)
}
if (first == 1) {
# 1. Try to call <url>
shell.exec(url)
} else {
# 2a. Try to call <browser> <url>
loaded <- FALSE
if (!is.null(browser)) {
# 2a.i.
cmd <- paste(browser, url)
res <- system(cmd, wait=FALSE)
loaded <- (res == 0)
if (!loaded) {
# 2a.ii. Check if "start" exists, because that might help us
start <- "start /minimized"
tryCatch({
system(start, intern=TRUE)
}, error = function(ex) {
start <<- NULL
})
cmd <- paste(start, browser, url)
res <- system(cmd, wait=FALSE)
loaded <- (res == 0)
}
if (!loaded) {
warning("Could not find the browser specified in options(). Please make sure it is specified with the absolute path *and* if it contains spaces, it has to be quoted.")
}
}
# 2b. Try to call <url>
if (!loaded)
shell.exec(url)
}
}
# ---------------------------------------------------------------------
# U n i x
# ---------------------------------------------------------------------
else if (OST == "unix") {
if (is.null(browser))
throw("options(\"browser\") not set.")
# 1. Try to call <browser> -remote "openURL(<url>)", which opens the
# document in an already existing browser.
cmd1 <- paste(browser, " -remote \"openURL(", url, ")\" 2>/dev/null", sep="")
# 2. Try to call <browser> <url>, which opens the document in a new
# browser.
cmd2 <- paste(browser, url)
# If 1 fails, try 2.
cmd <- paste(cmd1, "||", cmd2)
system(cmd)
} else {
throw("Don't know how to open the browser on", OST)
}
# Return the url, which was tried to be opened.
invisible(url)
}, static=TRUE)
#########################################################################/**
# @RdocMethod findGhostscript
#
# @title "Searches for a Ghostview executable on the current system"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{updateRGSCMD}{If @TRUE and Ghostscript is found, then the system
# environment variable @see "base::R_GSCMD" is set to the (first) path
# found.}
# \item{firstOnly}{If @TRUE, only the first executable is returned.}
# \item{force}{If @TRUE, existing @see "base::R_GSCMD" is ignored,
# otherwise not.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns a @character @vector of full and normalized pathnames
# where Ghostscript executables are found.
# }
#
# \examples{\dontrun{
# print(System$findGhostscript())
# }}
#
# @author
#
# \references{
# [1] \emph{How to use Ghostscript}, Ghostscript, 2022
# \url{https://ghostscript.com/docs/9.55.0/Use.htm}\cr
# [2] \emph{Environment variable}, Wikipedia, 2013.
# \url{https://en.wikipedia.org/wiki/Environment_variable}\cr
# [3] \emph{Environment.SpecialFolder Enumeration},
# Microsoft, 2013.
# \url{https://docs.microsoft.com/en-us/dotnet/api/system.environment.specialfolder}\cr
# }
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("findGhostscript", "System", function(static, updateRGSCMD=TRUE, firstOnly=TRUE, force=FALSE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
isFileX <- function(pathname, ...) {
if (length(pathname) == 0L) return(logical(0L))
(nchar(pathname, type="chars") > 0L) & sapply(pathname, FUN=isFile)
} # isFileX()
isDirectoryX <- function(path, ...) {
if (length(path) == 0L) return(logical(0L))
(nchar(path, type="chars") > 0L) & sapply(path, FUN=isDirectory)
} # isDirectoryX()
findGSBySysEnv <- function(names=c("R_GSCMD"), ...) {
pathnames <- Sys.getenv(names, "")
pathnames <- pathnames[isFileX(pathnames)]
pathnames
} # findGSBySysEnv()
findGSByWhich <- function(names=c("gswin64c", "gswin32c", "gs"), ...) {
pathnames <- Sys.which(names)
pathnames <- pathnames[isFileX(pathnames)]
pathnames
} # findGSByWhich()
findGSOnWindows <- function(patterns=c("^gswin64c.exe$", "^gswin32c.exe$"), ...) {
# (a) Look in "Program Files" directories
paths <- Sys.getenv(c("ProgramFiles(X86)", "ProgramFiles", "Programs"))
# (b) Look also in C:\ and %SystemDrive%
paths <- c(paths, "C:", Sys.getenv("SystemDrive"))
# (c) Drop non-existing directories
paths <- unique(paths)
paths <- paths[isDirectoryX(paths)]
if (length(paths) == 0L) return(NULL)
# Assume Ghostscript is installed under <path>\gs\
paths <- file.path(paths, "gs")
paths <- paths[isDirectoryX(paths)]
if (length(paths) == 0L) return(NULL)
# Now search each of the directories for Ghostscript executables
pathnames <- NULL
for (pattern in patterns) {
for (path in paths) {
pathnamesT <- list.files(pattern=pattern, ignore.case=TRUE,
path=path, recursive=TRUE, full.names=TRUE)
pathnamesT <- pathnamesT[isFileX(pathnamesT)]
pathnames <- c(pathnames, pathnamesT)
} # for (path ...)
} # for (pattern ...)
pathnames
} # findGSOnWindows()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Check environment variable 'R_GSCMD'
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
pathnames <- findGSBySysEnv("R_GSCMD")
if (!force && firstOnly && length(pathnames) > 0L) {
return(pathnames[1L])
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Search for Ghostscript
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
OST <- .Platform$OS.type
if (OST == "windows") {
# (1) Check environment variable 'GSC'
pathnames <- findGSBySysEnv("GSC")
# (2) Search executable on the system PATH
pathnames <- c(pathnames, findGSByWhich(c("gswin64c", "gswin32c")))
# (3) Search known Windows locations
pathnames <- c(pathnames, findGSOnWindows())
} else {
# Search executable on the system PATH
pathnames <- c(pathnames, findGSByWhich("gs"))
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Found Ghostscript?
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Cleanup and normalize paths
if (length(pathnames) > 0L) {
pathnames <- unique(pathnames)
pathnames <- normalizePath(pathnames)
}
# Return only first one found?
if (firstOnly && length(pathnames) > 0L) {
pathnames <- pathnames[1L]
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Update environment variable R_GSCMD?
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (updateRGSCMD) {
if (length(pathnames) > 0L) {
pathnameT <- pathnames[1L]
if (OST == "windows" && exists("shortPathName", mode="function")) {
# To please R CMD check
shortPathName <- NULL; rm(list="shortPathName")
pathnameT <- shortPathName(pathnameT)
}
Sys.setenv("R_GSCMD"=pathnameT)
} else {
warning("R_GSCMD not set, because Ghostscript was not found.")
}
}
pathnames
}, static=TRUE)
#########################################################################/**
# @RdocMethod findGraphicsDevice
#
# @title "Searches for a working PNG device"
#
# \description{
# @get "title".
#
# On Unix, the png device requires that X11 is available, which it is not
# when running batch scripts or running \R remotely. In such cases, an
# alternative is to use the \code{bitmap()} device, which generates an
# EPS file and the uses Ghostscript to transform it to a PNG file.
#
# Moreover, if identical looking bitmap and vector graphics (EPS) files
# are wanted for the same figures, in practice, \code{bitmap()} has
# to be used.
#
# By default, this method tests a list of potential graphical devices and
# returns the first that successfully creates an image file.
# By default, it tries to create a PNG image file via the built-in
# \code{png()} device.
# }
#
# @synopsis
#
# \arguments{
# \item{devices}{A @list of graphics device driver @functions to be
# tested.}
# \item{maxCount}{The maximum number of subsequent tests for the
# the existences of \code{bitmap()} generated image files.}
# \item{sleepInterval}{The time in seconds between above subsequent
# tests.}
# \item{findGhostscript}{If @TRUE, Ghostscript, which is needed by
# the \code{bitmap()} device, is searched for on the current system.
# If found, its location is recorded.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @function that generates images, or @NULL.
# }
#
# @author
#
# \examples{
# fcn <- System$findGraphicsDevice()
# if (identical(fcn, png)) {
# cat("PNG device found: png()")
# } else if (identical(fcn, bitmap)) {
# cat("PNG device found: bitmap()")
# } else {
# cat("PNG device not found.")
# }
# }
#
# \seealso{
# For supported graphical devices, see @see "capabilities".
# @see "grDevices::png",
# \code{bitmap()} and @see "grDevices::dev2bitmap".
# @seemethod "findGhostscript".
# @seeclass
# }
#
# @keyword device
#*/#########################################################################
setMethodS3("findGraphicsDevice", "System", function(static, devices=list(png), maxCount=100, sleepInterval=0.1, findGhostscript=TRUE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'devices':
devices <- as.list(devices)
for (device in devices) {
if (!is.function(device)) {
throw("Argument 'devices' specifies a non-function element: ",
mode(device))
}
}
# Argument 'maxCount':
maxCount <- Arguments$getInteger(maxCount, range=c(1,Inf))
# Argument 'sleepInterval':
sleepInterval <- Arguments$getDouble(sleepInterval, range=c(0,60))
# Argument 'findGhostscript':
findGhostscript <- Arguments$getLogical(findGhostscript)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Check for a valid ghostscript installation
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (findGhostscript)
System$findGhostscript()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Temporary output file for testing
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
file <- tempfile("findGraphicsDevice-testFile")
on.exit({
if (file.exists(file)) {
file.remove(file)
}
})
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Find the first functional device
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
for (device in devices) {
# Check capabilities
if (identical(device, png)) {
if (!capabilities("png"))
next
}
if (identical(device, jpeg)) {
if (!capabilities("jpeg"))
next
}
tryCatch({
device(file)
plot(0)
dev.off()
# The following wait-and-poll code is typically only necessary for
# the bitmap() device since it calls Ghostscript, which is called
# without waiting for it to finish. The default is to poll for the
# dummy image file for 10 seconds in intervals of 0.1 seconds.
# If not found by then, the device is considered not to be found.
# Hopefully, this is never the case.
count <- 0L
while (count < maxCount) {
if (file.exists(file)) {
size <- file.info2(file)$size
if (!is.na(size) && size > 0L) {
return(device)
}
}
Sys.sleep(sleepInterval)
count <- count + 1L
}
}, error = function(error) {
})
} # for (device in ...)
NULL
}, static=TRUE)
setMethodS3("mapDriveOnWindows", "System", function(static, drive, path=getwd(), ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
isWindowsUncPath <- function(path, ...) {
(regexpr("^(//|\\\\)", path) != -1L)
} # isWindowsUncPath()
getWindowsDrivePattern <- function(fmtstr, ...) {
# Windows drive letters
drives <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
# Support also lower case
drives <- paste(c(drives, tolower(drives)), collapse="")
sprintf(fmtstr, drives)
} # getWindowsDrivePattern()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'drive':
drive <- Arguments$getCharacter(drive, length=c(1L,1L), nchar=2L)
pattern <- getWindowsDrivePattern("[%s]:")
if (regexpr(pattern, toupper(drive)) == -1L) {
drive0 <- drive
# Add a colon, in case user forgot
drive <- sprintf("%s:", drive)
if (regexpr(pattern, toupper(drive)) == -1L) {
throw("Argument 'drive' is not a valid drive (e.g. 'Y:'): ", drive0)
}
}
# Argument 'path':
if (isWindowsUncPath(path)) {
path <- gsub("\\", "/", path, fixed=TRUE)
# Network drives cannot have trailing slashes
path <- gsub("[/\\\\]*$", "", path)
} else {
path <- Arguments$getReadablePath(path, mustExist=TRUE)
}
# New path, if successful
newPath <- sprintf("%s/", drive)
# Already mapped?
mapped <- System$getMappedDrivesOnWindows()
mappedTo <- mapped[drive]
if (!is.na(mappedTo)) {
if (!isWindowsUncPath(path)) {
mappedTo <- Arguments$getReadablePath(mappedTo)
}
if (path != mappedTo) {
throw(sprintf("Drive letter %s is already mapped to another path ('%s'), which is different from the requested one: %s", drive, mappedTo, path))
}
# If mapped to the same path, nothing to do
return(invisible(newPath))
}
# UNC paths should be mapped by 'net',
# cf. http://support.microsoft.com/kb/218740
if (isWindowsUncPath(path)) {
# Map using 'net use', which:
# (i) only recognized backslashes
pathT <- gsub("/", "\\", path, fixed=TRUE)
cmd <- sprintf("net use %s \"%s\"", toupper(drive), pathT)
res <- system(cmd, intern=FALSE)
if (res != 0L) {
res <- "???"
throw(sprintf("Failed to map drive '%s' to path '%s': %s (using '%s')",
drive, path, res, cmd))
}
} else {
# Map using 'subst'
cmd <- sprintf("subst %s \"%s\"", toupper(drive), path)
res <- system(cmd, intern=TRUE)
if (length(res) > 0L) {
throw(sprintf("Failed to map drive '%s' to path '%s': %s (using '%s')",
drive, path, res, cmd))
}
}
# Return new path
invisible(newPath)
}, static=TRUE)
setMethodS3("unmapDriveOnWindows", "System", function(static, drive, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
isWindowsUncPath <- function(path, ...) {
(regexpr("^(//|\\\\)", path) != -1L)
} # isWindowsUncPath()
getWindowsDrivePattern <- function(fmtstr, ...) {
# Windows drive letters
drives <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
# Support also lower case
drives <- paste(c(drives, tolower(drives)), collapse="")
sprintf(fmtstr, drives)
} # getWindowsDrivePattern()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'drive':
drive <- Arguments$getCharacter(drive, length=c(1L,1L), nchar=2L)
pattern <- getWindowsDrivePattern("[%s]:")
if (regexpr(pattern, toupper(drive)) == -1L) {
drive0 <- drive
# Add a colon, in case user forgot
drive <- sprintf("%s:", drive)
if (regexpr(pattern, toupper(drive)) == -1L) {
throw("Argument 'drive' is not a valid drive (e.g. 'Y:'): ", drive)
}
}
# Get old paths
maps <- getMappedDrivesOnWindows(static)
oldPath <- maps[toupper(drive)]
if (is.na(oldPath)) {
return(invisible(NULL))
}
# Unmap
if (isWindowsUncPath(oldPath)) {
# Unmap using 'net use'
cmd <- sprintf("net use /delete \"%s\"", toupper(drive))
res <- system(cmd, intern=FALSE)
if (res != 0L) {
res <- "???"
throw(sprintf("Failed to unmap drive '%s': %s (using '%s')",
drive, res, cmd))
}
} else {
# Unmap using 'subst'
cmd <- sprintf("subst \"%s\" /D", toupper(drive))
res <- system(cmd, intern=TRUE)
if (length(res) > 0L) {
throw(sprintf("Failed to unmap drive '%s': %s (using '%s')",
drive, res, cmd))
}
}
# Return old path
invisible(oldPath)
}, static=TRUE)
setMethodS3("getMappedDrivesOnWindows", "System", function(static, ...) {
# (1) By 'subst'
mounts <- system("subst", intern=TRUE)
pattern <- "^(.:).*[ ]*=>[ ]*(.*)[ ]*"
drives <- gsub(pattern, "\\1", mounts)
paths <- gsub(pattern, "\\2", mounts)
paths <- trim(paths)
names(paths) <- drives
paths1 <- paths
# (1) By 'net use'
mounts <- system("net use", intern=TRUE)
pattern <- "^(.*)[ ]+(.:)[ ]+(.*)[ ]+(.*)$"
mounts <- grep(pattern, mounts, value=TRUE)
drives <- gsub(pattern, "\\2", mounts)
paths <- gsub(pattern, "\\3", mounts)
paths <- trim(paths)
names(paths) <- drives
paths2 <- paths
paths <- c(paths1, paths2)
# Standardize
paths <- gsub("\\", "/", paths, fixed=TRUE)
# Order by drive letters
if (length(paths) > 1L) {
o <- order(names(paths))
paths <- paths[o]
}
paths
}, static=TRUE)
Try the R.utils package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.