R.utils/ 0000755 0001762 0000144 00000000000 14757161202 011617 5 ustar ligges users R.utils/tests/ 0000755 0001762 0000144 00000000000 14564147542 012770 5 ustar ligges users R.utils/tests/tempvar.R 0000644 0001762 0000144 00000000421 14372747611 014566 0 ustar ligges users library("R.utils")
# Get a temporary variable
name <- tempvar()
print(name)
# Get and assign a temporary variable
name <- tempvar(value=base::letters)
print(name)
str(get(name))
# Get a temporary variable with custom prefix
name <- tempvar(prefix=".hidden")
print(name)
R.utils/tests/capitalize.R 0000644 0001762 0000144 00000002022 14372747611 015234 0 ustar ligges users library("R.utils")
words <- strsplit("Hello wOrld", " ")[[1]]
cat(paste(toupper(words), collapse=" "), "\n") # "HELLO WORLD"
cat(paste(tolower(words), collapse=" "), "\n") # "hello world"
cat(paste(capitalize(words), collapse=" "), "\n") # "Hello WOrld"
cat(paste(decapitalize(words), collapse=" "), "\n") # "hello wOrld"
# Sanity checks
stopifnot(paste(toupper(words), collapse=" ") == "HELLO WORLD")
stopifnot(paste(tolower(words), collapse=" ") == "hello world")
stopifnot(paste(capitalize(words), collapse=" ") == "Hello WOrld")
stopifnot(paste(decapitalize(words), collapse=" ") == "hello wOrld")
# Empty character vector
s <- character(0L)
stopifnot(identical(capitalize(s), s))
stopifnot(identical(decapitalize(s), s))
# Empty string
s <- ""
stopifnot(identical(capitalize(s), s))
stopifnot(identical(decapitalize(s), s))
s <- NA_character_
stopifnot(identical(capitalize(s), s))
stopifnot(identical(decapitalize(s), s))
s <- c(NA_character_, "Hello wOrld")
y <- capitalize(s)
print(y)
y <- decapitalize(s)
print(y)
R.utils/tests/mout.R 0000644 0001762 0000144 00000002527 14372747611 014105 0 ustar ligges users library("R.utils")
show <- methods::show
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# General tests
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
x <- letters[1:8]
x2 <- c(x[-1], "\n")
x3 <- x2[-1]
y <- as.list(x[1:3])
cat("mprint():\n")
print(x)
mprint(x)
print(y)
mprint(y)
cat("mcat():\n")
cat(x, "\n")
mcat(x, "\n")
cat(x2)
mcat(x2)
cat(x3, sep=",")
mcat(x3, sep=",")
cat(x3, sep="\n")
mcat(x3, sep="\n")
cat("mstr():\n")
str(x)
mstr(x)
str(y)
mstr(y)
cat("mshow():\n")
show(x)
mshow(x)
show(y)
mshow(y)
cat("mprintf():\n")
printf("x=%d\n", 1:3)
mprintf("x=%d\n", 1:3)
cat("mout():\n")
writeLines(x)
mout(writeLines(x))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Tests related to closure
# - - - - - - - - - - - -- - - - - - - - - - - - - - - - - -
mfoo <- function(a=1) {
mprintf("a=%s\n", a)
}
mbar <- function(...) {
mfoo(...)
}
a <- 2
mfoo(a)
mfoo(3)
mbar(a)
mbar(3)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Assert that "console" messages can be captured/sunk
# via stderr but not stdout
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
res <- captureOutput({ mcat("Hello") })
str(res)
stopifnot(length(res) == 0L)
withSink({ mcat("Hello") }, file="foo.txt", type="message")
res <- readLines("foo.txt")
str(res)
stopifnot(length(res) > 0L)
R.utils/tests/wrap.array.R 0000644 0001762 0000144 00000006372 14372747611 015211 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# A matrix
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat("\nWrap a matrix 'y' to a vector and back again:\n")
x <- matrix(1:8, nrow=2, dimnames=list(letters[1:2], 1:4))
y <- wrap(x)
z <- unwrap(y)
print(z)
stopifnot(identical(z,x))
# Drop dimensions, iff applicable
z <- unwrap(y, drop=TRUE)
print(z)
# Argument 'split' can also be a list of functions
split <- list(function(names, ...) strsplit(names, split="[.]", ...))
z2 <- unwrap(y, split=split)
print(z2)
stopifnot(identical(z2, z))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# A matrix and a data frame
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
x3 <- matrix(1:27, nrow=3L, ncol=9L)
rownames(x3) <- LETTERS[1:3]
colnames(x3) <- letters[1:9]
x3b <- as.data.frame(x3, stringsAsFactors=FALSE)
y3 <- wrap(x3)
print(y3)
y3b <- wrap(x3b)
print(y3b)
stopifnot(identical(y3b,y3))
z3 <- unwrap(y3)
stopifnot(identical(z3,x3))
y3b <- as.data.frame(y3, stringsAsFactors=FALSE)
z3b <- unwrap(y3b)
stopifnot(identical(z3b,x3))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# A 3x2x3 array
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
dim <- c(3,2,3)
ndim <- length(dim)
dimnames <- list()
for (kk in 1:ndim)
dimnames[[kk]] <- sprintf("%s%d", letters[kk], 1:dim[kk])
x <- 1:prod(dim)
x <- array(x, dim=dim, dimnames=dimnames)
cat("Array 'x':\n")
print(x)
cat("\nReshape 'x' to its identity:\n")
y <- wrap(x, map=list(1, 2, 3))
print(y)
# Assert correctness of reshaping
stopifnot(identical(y, x))
cat("\nReshape 'x' by swapping dimensions 2 and 3, i.e. aperm(x, perm=c(1,3,2)):\n")
y <- wrap(x, map=list(1, 3, 2))
print(y)
# Assert correctness of reshaping
stopifnot(identical(y, aperm(x, perm=c(1,3,2))))
cat("\nWrap 'x' to a matrix 'y' by keeping dimension 1 and joining the others:\n")
y <- wrap(x, map=list(1, NA))
print(y)
# Assert correctness of reshaping
for (aa in dimnames(x)[[1]]) {
for (bb in dimnames(x)[[2]]) {
for (cc in dimnames(x)[[3]]) {
tt <- paste(bb, cc, sep=".")
stopifnot(identical(y[aa,tt], x[aa,bb,cc]))
}
}
}
cat("\nUnwrap matrix 'y' back to array 'x':\n")
z <- unwrap(y)
print(z)
stopifnot(identical(z,x))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# An array with a random number of dimensions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat("\nWrap and unwrap a randomly sized and shaped array 'x2':\n")
maxdim <- 5
dim <- sample(1:maxdim, size=sample(2:maxdim, size=1))
ndim <- length(dim)
dimnames <- list()
for (kk in 1:ndim)
dimnames[[kk]] <- sprintf("%s%d", letters[kk], 1:dim[kk])
x2 <- 1:prod(dim)
x2 <- array(x, dim=dim, dimnames=dimnames)
cat("\nArray 'x2':\n")
print(x)
# Number of dimensions of wrapped array
ndim2 <- sample(1:(ndim-1), size=1)
# Create a random map for joining dimensions
splits <- NULL
if (ndim > 2)
splits <- sort(sample(2:(ndim-1), size=ndim2-1))
splits <- c(0, splits, ndim)
map <- list()
for (kk in 1:ndim2)
map[[kk]] <- (splits[kk]+1):splits[kk+1]
cat("\nRandom 'map':\n")
print(map)
cat("\nArray 'y2':\n")
y2 <- wrap(x2, map=map)
print(y2)
cat("\nArray 'x2':\n")
z2 <- unwrap(y2)
print(z2)
stopifnot(identical(z2,x2))
R.utils/tests/FileProgressBar.R 0000644 0001762 0000144 00000000437 14372747611 016150 0 ustar ligges users library("R.utils")
# Creates a progress bar (of length 100) that displays it self as a file.
pb <- FileProgressBar(file.path(tempdir(), "progress.simulation"))
reset(pb)
while (!isDone(pb)) {
x <- rnorm(3e4)
increase(pb)
# Emulate a slow process
Sys.sleep(0.001)
}
cleanup(pb)
R.utils/tests/isPackageLoaded.R 0000644 0001762 0000144 00000000270 14372747611 016112 0 ustar ligges users library("R.utils")
for (pkg in c("R.utils", "tools", "MASS", "unknown")) {
mprintf("isPackageLoaded('%s'): %s\n", pkg, isPackageLoaded(pkg))
}
isPackageLoaded("R.utils", "1.2.0")
R.utils/tests/compressPDF.R 0000644 0001762 0000144 00000001105 14372747611 015275 0 ustar ligges users library("R.utils")
oopts <- options(warn=1)
message("*** compressPDF() ...")
pathname <- file.path(R.home("doc"), "NEWS.pdf")
if (file_test("-f", pathname)) {
tryCatch({
pathnameZ <- compressPDF(pathname)
print(pathnameZ)
pathnameZ <- compressPDF(pathname, skip=TRUE)
print(pathnameZ)
pathnameZ <- compressPDF(pathname, overwrite=TRUE)
print(pathnameZ)
file.remove(pathnameZ)
removeDirectory(dirname(pathnameZ))
}, error = function(ex) {
warning("TEST ERROR: ", ex$message)
})
}
message("*** compressPDF() ...DONE")
options(oopts)
R.utils/tests/isReplicated.R 0000644 0001762 0000144 00000002305 14372747611 015523 0 ustar ligges users library("R.utils")
x <- c(1,1,2,3,4,2,1)
x <- base::letters[x]
print(x)
# Identify entries with replicated values
reps <- isReplicated(x)
print(x[reps])
stopifnot(x[reps] == replicates(x))
# Identify entries with unique values
print(x[!reps])
stopifnot(x[!reps] == singles(x))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validation
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
x <- c(1,1,2,3,4,2,1)
x <- base::letters[x]
reps <- isReplicated(x)
stopifnot(all(table(x[reps]) > 1))
stopifnot(all(table(x[!reps]) == 1))
stopifnot(all(reps == rev(isReplicated(rev(x)))))
stopifnot(all(reps == duplicated(x) | duplicated(x, fromLast=TRUE)))
stopifnot(all(reps == !is.element(x, setdiff(x, unique(x[duplicated(x)])))))
stopifnot(all(sort(c(singles(x), replicates(x))) == sort(x)))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Benchmarking singles()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
set.seed(0xBEEF)
n <- 1e6
x <- sample(1:(n/2), size=n, replace=TRUE)
t <- system.time({
s <- isSingle(x)
})
print(sum(s))
t0 <- system.time({
s0 <- !(x %in% x[duplicated(x)])
})
print(t/t0)
stopifnot(all(s == s0))
R.utils/tests/NullVerbose.R 0000644 0001762 0000144 00000000225 14372747611 015352 0 ustar ligges users library("R.utils")
verbose <- Verbose()
cat(verbose, "A verbose messages")
verbose <- NullVerbose()
cat(verbose, "A verbose messages") # Ignored
R.utils/tests/Options.R 0000644 0001762 0000144 00000002352 14372747611 014550 0 ustar ligges users library("R.utils")
local <- Options()
print(local)
str(local)
print(names(local))
print(nbrOfOptions(local))
print(getLeaves(local))
# Query a missing option
cex <- getOption(local, "graphics/cex")
cat("graphics/cex =", cex, "\n") # Returns NULL
# Query a missing option with default value
cex <- getOption(local, "graphics/cex", defaultValue=1)
cat("graphics/cex =", cex, "\n") # Returns NULL
# Set option and get previous value
oldCex <- setOption(local, "graphics/cex", 2)
cat("previous graphics/cex =", oldCex, "\n") # Returns NULL
# Set option again and get previous value
oldCex <- setOption(local, "graphics/cex", 3)
cat("previous graphics/cex =", oldCex, "\n") # Returns 2
# Query a missing option with default value, which is ignored
cex <- getOption(local, "graphics/cex", defaultValue=1)
cat("graphics/cex =", cex, "\n") # Returns 3
# Query multiple options with multiple default values
multi <- getOption(local, c("graphics/cex", "graphics/pch"), c(1,2))
print(multi)
# Check existance of multiple options
has <- hasOption(local, c("graphics/cex", "graphics/pch"))
print(has)
# Get a subtree of options
graphics <- getOption(local, "graphics")
print(graphics)
# Get the complete tree of options
all <- getOption(local)
print(all)
R.utils/tests/mpager.R 0000644 0001762 0000144 00000000223 14372747611 014363 0 ustar ligges users library("R.utils")
file <- tempfile()
cat("Hello world!\n", file=file)
mpager(file, header=file, title="Example for mpager()", delete.file=TRUE)
R.utils/tests/writeDataFrame.R 0000644 0001762 0000144 00000001335 14372747611 016014 0 ustar ligges users library("R.utils")
# A data frame
set.seed(42)
n <- 5L
data <- data.frame(
index = 1:n,
symbol = letters[1:n],
x = runif(n),
y = rnorm(n),
stringsAsFactors=FALSE
)
# Write to tab-delimited file (using a connection)
pathname <- tempfile(fileext=".tsv")
con <- file(pathname, open="w")
writeDataFrame(data, file=con, createdBy="R.utils")
close(con)
# Append another set of rows
writeDataFrame(data, file=pathname, append=TRUE)
# There should only be one header and one set of column names
print(readLines(pathname))
# Overwrite using a connection
con <- file(pathname, open="w")
writeDataFrame(data, file=con, overwrite=TRUE)
close(con)
# Overwrite using a filename
writeDataFrame(data, file=pathname, overwrite=TRUE)
R.utils/tests/dataFrame.R 0000644 0001762 0000144 00000000225 14372747611 014776 0 ustar ligges users library("R.utils")
df <- dataFrame(colClasses=c(a="integer", b="double"), nrow=10)
df[,1] <- sample(1:nrow(df))
df[,2] <- rnorm(nrow(df))
print(df)
R.utils/tests/subplots.R 0000644 0001762 0000144 00000000647 14372747611 014775 0 ustar ligges users library("R.utils")
local({
dev.new()
on.exit(dev.off())
subplots(4)
for (kk in 1:4) plot(kk, main=kk)
})
local({
dev.new()
on.exit(dev.off())
subplots(1:4)
for (kk in 1:4) plot(kk, main=kk)
})
local({
dev.new()
on.exit(dev.off())
subplots(4, nrow=2)
for (kk in 1:4) plot(kk, main=kk)
})
local({
dev.new()
on.exit(dev.off())
subplots(nrow=2, ncol=4)
for (kk in 1:4) plot(kk, main=kk)
})
R.utils/tests/splitByPattern.R 0000644 0001762 0000144 00000000235 14372747611 016077 0 ustar ligges users library("R.utils")
rspCode <- "
Hello <%=\"world\"%>"
rspParts <- splitByPattern(rspCode, pattern="<%.*%>")
cat(rspCode, "\n")
print(rspParts)
R.utils/tests/TextStatusBar.R 0000644 0001762 0000144 00000002721 14372747611 015672 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Read all HTML files in the base package
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
path <- system.file(package="base")
files <- list.files(path, recursive=TRUE, full.names=TRUE)
files <- files[sapply(files, FUN=isFile)]
nfiles <- length(files)
cat(sprintf("Reading %d files in %s:\n", nfiles, path))
# Create a status bar with four labels
sb <- TextStatusBar("File: %-*s [%3.0f%% %7.0f bytes %-8s]",
hfill=1, file="", progress=0, nbytes=0L, time="")
nbytes <- 0L
for (kk in seq_len(nfiles)) {
file <- files[kk]
# Update the status bar
if (sb) {
setLabel(sb, "progress", 100*kk/nfiles)
if (kk %% 10 == 1 || kk == nfiles)
setLabel(sb, "file", substr(basename(file), 1, 44))
size <- file.info(file)$size
# popMessage() calls update() too
popMessage(sb, sprintf("Processing %s (%.2fkB)",
basename(file), size/1024))
flush(sb)
}
# Read the file
bfr <- readBin(file, what="raw", n=size)
nbytes <- nbytes + size
# Emulate a slow process
if (interactive()) Sys.sleep(rexp(1, rate=60))
# Update the status bar
if (sb) {
setLabel(sb, "nbytes", nbytes)
setLabel(sb, "time", format(Sys.time(), "%H:%M:%S"))
update(sb)
}
}
setLabel(sb, "file", "")
update(sb)
cat("\n")
## Odds and ends
print(getLabel(sb, "progress"))
print(newline(sb))
updateLabels(sb)
R.utils/tests/pushTemporaryFile.R 0000644 0001762 0000144 00000002005 14372747611 016572 0 ustar ligges users library("R.utils")
createAtomically <- function(pathname, ...) {
cat("Pathname: ", pathname, "\n", sep="")
# Generate a file atomically, i.e. the file will either be
# complete or not created at all. If interrupted while
# writing, only a temporary file will exist/remain.
pathnameT <- pushTemporaryFile(pathname, verbose=TRUE)
cat("Temporary pathname: ", pathnameT, "\n", sep="")
cat(file=pathnameT, "This file was created atomically:\n")
for (kk in 1:10) {
cat(file=pathnameT, kk, "\n", append=TRUE)
# Emulate a slow process
if (interactive()) Sys.sleep(0.1)
}
cat(file=pathnameT, "END OF FILE\n", append=TRUE)
# Rename the temporary file
pathname <- popTemporaryFile(pathnameT, verbose=TRUE)
pathname
} # createAtomically()
pathname <- tempfile()
tryCatch({
# Try to interrupt the process while writing...
pathname <- createAtomically(pathname)
}, interrupt=function(intr) {
str(intr)
})
# ...and this will throw an exception
bfr <- readLines(pathname)
cat(bfr, sep="\n")
R.utils/tests/compressFile.R 0000644 0001762 0000144 00000002765 14372747611 015560 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# bzip2
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat(file="foo.txt", "Hello world!")
print(isBzipped("foo.txt"))
print(isBzipped("foo.txt.bz2"))
bzip2("foo.txt")
print(file.info("foo.txt.bz2"))
print(isBzipped("foo.txt"))
print(isBzipped("foo.txt.bz2"))
bunzip2("foo.txt.bz2")
print(file.info("foo.txt"))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# gzip
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat(file="foo.txt", "Hello world!")
print(isGzipped("foo.txt"))
print(isGzipped("foo.txt.gz"))
gzip("foo.txt")
print(file.info("foo.txt.gz"))
print(isGzipped("foo.txt"))
print(isGzipped("foo.txt.gz"))
gunzip("foo.txt.gz")
print(file.info("foo.txt"))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Skipping and overwriting
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat(file="foo.txt", "Hello world!")
gzip("foo.txt", remove=FALSE)
res <- try(gzip("foo.txt", remove=FALSE, skip=FALSE), silent=TRUE)
stopifnot(inherits(res, "try-error"))
gzip("foo.txt", remove=FALSE, overwrite=TRUE)
gzip("foo.txt", remove=FALSE, skip=TRUE)
res <- try(gzip("foo.txt", remove=FALSE, skip=FALSE), silent=TRUE)
stopifnot(inherits(res, "try-error"))
gunzip("foo.txt.gz", remove=FALSE, overwrite=TRUE)
res <- try(gunzip("foo.txt.gz", remove=FALSE, skip=FALSE), silent=TRUE)
stopifnot(inherits(res, "try-error"))
gunzip("foo.txt.gz", overwrite=TRUE)
## Cleanup
file.remove("foo.txt")
R.utils/tests/Verbose.R 0000644 0001762 0000144 00000003063 14372747611 014522 0 ustar ligges users library("R.utils")
verbose <- Verbose(threshold=-1)
print(verbose)
header(verbose, "A verbose writer example", padding=0)
enter(verbose, "Analysis A")
for (kk in 1:10) {
printf(verbose, "step %d\n", kk)
if (kk == 2) {
cat(verbose, "Turning ON automatic timestamps")
timestampOn(verbose)
} else if (kk == 4) {
timestampOff(verbose)
cat(verbose, "Turned OFF automatic timestamps")
cat(verbose, "Turning OFF verbose messages for steps ", kk, "-6")
off(verbose)
} else if (kk == 6) {
on(verbose)
cat(verbose, "Turned ON verbose messages just before step ", kk+1)
}
if (kk %in% c(5,8)) {
enterf(verbose, "Sub analysis #%d", kk)
for (jj in c("i", "ii", "iii")) {
cat(verbose, "part ", jj)
}
exit(verbose)
}
}
cat(verbose, "All steps completed!")
exit(verbose)
ruler(verbose)
cat(verbose, "Demo of some other methods:")
str(verbose, c(a=1, b=2, c=3))
print(verbose, c(a=1, b=2, c=3))
summary(verbose, c(a=1, b=2, c=3))
evaluate(verbose, rnorm, n=3, mean=2, sd=3)
ruler(verbose)
newline(verbose)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Odds and ends
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
print(equals(verbose, verbose))
print(equals(verbose, NA))
setThreshold(verbose, -4)
print(verbose)
setDefaultLevel(verbose, -1)
print(verbose)
print(as.logical(verbose))
print(as.double(verbose))
print(less(verbose))
print(more(verbose))
timestamp(verbose)
setTimestampFormat(verbose)
print(getTimestampFormat(verbose))
warning("Hello world!")
warnings(verbose)
print(timestamp())
R.utils/tests/insert.R 0000644 0001762 0000144 00000003446 14372747611 014426 0 ustar ligges users library("R.utils")
# Insert NAs (default) between all values
y <- c(a=1, b=2, c=3)
print(y)
x <- insert(y, ats=2:length(y))
Ex <- c(y[1], NA_real_, y[2], NA_real_, y[3])
print(x)
stopifnot(identical(x,Ex))
# Insert at first position
y <- c(a=1, b=2, c=3)
print(y)
x <- insert(y, ats=1, values=rep(NA_real_, 2))
Ex <- c(NA_real_,NA_real_,y)
print(x)
stopifnot(identical(x,Ex))
x <- insert(y, ats=1, values=rep(NA_real_,2), useNames=FALSE)
print(x)
# Insert at last position (names of 'values' are ignored
# because input vector has no names)
x <- insert(1:3, ats=4, values=c(d=2, e=1))
Ex <- c(1:3,2,1)
print(x)
stopifnot(identical(x,Ex))
# Insert in the middle of a vector
x <- insert(c(1,3,2,1), ats=2, values=2)
print(x)
stopifnot(identical(as.double(x),as.double(Ex)))
# Insert multiple vectors at multiple indices at once
x0 <- c(1:4, 8:11, 13:15)
x <- insert(x0, ats=c(5,9), values=list(5:7,12))
print(x)
Ex <- 1:max(x)
stopifnot(identical(as.double(x),as.double(Ex)))
x <- insert(x0, ats=c(5,9,12), values=list(5:7,12,16:18))
print(x)
Ex <- 1:max(x)
stopifnot(identical(as.double(x),as.double(Ex)))
# Insert with duplicated locations (which requires grouping)
x <- letters[1:6]
ats <- c(1L, 1L, 4L)
values <- LETTERS[1:3]
y0 <- c("A", "B", "a", "b", "c", "C", "d", "e", "f")
y <- insert(x, ats = ats, values = values)
print(y)
stopifnot(identical(y, y0))
ats <- c(1L, 4L)
values <- list(LETTERS[1:2], LETTERS[3])
y <- insert(x, ats = ats, values = values)
print(y)
stopifnot(identical(y, y0))
# Insert missing indices
Ex <- 1:20
missing <- setdiff(Ex, x0)
x <- x0
for (m in missing)
x <- insert(x, ats=m, values=m)
print(x)
stopifnot(identical(as.double(x),as.double(Ex)))
## Exception handling
x <- 1:10
res <- try(y <- insert(x, ats=1:2, values=1:3), silent=TRUE)
stopifnot(inherits(res, "try-error"))
R.utils/tests/systemR.R 0000644 0001762 0000144 00000000312 14372747611 014555 0 ustar ligges users library("R.utils")
message("*** systemR() ...")
res <- systemR('--slave -e "cat(runif(1))"', intern=TRUE, verbose=TRUE)
cat("A random number: ", res, "\n", sep="")
message("*** systemR() ... DONE")
R.utils/tests/getOption.R 0000644 0001762 0000144 00000001013 14372747611 015056 0 ustar ligges users digits0 <- digits <- base::getOption("digits")
print(digits)
digits <- getOption("digits")
print(digits)
stopifnot(identical(digits, digits0))
digits <- R.utils::getOption("digits")
print(digits)
stopifnot(identical(digits, digits0))
library("R.utils")
digits <- base::getOption("digits")
print(digits)
stopifnot(identical(digits, digits0))
digits <- getOption("digits")
print(digits)
stopifnot(identical(digits, digits0))
digits <- R.utils::getOption("digits")
print(digits)
stopifnot(identical(digits, digits0))
R.utils/tests/readWindowsShellLink.R 0000644 0001762 0000144 00000000322 14372747611 017204 0 ustar ligges users library("R.utils")
pathname <- system.file("data-ex/HISTORY.LNK", package="R.utils")
lnk <- readWindowsShellLink(pathname)
str(lnk)
str(lnk$pathname)
lnk0 <- readWindowsShortcut(pathname)
str(lnk0$pathname)
R.utils/tests/countLines.R 0000644 0001762 0000144 00000005260 14372747611 015241 0 ustar ligges users library("R.utils")
pathname <- tempfile()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
writeString <- function(s, file) {
raw <- charToRaw(s)
writeBin(raw, con=file)
if (is.character(file)) {
# Sanity check
stopifnot(file.info(file)$size == length(raw))
}
} # writeString()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Empty file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat("", file=pathname)
# Sanity check
stopifnot(file.info(pathname)$size == 0L)
n <- countLines(pathname)
stopifnot(n == 0L)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# File with one line
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# File: Ending with a new line
writeString("Hello world!\n", file=pathname)
n <- countLines(pathname)
stopifnot(n == 1L)
# File: Last line does not end with a new line
writeString("Hello world!", file=pathname)
n <- countLines(pathname)
stopifnot(n == 1L)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Files with multiple lines
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
bfr <- letters[1:9]
# File: All lines ending with a new line
writeString(paste(c(bfr, ""), collapse="\n"), file=pathname)
n <- countLines(pathname)
stopifnot(n == length(bfr))
# File: Last line does not end with a new line
writeString(paste(bfr, collapse="\n"), file=pathname)
n <- countLines(pathname)
stopifnot(n == length(bfr))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Counting either CR, LF, or CRLF
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
for (newline in c("\r", "\n", "\r\n")) {
cat("Newline sequence:\n")
str(newline)
writeString(paste(bfr, collapse=newline), file=pathname)
# Reading from file
n <- countLines(pathname)
stopifnot(n == length(bfr))
# Reading from connection
con <- file(pathname, open="rb")
n <- countLines(con)
close(con)
stopifnot(n == length(bfr))
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Compressed files
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
pathnameGZ <- sprintf("%s.gz", pathname)
for (newline in c("\r", "\n", "\r\n")) {
cat("Newline sequence:\n")
str(newline)
con <- gzfile(pathnameGZ, open="wb")
writeString(paste(bfr, collapse=newline), file=con)
close(con)
# Reading from file
n <- countLines(pathnameGZ)
stopifnot(n == length(bfr))
print(n)
# Reading from connection
con <- gzfile(pathname, open="rb")
n <- countLines(con)
close(con)
print(n)
stopifnot(n == length(bfr))
}
# Cleanup
file.remove(pathnameGZ)
file.remove(pathname)
R.utils/tests/readBinFragments.R 0000644 0001762 0000144 00000007170 14372747611 016333 0 ustar ligges users library("R.utils")
if ("covr" %in% loadedNamespaces())
options("R.utils::onNonSeekable"="warning")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Create a data file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
data <- 1:255
size <- 2
pathname <- tempfile("exampleReadBinFragments")
writeBin(con=pathname, data, size=size)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Read and write using index vectors
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat("Read file...\n")
# Read every 16:th byte in the file
idxs <- seq(from=1, to=255, by=16)
x <- readBinFragments(pathname, what="integer", size=size, signed=FALSE, idxs=idxs)
stopifnot(identical(x, data[idxs]))
print(x)
# Read every 16:th byte in a connection starting with the 6th.
idxs <- idxs + 5L
x <- readBinFragments(pathname, what="integer", size=size, signed=FALSE, idxs=idxs)
stopifnot(identical(x, data[idxs]))
print(x)
cat("Read file...done\n")
cat("Write file...\n")
# Update every 16:th byte in the file
idxs <- seq(from=1, to=255, by=16)
x0 <- data[idxs]
writeBinFragments(pathname, idxs=idxs, rev(x0), size=size)
x <- readBinFragments(pathname, what="integer", size=size, signed=FALSE, idxs=idxs)
print(x)
stopifnot(identical(rev(x0), x))
# Update every 16:th byte in the file
idxs <- seq(from=1, to=255, by=16)
writeBinFragments(pathname, idxs=idxs, rev(x), size=size)
x <- readBinFragments(pathname, what="integer", size=size, signed=FALSE, idxs=idxs)
print(x)
stopifnot(identical(x0, x))
# Assert everything is as expected
# Read the complete file
x <- readBin(pathname, what="integer", size=size, signed=FALSE, n=length(data))
stopifnot(identical(x, data))
cat("Write file...done\n")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Ditto but via a connection
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat("Read connection...\n")
# Read every 16:th byte in a connection
con <- file(pathname, open="rb")
idxs <- seq(from=1, to=255, by=16)
x <- readBinFragments(con, what="integer", size=size, signed=FALSE, idxs=idxs)
stopifnot(identical(x, data[idxs]))
print(x)
# Read every 16:th byte in a connection starting with the 6th.
idxs <- idxs + 5L
x <- readBinFragments(con, what="integer", size=size, signed=FALSE, idxs=idxs, origin="start")
stopifnot(identical(x, data[idxs]))
print(x)
close(con)
cat("Read connection...done\n")
# Update every 16:th byte in a connection
cat("Write connection...\n")
con <- file(pathname, open="r+b")
idxs <- seq(from=1, to=255, by=16)
x0 <- data[idxs]
writeBinFragments(pathname, idxs=idxs, rev(x0), size=size)
x <- readBinFragments(pathname, what="integer", size=size, signed=FALSE, idxs=idxs)
print(x)
stopifnot(identical(rev(x0), x))
# Update every 16:th byte in the file
idxs <- seq(from=1, to=255, by=16)
writeBinFragments(pathname, idxs=idxs, rev(x), size=size)
x <- readBinFragments(pathname, what="integer", size=size, signed=FALSE, idxs=idxs, origin="start")
print(x)
stopifnot(identical(x0, x))
close(con)
# Assert everything is as expected
# Read the complete file
x <- readBin(pathname, what=integer(), size=size, signed=FALSE, n=length(data))
stopifnot(identical(x, data))
cat("Write connection...done\n")
# Read bytes 1-4, 11-14, 21-24, ...
idxs <- seq(from=1, to=255, by=10)
idxs <- cbind(idxs, idxs+3)
x <- readBinFragments(pathname, what="integer", size=size, signed=FALSE, idxs=idxs, verbose=TRUE)
idxsX <- intervalsToSeq(idxs)
stopifnot(identical(x, data[idxsX]))
print(x)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Clean up
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
file.remove(pathname)
R.utils/tests/useRepos.R 0000644 0001762 0000144 00000000337 14372747611 014723 0 ustar ligges users library("R.utils")
# Get current 'repos' option
orepos <- useRepos()
print(orepos)
useRepos("http://cran.r-project.org")
repos <- useRepos()
print(repos)
# Reset 'repos'
useRepos(orepos)
repos <- useRepos()
print(repos)
R.utils/tests/symlinks,dirs.R 0000644 0001762 0000144 00000004746 14372747611 015735 0 ustar ligges users library("R.utils")
verbose <- Arguments$getVerbose(TRUE, timestamp=TRUE)
# Run only tests if this platform/client supports symbolic file links
canSymlink <- tryCatch({
res <- file.symlink(".", "test-symlink-dir")
if (isDirectory("test-symlink-dir")) removeDirectory("test-symlink-dir")
res
}, error = function(ex) FALSE)
# Test only if symlinks are supported
if (canSymlink) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
fileAccessT <- function(pathname, modes=c(exist=0, exec=1, write=2, read=4)) {
sapply(modes, FUN=function(mode) fileAccess(pathname, mode=mode))
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# DIRECTORIES
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
verbose && enter(verbose, "Symbolic links to directories")
# Create a target
path <- file.path(tempdir(), "foo")
mkdirs(path)
stopifnot(isDirectory(path))
# Create a symbolic link
pathL <- "link-to-tempdir"
file.symlink(path, pathL)
stopifnot(isDirectory(pathL))
# File information (directly and via link)
fi <- file.info(path)
fiL <- file.info2(pathL)
stopifnot(all.equal(fiL, fi, check.attributes=FALSE))
# Add a file (via link)
pathnameL <- file.path(pathL, "target2.txt")
cat("Hello", file=pathnameL)
# Assert that it exists (via direct pathname)
pathname <- file.path(path, "target2.txt")
stopifnot(isFile(pathname))
# Remove file (via direct pathname)
file.remove(pathname)
stopifnot(!isFile(pathname))
stopifnot(!isFile(pathnameL))
verbose && enter(verbose, "Renaming")
pathL2 <- sprintf("%s-new", pathL)
renameFile(pathL, pathL2)
stopifnot(isDirectory(pathL2))
renameFile(pathL2, pathL)
stopifnot(isDirectory(pathL))
verbose && exit(verbose)
# File access
verbose && enter(verbose, "Testing file permissions & access information")
fa <- fileAccessT(path)
faL <- fileAccessT(pathL)
stopifnot(identical(faL, fa))
# Disable write permission on target
Sys.chmod(path, mode="0077")
fa <- fileAccessT(path)
faL <- fileAccessT(pathL)
stopifnot(identical(faL, fa))
# Reset
Sys.chmod(path, mode="0777")
verbose && exit(verbose)
# Removing & cleanup
verbose && enter(verbose, "Cleanup")
# (Neither file.remove() nor unlink() can remove symbolic directory links)
removeDirectory(pathL)
stopifnot(!isDirectory(pathL))
stopifnot(isDirectory(path))
removeDirectory(path)
stopifnot(!isDirectory(path))
verbose && exit(verbose)
verbose && exit(verbose)
} # if (canSymlink)
R.utils/tests/env.R 0000644 0001762 0000144 00000000444 14372747611 013705 0 ustar ligges users library("R.utils")
x <- list()
x$case1 <- env({
# Cut'n'pasted from elsewhere
a <- 1
b <- 2
})
x$case2 <- env({
# Cut'n'pasted from elsewhere
foo <- function(x) x^2
a <- foo(2)
b <- 1
rm(foo) # Not needed anymore
})
# Turn into a list of lists
x <- lapply(x, FUN=as.list)
str(x)
R.utils/tests/listDirectory.R 0000644 0001762 0000144 00000001004 14372747611 015746 0 ustar ligges users library("R.utils")
path <- system.file(package="R.utils")
print(listDirectory(path))
print(listDirectory(path, pattern="DESCRIPTION"))
print(listDirectory(path, recursive=TRUE))
print(listDirectory(path, recursive=+Inf))
print(listDirectory(path, recursive=FALSE))
print(listDirectory(path, recursive=0L))
print(listDirectory(path, recursive=1L))
print(listDirectory(path, recursive=2L))
## Full names
print(listDirectory(path, recursive=2L, fullNames=TRUE))
## Non-existing
print(listDirectory("unknown-path"))
R.utils/tests/intToHex.R 0000644 0001762 0000144 00000003057 14372747611 014662 0 ustar ligges users library("R.utils")
x <- c(7, 8, 15, 16)
print(x)
y <- intToHex(x)
y_truth <- c("07", "08", "0f", "10")
print(y)
stopifnot(is.character(y), all(!is.na(y)), identical(y, y_truth))
y <- intToOct(x)
y_truth <- c("07", "10", "17", "20")
print(y)
stopifnot(is.character(y), all(!is.na(y)), identical(y, y_truth))
y <- intToBin(x)
y_truth <- c("00111", "01000", "01111", "10000")
print(y)
stopifnot(is.character(y), all(!is.na(y)), identical(y, y_truth))
x <- -3:3
print(x)
y <- intToHex(x)
y_truth <- c("fffffffd", "fffffffe", "ffffffff",
"00000000",
"00000001", "00000002", "00000003")
print(y)
stopifnot(is.character(y), all(!is.na(y)), identical(y, y_truth))
y <- intToOct(x)
y_truth <- c("37777777775", "37777777776", "37777777777",
"00000000000",
"00000000001", "00000000002", "00000000003")
print(y)
stopifnot(is.character(y), all(!is.na(y)), identical(y, y_truth))
y <- intToBin(x)
y_truth <- c("1111111111111111111111111111101",
"1111111111111111111111111111110",
"1111111111111111111111111111111",
"0000000000000000000000000000000",
"0000000000000000000000000000001",
"0000000000000000000000000000010",
"0000000000000000000000000000011")
print(y)
stopifnot(is.character(y), all(!is.na(y)), identical(y, y_truth))
## Integer out of range
x <- 2^31
y <- intToBin(x)
print(y)
stopifnot(is.character(y), is.na(y))
y <- intToHex(x)
print(y)
stopifnot(is.character(y), is.na(y))
y <- intToOct(x)
print(y)
stopifnot(is.character(y), is.na(y))
R.utils/tests/fileAccess.R 0000644 0001762 0000144 00000004207 14372747611 015157 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Current directory
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
path <- "."
# Test for existence
print(fileAccess(path, mode=0))
# Test for execute permission
print(fileAccess(path, mode=1))
# Test for write permission
print(fileAccess(path, mode=2))
# Test for read permission
print(fileAccess(path, mode=4))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# A temporary file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
pathname <- tempfile()
cat(file=pathname, "Hello world!")
# Test for existence
print(fileAccess(pathname, mode=0))
# Test for execute permission
print(fileAccess(pathname, mode=1))
# Test for write permission
print(fileAccess(pathname, mode=2))
# Test for read permission
print(fileAccess(pathname, mode=4))
file.remove(pathname)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# The 'base' package directory
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
path <- system.file(package="base")
# Test for existence
print(fileAccess(path, mode=0))
# Test for execute permission
print(fileAccess(path, mode=1))
# Test for write permission
print(fileAccess(path, mode=2))
# Test for read permission
print(fileAccess(path, mode=4))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# The 'base' package DESCRIPTION file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
pathname <- system.file("DESCRIPTION", package="base")
# Test for existence
print(fileAccess(pathname, mode=0))
# Test for execute permission
print(fileAccess(pathname, mode=1))
# Test for write permission
print(fileAccess(pathname, mode=2))
# Test for read permission
print(fileAccess(pathname, mode=4))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Assert that RNG state does not change (mode = 2)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Make sure .Random.seed exists
dummy <- sample(1:10)
rng0 <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
res <- fileAccess(tempdir(), mode=2)
rng1 <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
stopifnot(identical(rng1, rng0))
R.utils/tests/VComments.R 0000644 0001762 0000144 00000000510 14372747611 015022 0 ustar ligges users library("R.utils")
opager <- options(pager=mpager)
filename <- system.file("data-ex/exampleVComments.R", package="R.utils")
lines <- readLines(filename)
cat("Code before preprocessing:\n")
displayCode(code=lines)
lines <- VComments$compile(lines)
cat("Code after preprocessing:\n")
displayCode(code=lines)
options(opager)
R.utils/tests/withLocale.R 0000644 0001762 0000144 00000003005 14372747611 015204 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Basic tests
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# The current set of locales
old <- Sys.getlocale("LC_ALL")
# Vector
cat("Original vector:\n")
x <- c(letters[1:8], LETTERS[1:8])
print(x)
cat("Sorting with 'C' locale:\n")
y1 <- withLocale(sort(x), "LC_COLLATE", "C")
print(y1)
cat("Sorting with an 'English' locale:\n")
y2 <- withLocale(sort(x), "LC_COLLATE", c("en_US", "en_US.UTF8", "English_United States.1252"))
print(y2)
# Sanity check
curr <- Sys.getlocale("LC_ALL")
if (!identical(curr, old)) {
throw("Locale settings have changed: ", old, " != ", curr)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Nested calls
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat("Sorting with 'C' locale (nested inside a English one):\n")
y3 <- withLocale({
withLocale({
sort(x)
}, "LC_COLLATE", "C")
}, "LC_COLLATE", c("en_US", "en_US.UTF8", "English_United States.1252"))
print(y3)
stopifnot(identical(y3, y1))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Visibility
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
res <- withVisible({
withLocale({ 1 }, "LC_COLLATE", "C")
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(res$visible)
x <- 0
res <- withVisible({
withLocale({ x <- 1 }, "LC_COLLATE", "C")
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(!res$visible)
stopifnot(all.equal(x, 1))
R.utils/tests/sourceDirectory.R 0000644 0001762 0000144 00000002171 14372747611 016301 0 ustar ligges users library("R.utils")
## Create a test folder with R scripts
path <- file.path(tempdir(), "R.utils")
dir.create(path, recursive = TRUE, showWarnings = FALSE)
pathname <- file.path(path, "increment_x.R")
cat(file = pathname, "x <- x + 1L\n")
x <- 0L
source(pathname)
message("x = ", x)
stopifnot(x == 1L)
source(pathname)
message("x = ", x)
stopifnot(x == 2L)
for (kk in 1:2) {
sourceTo(pathname, modifiedOnly = TRUE)
message("x = ", x)
stopifnot(x == 3L)
}
Sys.sleep(1)
touchFile(pathname)
for (kk in 1:2) {
sourceTo(pathname, modifiedOnly = TRUE)
message("x = ", x)
stopifnot(x == 4L)
}
sourceTo(pathname, modifiedOnly = FALSE)
message("x = ", x)
stopifnot(x == 5L)
for (kk in 1:2) {
sourceDirectory(path, modifiedOnly = TRUE)
message("x = ", x)
stopifnot(x == 5L)
}
sourceDirectory(path, modifiedOnly = FALSE)
message("x = ", x)
stopifnot(x == 6L)
sourceDirectory(path, modifiedOnly = TRUE)
message("x = ", x)
stopifnot(x == 6L)
Sys.sleep(1)
touchFile(pathname)
for (kk in 1:2) {
sourceDirectory(path, modifiedOnly = TRUE)
message("x = ", x)
stopifnot(x == 7L)
}
## Cleanup
#unlink(path, recursive = TRUE)
R.utils/tests/createFileAtomically.R 0000644 0001762 0000144 00000003241 14372747611 017175 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Create a file atomically
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
n <- 10
createFileAtomically("foobar.txt", FUN=function(pathname) {
cat(file=pathname, "This file was created atomically.\n")
cat(file=pathname, "Timestamp: ", as.character(Sys.time()), "\n", sep="")
for (kk in 1:n) {
cat(file=pathname, kk, "\n", append=TRUE)
# Emulate a slow process
if (interactive()) Sys.sleep(0.1)
}
cat(file=pathname, "END OF FILE\n", append=TRUE)
}, overwrite=TRUE)
# Skip, if already exists
createFileAtomically("foobar.txt", FUN=function(pathname) {
cat("This will not be called\n")
}, skip=TRUE, verbose=TRUE)
bfr <- readLines("foobar.txt")
cat(bfr, sep="\n")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Overwrite the file atomically (emulate write failure)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
tryCatch({
createFileAtomically("foobar.txt", FUN=function(pathname) {
cat(file=pathname, "Trying to create a new file.\n")
cat(file=pathname, "Writing a bit, but then an error...\n", append=TRUE)
# Emulate write error
stop("An error occured while writing to the new file.")
cat(file=pathname, "END OF FILE\n", append=TRUE)
}, overwrite=TRUE)
}, error = function(ex) {
print(ex$message)
})
# The original file was never overwritten
bfr2 <- readLines("foobar.txt")
cat(bfr2, sep="\n")
stopifnot(identical(bfr2, bfr))
# The partially temporary file remains
stopifnot(isFile("foobar.txt.tmp"))
bfr3 <- readLines("foobar.txt.tmp")
cat(bfr3, sep="\n")
file.remove("foobar.txt.tmp")
file.remove("foobar.txt")
R.utils/tests/symlinks,files.R 0000644 0001762 0000144 00000010330 14564147542 016060 0 ustar ligges users library("R.utils")
verbose <- Arguments$getVerbose(TRUE, timestamp=TRUE)
# Run only tests if this platform/client supports symbolic file links
canSymlink <- tryCatch({
res <- file.symlink(".", "test-symlink-dir")
if (isDirectory("test-symlink-dir")) removeDirectory("test-symlink-dir")
res
}, error = function(ex) FALSE)
# Test only if symlinks are supported
if (canSymlink) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
fileAccessT <- function(pathname, modes=c(exist=0, exec=1, write=2, read=4)) {
sapply(modes, FUN=function(mode) fileAccess(pathname, mode=mode))
}
filename <- "foo.txt"
paths <- list(".", tempdir())
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# FILES
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
for (path in paths) {
verbose && enter(verbose, "Symbolic links to files")
verbose && cat(verbose, "Path: ", path)
pathnameS <- pathname <- file.path(path, filename)
# WORKAROUND: On Windows, file.symlink() does not translate forward
# slashes for you! Fixed (PR#15631) in r64711 2014-01-09.
if (.Platform$OS.type == "windows") {
pathnameS <- gsub("/", "\\", pathname, fixed=TRUE)
}
# Create a target file
cat("Hello", file=pathname)
# Create a symbolic link
pathnameL <- file.path(path, sprintf("link-to-%s", filename))
file.symlink(pathnameS, pathnameL)
stopifnot(isFile(pathnameL))
stopifnot(identical(lastModified(pathnameL), lastModified(pathname)))
# Get target pathname
pathnameT <- Sys.readlink2(pathnameL)
# Should be equal
stopifnot(getAbsolutePath(pathnameT) == getAbsolutePath(pathname))
# Read contents (directly and via link)
bfr <- readChar(pathname, n=1e6)
bfrL <- readChar(pathnameL, n=1e6)
# Should be identical content
stopifnot(identical(bfrL, bfr))
# Append content (via link)
cat(" world!", file=pathnameL, append=TRUE)
# Read contents (directly and via link)
bfr <- readChar(pathname, n=1e6)
printf("Target content: '%s'\n", bfr)
bfrL <- readChar(pathnameL, n=1e6)
printf("Link content : '%s'\n", bfrL)
# Should be identical content
stopifnot(identical(bfrL, bfr))
# Retrieve file information (directly and via link)
fi <- file.info(pathname)
printf("*** file.info('%s'):\n", pathname)
print(fi)
fiL <- file.info2(pathnameL)
printf("*** file.info2('%s'):\n", pathnameL)
print(fiL)
# Should be equal file information except the filenames
stopifnot(all.equal(fiL, fi, check.attributes=FALSE))
stopifnot(identical(lastModified(pathnameL), lastModified(pathname)))
# Note that file.info() does not follow links on Windows
if (.Platform$OS.type == "windows") {
fiLx <- file.info(pathnameL)
printf("*** file.info('%s'):\n", pathnameL)
print(fiLx)
res <- all.equal(fiLx, fi, check.attributes=FALSE)
}
# Renaming
verbose && enter(verbose, "Renaming file link")
pathnameL2 <- sprintf("%s-new", pathnameL)
renameFile(pathnameL, pathnameL2)
stopifnot(isFile(pathnameL2))
stopifnot(!isFile(pathnameL))
renameFile(pathnameL2, pathnameL)
stopifnot(isFile(pathnameL))
stopifnot(!isFile(pathnameL2))
verbose && exit(verbose)
# File access
verbose && enter(verbose, "Testing file permissions & access information")
fa <- fileAccessT(pathname)
faL <- fileAccessT(pathnameL)
stopifnot(identical(faL, fa))
# Disable write permission on target
Sys.chmod(pathname, mode="0077")
fa <- fileAccessT(pathname)
faL <- fileAccessT(pathnameL)
stopifnot(identical(faL, fa))
# Reset
Sys.chmod(pathname, mode="0777")
verbose && exit(verbose)
# Removing & cleanup
verbose && enter(verbose, "Cleanup")
verbose && enter(verbose, "Removing file link")
verbose && cat(verbose, "Link: ", pathnameL)
verbose && cat(verbose, "Target: ", pathname)
file.remove(pathnameL) # unlink() cannot remove symbolic links
stopifnot(!file.exists(pathnameL))
stopifnot(isFile(pathname))
verbose && exit(verbose)
verbose && enter(verbose, "Removing target")
file.remove(pathname)
stopifnot(!file.exists(pathname))
verbose && exit(verbose)
verbose && exit(verbose)
verbose && exit(verbose)
} # for (path in ...)
} # if (canSymlink)
R.utils/tests/loadToEnv.R 0000644 0001762 0000144 00000000220 14372747611 015000 0 ustar ligges users library("R.utils")
file <- tempfile()
x <- 1:10
save(x, file=file)
env <- loadToEnv(file)
print(env)
print(ls(envir=env))
file.remove(file)
R.utils/tests/captureOutput.R 0000644 0001762 0000144 00000001672 14372747611 016005 0 ustar ligges users library("R.utils")
message("*** captureOutput() == capture.output()")
for (n in c(0, 1, 10, 100, 1000)) {
printf("n=%d\n", n)
x <- rnorm(n)
str(x)
bfr0 <- capture.output(print(x))
bfr <- captureOutput(print(x))
stopifnot(nchar(bfr) == nchar(bfr0))
stopifnot(identical(bfr, bfr0))
} # for (n ...)
message("*** captureOutput(..., collapse=ch)")
x <- c("abc", "123", "def\n456")
for (ch in list(NULL, "\n", "\r", "\n\r", "\r\n", ";\n", "")) {
bfr0 <- paste(capture.output(cat(x)), collapse=ch)
bfr <- captureOutput(cat(x), collapse=ch)
str(list(bfr0=bfr0, bfr=bfr))
stopifnot(identical(bfr0, bfr))
}
message("*** captureOutput(..., file='foo.txt')")
x <- c("abc", "123", "def\n456")
capture.output(cat(x), file="foo1.txt")
captureOutput(cat(x), file="foo2.txt")
bfr1 <- readLines("foo1.txt", warn=FALSE)
bfr2 <- readLines("foo2.txt", warn=FALSE)
stopifnot(all.equal(bfr2, bfr1))
file.remove("foo1.txt")
file.remove("foo2.txt")
R.utils/tests/isUrl.R 0000644 0001762 0000144 00000000644 14372747611 014215 0 ustar ligges users library("R.utils")
urls <- c(
"http://www.r-project.org/",
"ftp://cran.r-project.org/",
"htttp://www.r-project.org/", ## typo, but still a URL
"", ## empty
NA_character_ ## missing
)
print(urls)
res <- sapply(urls, FUN=isUrl)
print(res)
res <- isUrl(urls)
print(res)
stopifnot(is.logical(res))
stopifnot(length(res) == length(urls))
stopifnot(!any(is.na(res)))
R.utils/tests/cmdArgs.R 0000644 0001762 0000144 00000002424 14372747611 014475 0 ustar ligges users library("R.utils")
######################################################################
# Parsed command-line arguments
######################################################################
# Call:
exprA <- "str(R.utils::cmdArgs(defaults=list(n=2L,a=2)))"
exprB <- "str(R.utils::cmdArgs(defaults=list(n=3L,a=3)))"
argsC <- c("Rscript", "-e", exprA, "--args", "-e", exprB, "-n", "1")
print(argsC)
# Truth:
args0 <- list(e=exprB, n=1)
args <- cmdArgs(.args=argsC)
str(args)
stopifnot(all.equal(args, args0))
# Truth:
args0 <- list(x=3.14, e=exprB, n=1L)
args <- cmdArgs(defaults=list(n=0L, x=3.14), .args=argsC)
str(args)
stopifnot(all.equal(args, args0))
# Truth:
args0 <- list(K=50)
args <- cmdArgs(args=args0, .args=argsC)
str(args)
stopifnot(all.equal(args, args0))
args <- cmdArgs(args=list())
str(args)
args <- cmdArgs(args="*")
str(args)
args <- cmdArgs(args=list("*", "*"))
str(args)
args <- cmdArgs(args=list("*", a=3L, "*"))
str(args)
args <- cmdArgs(args=args0, names="K")
str(args)
stopifnot(all.equal(args, args0["K"]))
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Call function via command-line arguments
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
value <- cmdArgsCall("seq_len", args=list(length.out=5))
print(value)
R.utils/tests/eget.R 0000644 0001762 0000144 00000001046 14372747611 014040 0 ustar ligges users library("R.utils")
# Get variable 'a' if it exists, otherwise return the default value.
value <- eget("a", default=42L)
print(value) # 42L
# Short version doing the same
value <- eget(a=42L)
print(value) # 42L
# Same, but look for the variable in 'envir' (here a list)
value <- eget("a", default=42L, envir=list(a=1))
print(value) # 1L
# Get variable 'n', which defaults to command-line argument
# 'n' ('-n' or '--n'), which in turn defaults to 42L.
value <- eget(n=cmdArg(n=42L))
print(value)
# Equivalently.
value <- ecget(n=42L)
print(value)
R.utils/tests/doCall.R 0000644 0001762 0000144 00000001145 14372747611 014312 0 ustar ligges users library("R.utils")
message("*** doCall() ...\n")
value <- doCall(seq_len, length.out=5L, .ignoreUnusedArgs=FALSE)
print(value)
value <- doCall("seq_len", args=list(length.out=5L), .ignoreUnusedArgs=FALSE)
print(value)
value <- doCall("seq_len", args=list(length.out=5L), .functions=list("seq_len"), .ignoreUnusedArgs=FALSE)
print(value)
## Exception handling
res <- try(doCall(2L), silent=TRUE)
stopifnot(inherits(res, "try-error"))
res <- try(doCall("seq_len", args=list(length.out=5L), .functions=list("")), silent=TRUE)
stopifnot(inherits(res, "try-error"))
message("*** doCall() ... DONE\n")
R.utils/tests/tmpfile.R 0000644 0001762 0000144 00000001170 14372747611 014552 0 ustar ligges users library("R.utils")
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Assert that auto delete works
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Temporary files before
tfiles <- dir(path=tempdir(), full.names=TRUE)
## Create temporary file on the fly without any references to it
bfr <- readLines(tmpfile("Hello world!\n"))
print(bfr)
## Find new temporary file
tfile <- setdiff(dir(path=tempdir(), full.names=TRUE), tfiles)
print(tfile)
stopifnot(file.exists(tfile))
## The on-the-fly temporary file is removed
## whenever the garbage collector runs
gc()
stopifnot(!file.exists(tfile))
R.utils/tests/Arguments-FILES.R 0000644 0001762 0000144 00000001167 14372747611 015725 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# getReadablePathname()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
paths <- c(".", getwd(), R.home(), system.file(package="R.utils"))
for (path in paths) {
for (mustExist in c(FALSE, TRUE)) {
path2 <- Arguments$getReadablePath(path, mustExist=mustExist)
str(list(path=path, path2=path2))
}
}
# Missing values
pathname <- Arguments$getReadablePathname(NA_character_, mustExist=FALSE)
stopifnot(is.na(pathname))
path <- Arguments$getReadablePath(NA_character_, mustExist=FALSE)
stopifnot(is.na(path))
R.utils/tests/isZero.R 0000644 0001762 0000144 00000001243 14372747611 014366 0 ustar ligges users library("R.utils")
x <- 0
print(x == 0) # TRUE
print(isZero(x)) # TRUE
x <- 1
print(x == 0) # FALSE
print(isZero(x)) # FALSE
x <- .Machine$double.eps
print(x == 0) # FALSE
print(isZero(x)) # FALSE
x <- 0.9*.Machine$double.eps
print(x == 0) # FALSE
print(isZero(x)) # TRUE
# From help(Comparisions)
x1 <- 0.5 - 0.3
x2 <- 0.3 - 0.1
print(x1 - x2)
print(x1 == x2) # FALSE on most machines
print(identical(all.equal(x1, x2), TRUE)) # TRUE everywhere
print(isZero(x1-x2)) # TRUE everywhere
# Specifying tolerance by name
print(isZero(x1-x2, eps="double.eps"))
print(isZero(x1-x2, eps="single.eps"))
R.utils/tests/System.R 0000644 0001762 0000144 00000000157 14372747611 014402 0 ustar ligges users library("R.utils")
print(System$getHostname())
print(System$getUsername())
print(System$currentTimeMillis())
R.utils/tests/commandArgs.R 0000644 0001762 0000144 00000005354 14372747611 015355 0 ustar ligges users library("R.utils")
######################################################################
# How R was invoked
######################################################################
cmd <- paste(commandArgs(), collapse=" ")
cat("How R was invoked:\n")
cat(cmd, "\n")
# Get all arguments
args <- commandArgs()
print(args)
# Get only "private" arguments and not the name of the R executable.
args <- commandArgs(excludeReserved=TRUE)[-1]
print(args)
# Assert backward compatibility
args0 <- base::commandArgs()
args <- commandArgs()
stopifnot(all.equal(args, args0))
######################################################################
# Parsed command-line arguments
######################################################################
# Call #1:
argsC <- c("R", "--encoding=ASCII", "--encoding", "ASCII", "DATAPATH=../data", "--args", "--root=do da", "--foo", "bar", "--details", "--a=2", "--src_file=foo.R")
print(argsC)
# Truth:
args0 <- list("R", encoding="ASCII", encoding="ASCII", DATAPATH="../data", args=TRUE, root="do da", foo="bar", details=TRUE, a="2", "src_file"="foo.R")
args <- commandArgs(asValues=TRUE, .args=argsC)
str(args)
stopifnot(all.equal(args, args0))
# Exclude reserved
args <- commandArgs(asValues=TRUE, excludeReserved=TRUE, excludeEnvVars=TRUE, .args=argsC)[-1L]
stopifnot(all.equal(args, args0[-(1:5)]))
# Call #2:
argsC <- c("R", "noname1", "DATAPATH=../data", "--args", "--root=do da", "noname2", "--foo", "bar", "--details", "--a=2", "noname3", "noname4", "noname5", "--b=pi", "--c:=pi")
print(argsC)
# Truth:
args0 <- list("R", "noname1", DATAPATH="../data", args=TRUE, root="do da", "noname2", foo="bar", details=TRUE, a="2", "noname3", "noname4", "noname5", b="pi", c=structure("pi", class="CmdArgExpression"))
args <- commandArgs(asValues=TRUE, .args=argsC)
str(args)
stopifnot(all.equal(args, args0))
# Truth (when evaluating expression):
args0 <- list("R", "noname1", DATAPATH="../data", args=TRUE, root="do da", "noname2", foo="bar", details=TRUE, a=2, "noname3", "noname4", "noname5", b="pi", c=pi)
args <- commandArgs(asValues=TRUE, adhoc=TRUE, .args=argsC)
str(args)
stopifnot(all.equal(args, args0))
for (asValues in c(TRUE, FALSE)) {
# Argument 'defaults'
args <- commandArgs(asValues=asValues, .args=argsC, defaults=c(a=1L, d=4L))
str(args)
# Argument 'always'
args <- commandArgs(asValues=asValues, .args=argsC, always=c(c=4L))
str(args)
# Argument 'unique'
args <- commandArgs(asValues=asValues, .args=argsC, unique=TRUE)
str(args)
# Argument 'os'
args <- commandArgs(asValues=asValues, os="current")
str(args)
# Unusual option: -name=value
args <- commandArgs(asValues=asValues, .args="-foo=4")
str(args)
# Default
args <- commandArgs(asValues=asValues)
str(args)
} # for (asValues ...)
R.utils/tests/gcat.R 0000644 0001762 0000144 00000001036 14372747611 014031 0 ustar ligges users message("*** Testing gcat()...")
library("R.utils")
gcat("Hello world!\n")
a <- 1
gcat("a=${a}\n")
gcat(GString("a=${a}\n"))
message("*** Testing gcat()...DONE")
message("*** Testing gstring()...")
a <- 2
s <- gstring("a=${a}\n")
print(s)
cat("a=${a}\n", file="foo.txt")
s <- gstring(file="foo.txt")
print(s)
file.remove("foo.txt")
pathT <- tempdir()
pathname <- file.path(pathT, "foo.txt")
cat("a=${a}\n", file=pathname)
s <- gstring(file="foo.txt", path=pathT)
print(s)
file.remove(pathname)
message("*** Testing gcat()...DONE")
R.utils/tests/zzz_finalizer_crash.R 0000644 0001762 0000144 00000001421 14372747611 017171 0 ustar ligges users # This script crashes in ~40s on R 2.15.3 patched and R 3.0.2 with
# R.oo (< 1.18.0). It only does so when 'methods' is attached. It
# does not crash on R 3.0.2 patched (2014-02-21 r65057) and beyond.
# It appears to not crash with 'R CMD check' on 2.15.3 but if run
# via 'Rscript' or similar. /HB 2014-02-22
library("methods")
library("R.methodsS3")
loadNamespace("R.utils")
# Remove all existing variables
rm(list=ls(all.names=TRUE))
gc()
R.oo::setConstructorS3("Verbose2", function(con=stderr(), ...) {
R.oo::extend(R.oo::Object(), "Verbose",
.con = con
)
})
print(sessionInfo())
message(Sys.time())
local({
Verbose2(file())
gctorture(TRUE)
unloadNamespace("R.utils")
unloadNamespace("R.oo")
NULL
})
gctorture(FALSE)
message(Sys.time())
print(sessionInfo())
R.utils/tests/colClasses.R 0000644 0001762 0000144 00000002106 14372747611 015205 0 ustar ligges users library("R.utils")
# All predefined types
print(colClasses("-?cdfilnrzDP"))
## [1] "NULL" "NA" "character" "double"
## [5] "factor" "integer" "logical" "numeric"
## [9] "raw" "complex" "Date" "POSIXct"
# A string in column 1, integers in column 4 and 5, rest skipped
print(colClasses("c--ii----"))
## [1] "character" "NULL" "NULL" "integer"
## [5] "integer" "NULL" "NULL" "NULL"
## [9] "NULL"
# Repeats and custom column classes
c1 <- colClasses("3c{MyClass}3{foo}")
print(c1)
## [1] "character" "character" "character" "MyClass"
## [5] "foo" "foo" "foo"
# Passing repeats and class names using sprintf() syntax
c2 <- colClasses("%dc{%s}%d{foo}", 3, "MyClass", 3)
stopifnot(identical(c1, c2))
# Repeats of a vector of column classes
c3 <- colClasses("3{MyClass,c}")
print(c3)
## [1] "MyClass" "character" "MyClass" "character"
## [4] "MyClass" "character"
# Large number repeats
c4 <- colClasses("321{MyClass,c,i,d}")
c5 <- rep(c("MyClass", "character", "integer", "double"), times=321)
stopifnot(identical(c4, c5))
R.utils/tests/copyRenameFile.R 0000644 0001762 0000144 00000002633 14372747611 016021 0 ustar ligges users library("R.utils")
# Create file
cat("Hello", file="hello.txt")
stopifnot(isFile("hello.txt"))
# Copy file
copyFile("hello.txt", "hello2.txt", verbose=TRUE)
stopifnot(isFile("hello2.txt"))
# Copy file
stopifnot(all(isFile(c("hello.txt", "hello2.txt"))))
# Copy file by overwriting existing file
copyFile("hello.txt", "hello2.txt", overwrite=TRUE)
stopifnot(isFile("hello2.txt"))
# Copy file to directory
pathD <- tempdir()
copyFile("hello.txt", pathD)
pathnameD <- file.path(pathD, "hello.txt")
stopifnot(isFile(pathnameD))
file.remove(pathnameD)
# Rename file
renameFile("hello2.txt", "hello3.txt", verbose=TRUE)
stopifnot(!isFile("hello2.txt"))
stopifnot(isFile("hello3.txt"))
# Rename file by overwriting existing file
renameFile("hello3.txt", "hello.txt", overwrite=TRUE)
stopifnot(!isFile("hello3.txt"))
stopifnot(isFile("hello.txt"))
# Move file to directory (and back)
# NOTE: We are not moving file to tempdir() just in case
# that is on a different file system which in case we
# risk getting error "cannot rename file reason 'Invalid
# cross-device link' (some Unix problem)
pathD <- "foo"
mkdirs(pathD)
renameFile("hello.txt", pathD)
pathnameD <- file.path(pathD, "hello.txt")
stopifnot(isFile(pathnameD))
renameFile(pathnameD, ".")
## Exception handling
res <- try(copyFile("hello.txt", "hello.txt"), silent=TRUE)
stopifnot(inherits(res, "try-error"))
# Cleanup
removeDirectory("foo")
file.remove("hello.txt")
R.utils/tests/parseRepos.R 0000644 0001762 0000144 00000002575 14372747611 015247 0 ustar ligges users library("R.utils")
message("CRAN:")
str(as.list(parseRepos("CRAN")))
message("braju.com:")
str(as.list(parseRepos("braju.com")))
message("CRAN + braju.com:")
str(as.list(parseRepos(c("CRAN", "braju.com"))))
message("braju.com + CRAN:")
str(as.list(parseRepos(c("braju.com", "CRAN"))))
message("All CRAN related repositories:")
str(as.list(parseRepos("[[CRAN]]")))
message("All BioC related repositories:")
str(as.list(parseRepos("[[BioC]]")))
message("braju.com + all CRAN related repositories:")
str(as.list(parseRepos(c("braju.com", "[[CRAN]]"))))
message("All CRAN related repositories + braju.com:")
str(as.list(parseRepos(c("[[CRAN]]", "braju.com"))))
message("All CRAN related + BioC related repositories:")
str(as.list(parseRepos(c("[[CRAN]]", "[[BioC]]"))))
message("All BioC related + CRAN related repositories:")
str(as.list(parseRepos(c("[[BioC]]", "[[CRAN]]"))))
message("Mainstream (CRAN and BioC related) repositories (only):")
str(as.list(parseRepos("[[mainstream]]")))
message("An explicit repository URL:")
str(as.list(parseRepos("http://r-forge.r-project.org")))
message("An explicit repository URL + mainstream:")
str(as.list(parseRepos(c("http://r-forge.r-project.org", "[[mainstream]]"))))
message("Repositories according to option 'repos':")
str(as.list(parseRepos("[[current]]")))
message("All repositories known to this system:")
str(as.list(parseRepos("[[all]]")))
R.utils/tests/GString.R 0000644 0001762 0000144 00000007100 14372747611 014466 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# First example
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
who <- "world"
# Compare this...
cat(as.character(GString("Hello ${who}\n")))
# ...to this.
cat(GString("Hello ${who}\n"))
# Escaping
cat(as.character(GString("Hello \\\\${who}\n")))
# Printing
print(GString("Hello ${who}\n"))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Looping over vectors
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
x <- 1:5
y <- c("hello", "world")
cat(as.character(GString("(x,y)=(${x},${y})")), sep=", ")
cat("\n")
cat(as.character(GString("(x,y)=(${x},$[capitalize]{y})")), sep=", ")
cat("\n")
cat(as.character(GString("(x,y)=(${x},$[toupper]{y})")), sep=", ")
cat("\n")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Predefined ("builtin") variables
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat(as.character(GString("Hello ${username} on host ${hostname} running ",
"R v${rversion} in process #${pid} on ${os}. R is installed in ${rhome}.")))
# Other built-in variables/functions...
cat(as.character(GString("Current date: ${date}\n")))
cat(as.character(GString("Current date: $[format='%d/%m/%y']{date}\n")))
cat(as.character(GString("Current time: ${time}\n")))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluating inline R code
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat(as.character(GString("Simple calculation: 1+1=${`1+1`}\n")))
cat(as.character(GString("Alternative current date: ${`date()`}\n")))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Function values
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Call function rnorm with arguments n=1, i.e. rnorm(n=1)
cat(as.character(GString("Random normal number: $[n=1]{rnorm}\n")))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Global search-replace feature
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Replace all '-' with '.'
cat(as.character(GString("Current date: ${date/-/.}\n")))
# Another example
cat(as.character(GString("Escaped string: 12*12=${`12*12`/1/}\n")))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Defining new "builtin" function values
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Define your own builtin variables (functions)
setMethodS3("getBuiltinAletter", "GString", function(object, ...) {
base::letters[runif(1, min=1, max=length(base::letters))]
})
cat(as.character(GString("A letter: ${aletter}\n")))
cat(as.character(GString("Another letter: ${aletter}\n")))
# Another example
setMethodS3("getBuiltinGstring", "GString", function(object, ...) {
# Return another GString.
GString("${date} ${time}")
})
if (FALSE) {
cat(as.character(GString("Advanced example: ${gstring}\n")))
# Advanced example
setMethodS3("getBuiltinRunif", "GString", function(object, n=1, min=0, max=1, ...) {
formatC(runif(n=n, min=min, max=max), ...)
})
cat(as.character(GString("A random number: ${runif}\n")))
n <- 5
cat(as.character(GString("${n} random numbers: ")))
cat(as.character(GString("$[n=n, format='f']{runif}")))
cat("\n")
# Advanced options.
# Options are parsed as if they are elements in a list, e.g.
# list(n=runif(n=1,min=1,max=5), format='f')
cat(as.character(GString("$Random number of numbers: ")))
cat(as.character(GString("$[n=runif(n=1,min=1,max=5), format='f']{runif}")))
cat("\n")
} # if (FALSE)
R.utils/tests/getParent.R 0000644 0001762 0000144 00000000211 14372747611 015036 0 ustar ligges users library("R.utils")
path <- "C:/Users/JohnDoe/"
parent0 <- dirname(path)
parent <- getParent(path)
stopifnot(identical(parent, parent0))
R.utils/tests/withRepos.R 0000644 0001762 0000144 00000004200 14372747611 015073 0 ustar ligges users library("R.utils")
# Set new default repositories for this test
orepos <- options(repos=c(
CRAN="http://cran.r-project.org",
EXAMPLE="http://example.org"
))
message("Current repositories:")
str(as.list(getOption("repos")))
message("All current repositories:")
withRepos({
str(as.list(getOption("repos")))
})
message("All current repositories (explicit):")
withRepos({
str(as.list(getOption("repos")))
}, repos="[[current]]")
message("CRAN (only):")
withRepos({
str(as.list(getOption("repos")))
}, repos="CRAN")
message("braju.com (only):")
withRepos({
str(as.list(getOption("repos")))
}, repos="braju.com")
message("CRAN and braju.com (only):")
withRepos({
str(as.list(getOption("repos")))
}, repos=c("CRAN", "braju.com"))
message("braju.com and CRAN (only):")
withRepos({
str(as.list(getOption("repos")))
}, repos=c("braju.com", "CRAN"))
message("All CRAN replated repositories (only):")
withRepos({
str(as.list(getOption("repos")))
}, repos="[[CRAN]]")
message("Mainstream (CRAN and BioC related) repositories (only):")
withRepos({
str(as.list(getOption("repos")))
}, repos="[[mainstream]]")
message("braju.com and mainstream (only):")
withRepos({
str(as.list(getOption("repos")))
}, repos="[[braju.com]]")
message("R-Forge and mainstream (only):")
withRepos({
str(as.list(getOption("repos")))
}, repos="[[R-Forge]]")
message("An explicit repository URL:")
withRepos({
str(as.list(getOption("repos")))
}, repos="http://r-forge.r-project.org")
message("An explicit repository URL + mainstream:")
withRepos({
str(as.list(getOption("repos")))
}, repos=c("http://r-forge.r-project.org", "[[mainstream]]"))
message("All known:")
withRepos({
str(as.list(getOption("repos")))
}, repos="[[all]]")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Visibility
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
res <- withVisible({
withRepos({ 1 })
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(res$visible)
x <- 0
res <- withVisible({
withRepos({ x <- 1 })
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(!res$visible)
stopifnot(all.equal(x, 1))
# Undo
options(orepos)
R.utils/tests/withSeed.R 0000644 0001762 0000144 00000002130 14372747611 014663 0 ustar ligges users library("R.utils")
# Reset seed
if (exists(".Random.seed", envir=globalenv())) {
rm(list=".Random.seed", envir=globalenv())
}
# Generate a random number
y0 <- runif(1)
print(y0)
# Generate a random number using the same seed over and over
yp <- NULL
for (ii in 1:10) {
y <- withSeed({
runif(1)
}, seed=0x42)
print(y)
# Assert identical
if (!is.null(yp)) stopifnot(identical(y, yp))
yp <- y
}
# Generate a random number
y <- runif(1)
print(y)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Visibility
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
res <- withVisible({
withSeed({ 1 }, seed=42L)
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(res$visible)
x <- 0
res <- withVisible({
withSeed({ x <- 1 }, seed=42L)
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(!res$visible)
stopifnot(all.equal(x, 1))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# With RNG state reset
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
res <- withSeed(sample.int(100L, size=1L), seed=NULL)
R.utils/tests/filePath.R 0000644 0001762 0000144 00000001676 14372747611 014661 0 ustar ligges users library("R.utils")
assertEqual <- function(a, b) {
a <- gsub("\\", "/", a, fixed=TRUE)
b <- gsub("\\", "/", b, fixed=TRUE)
if (a != b) {
throw("The two paths/pathnames differ: ", sQuote(a), " != ", sQuote(b))
}
} # assertEqual()
path <- file.path("foo", "bar", "..", "name")
assertEqual(path, "foo/bar/../name")
path <- filePath("foo", "bar", "..", "name")
assertEqual(path, "foo/name")
path <- filePath("foo/bar/../name")
assertEqual(path, "foo/name")
path <- filePath(".")
assertEqual(path, ".")
path <- filePath("..")
assertEqual(path, "..")
path <- filePath("../..")
assertEqual(path, "../..")
path <- filePath("./.")
assertEqual(path, ".")
path <- filePath(".", ".")
assertEqual(path, ".")
path <- filePath(".", "..")
assertEqual(path, "..")
path <- filePath("C:/foo/..")
assertEqual(path, "C:/")
path <- filePath("/tmp/../../..")
assertEqual(path, "/../..")
path <- filePath("C:/../../..")
assertEqual(path, "C:/../../..")
R.utils/tests/use.R 0000644 0001762 0000144 00000001230 14372747611 013703 0 ustar ligges users library("R.utils")
# Use with one package
use("tools", how="load")
# Use with one package
use("tools")
# Use with multiple packages
use(c("tools", "graphics"))
use("tools, graphics")
use(c("tools, graphics", "grDevices"))
# Use with version constraint
use("tools", version="(>= 2.5.0)")
use("tools (>= 2.5.0)")
# Use with multiple packages and version constraints
use(c("tools", "graphics"), version=c("(>= 2.5.0)", "(>= 2.5.0)"))
use("tools, graphics", version="(>= 2.5.0), (>= 2.5.0)")
use("tools (>= 2.5.0), graphics (>= 2.5.0)")
# Exception should be visible
tryCatch({
use("NonExistingPackage", install=FALSE)
}, error = function(ex) {
print(ex)
})
R.utils/tests/readWindowsShortcut.R 0000644 0001762 0000144 00000000563 14372747611 017141 0 ustar ligges users library("R.utils")
pathname <- system.file("data-ex/HISTORY.LNK", package="R.utils")
lnk <- readWindowsShortcut(pathname, verbose=TRUE)
# Print all information
print(lnk)
# Get the relative path to the target file
history <- file.path(dirname(pathname), lnk$relativePath)
# Alternatively, everything in one call
history <- filePath(pathname, expandLinks="relative")
R.utils/tests/dimNA.R 0000644 0001762 0000144 00000000417 14372747611 014105 0 ustar ligges users library("R.utils")
x <- 1:12
dimNA(x) <- c(2,NA_real_,3)
stopifnot(dim(x) == as.integer(c(2,2,3)))
dimNA(x) <- NULL
stopifnot(is.null(dim(x)))
## Exception handling
x <- 1:12
res <- try(dimNA(x) <- c(4,NA_real_,4), silent=TRUE)
stopifnot(inherits(res, "try-error"))
R.utils/tests/withCapture.R 0000644 0001762 0000144 00000005734 14372747611 015423 0 ustar ligges users library("R.utils")
oopts <- options(prompt = "> ")
print(withCapture({
n <- 3
n
for (kk in 1:3) {
printf("Iteration #%d\n", kk)
}
print(Sys.time())
type <- "horse"
type
}))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Assert correct capture of code and output
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
bfr <- withCapture({
x <- 1
x
}, newline=TRUE)
print(bfr)
stopifnot(bfr == "> x <- 1\n> x\n[1] 1\n")
bfr <- withCapture({
x <- 1
x
}, code=TRUE, output=FALSE, newline=TRUE)
print(bfr)
stopifnot(bfr == "> x <- 1\n> x\n")
bfr <- withCapture({
x <- 1
x
}, code=FALSE, output=TRUE, newline=TRUE)
print(bfr)
stopifnot(bfr == "[1] 1\n")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Fixed substitutions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
bfr <- withCapture({ x <- a }, replace=list(a="abc"))
print(bfr)
stopifnot(bfr == '> x <- "abc"\n')
res <- tryCatch({
withCapture({ x <- a }, substitute=list(a="abc"))
}, error = identity)
stopifnot(inherits(res, "error"))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# With automatic variable substitute
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
a <- 2
bfr <- withCapture({
x <- .a.
x
}, newline=TRUE)
print(bfr)
stopifnot(bfr == "> x <- 2\n> x\n[1] 2\n")
# Make sure not to substitute parts of variable names
# or expressions
foo.bar.yaa <- function(x) x
a <- 2
b.c <- 3
bfr <- withCapture({
res <- foo.bar.yaa(3.14)
R.utils::use("R.utils")
x <- .a.
y <- .b.c.
})
print(bfr)
## ODD: Different results when sourcing and R CMD check:ing
## this test script. /HB 2014-08-12
## stopifnot(bfr ==""> res <- foo.bar.yaa(3.14)\n> R.utils::use(\"R.utils\")\n> x <- 2\n> y <- 3\n")
# Make sure '...' is not substituted
bfr <- withCapture({
benchmark <- function(fcn, n, len=100L, ...) {
x <- lineBuffer(n, len=len, ...)
foo(...)
system.time({
fcn(cat(x))
}, gcFirst=TRUE)[[3]]
} # benchmark()
})
print(bfr)
## ODD: Different results when sourcing and R CMD check:ing
## this test script. /HB 2014-08-12
## stopifnot(bfr == "> benchmark <- function(fcn, n, len = 100L, ...) {\n+ x <- lineBuffer(n, len = len, ...)\n+ foo(...)\n+ system.time({\n+ fcn(cat(x))\n+ }, gcFirst = TRUE)[[3]]\n+ }\n")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# BUG TEST: if-else statements
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
bfr <- withCapture(if (TRUE) 1 else 2)
print(bfr)
stopifnot(bfr == "> if (TRUE) 1 else 2\n[1] 1\n")
bfr <- withCapture({if (TRUE) 1 else 2 })
print(bfr)
## ODD: Different results when sourcing and R CMD check:ing
## this test script. /HB 2014-08-12
## stopifnot(bfr == "> if (TRUE) \n+ 1 else 2\n[1] 1\n")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Empty
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
bfr <- withCapture({})
print(bfr)
stopifnot(length(bfr) == 0L)
options(oopts)
R.utils/tests/toCamelCase.R 0000644 0001762 0000144 00000003164 14372747611 015277 0 ustar ligges users library("R.utils")
strings <- list(
"",
"hello world" = c("helloWorld", "HelloWorld", "helloWorld", "HelloWorld"),
"tcn start" = c("tcnStart", "TcnStart", "tcnStart", "TcnStart"),
"GEO Accession" = c("gEOAccession", "GEOAccession", "geoAccession", "GEOAccession")
)
for (s in names(strings)) {
printf("Original: %s\n", sQuote(s))
y <- toCamelCase(s)
printf("Camel case: %s\n", sQuote(y))
stopifnot(y == strings[[s]][1L])
y <- toCamelCase(s, capitalize=TRUE)
printf("Capitalized camel case: %s\n", sQuote(y))
stopifnot(y == strings[[s]][2L])
y <- toCamelCase(s, preserveSameCase=TRUE)
printf("Capitalized camel case without same case preserved: %s\n", sQuote(y))
stopifnot(y == strings[[s]][3L])
y <- toCamelCase(s, capitalize=TRUE, preserveSameCase=TRUE)
printf("Capitalized camel case with same case preserved: %s\n", sQuote(y))
stopifnot(y == strings[[s]][4L])
cat("\n")
}
# Vectorized
s <- names(strings)
y <- toCamelCase(s)
stopifnot(length(y) == length(s))
y0 <- sapply(strings, FUN=function(s) s[1L])
stopifnot(all(y == y0))
# Empty vector
y <- toCamelCase(character(0L))
stopifnot(length(y) == 0L)
y <- toCamelCase(NULL)
stopifnot(length(y) == 0L)
# Missing values
for (preserveSameCase in c(FALSE, TRUE)) {
y <- toCamelCase(NA_character_, preserveSameCase=preserveSameCase)
stopifnot(is.na(y))
y <- toCamelCase(c(NA_character_, NA_character_), preserveSameCase=preserveSameCase)
stopifnot(all(is.na(y)))
y <- toCamelCase(c(NA_character_, "hello world", NA_character_), preserveSameCase=preserveSameCase)
stopifnot(identical(y, c(NA_character_, "helloWorld", NA_character_)))
}
R.utils/tests/displayCode.R 0000644 0001762 0000144 00000002001 14372747611 015344 0 ustar ligges users library("R.utils")
opager <- options(pager=mpager)
file <- system.file("DESCRIPTION", package="R.utils")
cat("Displaying: ", file, ":\n", sep="")
displayCode(file)
file <- system.file("NEWS.md", package="R.utils")
cat("Displaying: ", file, ":\n", sep="")
displayCode(file, numerate=FALSE, lines=100:110, wrap=65)
file <- system.file("NEWS.md", package="R.utils")
cat("Displaying: ", file, ":\n", sep="")
displayCode(file, lines=100:110, wrap=65, highlight=c(101,104:108))
con <- file(file)
displayCode(con, lines=1:10)
displayCode(file, lines=1:10, pager=mpager)
displayCode(file, lines=1:10, pager="mpager")
## Exception handling
res <- try(displayCode(file, lines=-10:110), silent=TRUE)
stopifnot(inherits(res, "try-error"))
res <- try(displayCode(file, wrap=integer(0)), silent=TRUE)
stopifnot(inherits(res, "try-error"))
res <- try(displayCode(file, wrap=55:66), silent=TRUE)
stopifnot(inherits(res, "try-error"))
res <- try(displayCode(2L), silent=TRUE)
stopifnot(inherits(res, "try-error"))
options(opager)
R.utils/tests/egsub.R 0000644 0001762 0000144 00000001731 14372747611 014222 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# A symbol
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
x <- 1L
y <- 2L
symb <- as.symbol("x")
print(symb)
expr <- egsub("x", "y", symb, value=FALSE)
print(expr)
expr2 <- egsub("x", "y", symb, value=TRUE)
print(expr2)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Missing expression
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
expr <- expression(x[,1])
print(expr)
expr2 <- egsub("foo", "bar", expr)
print(expr2)
stopifnot(identical(expr2, expr))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# NULLs in expression
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# An expression containing a function definition for a
# function without arguments.
expr <- substitute(y <- function() 0)
print(expr)
# Don't replace anything
expr2 <- egsub("x", "x", expr)
print(expr2)
stopifnot(identical(expr2, expr))
R.utils/tests/withSink.R 0000644 0001762 0000144 00000003361 14372747611 014716 0 ustar ligges users library("R.utils")
mfile <- function(file, ...) {
mprintf("\n%s:\n", file)
mcat("-------------------------------------------------\n")
mcat(readLines(pathname), sep="\n")
mcat("-------------------------------------------------\n")
} # mfile()
# Display warnings as they occur
oopts <- options(warn=1L)
cons0 <- showConnections()
# Divert standard output
pathname <- tempfile(fileext=".output.txt")
mprint(pathname)
res <- withSink(file=pathname, {
print(letters)
NULL
})
mfile(pathname)
mprint(warnings())
# Divert standard error/messages
pathname <- tempfile(fileext=".message.txt")
mprint(pathname)
res <- withSink(file=pathname, type="message", {
mprint(letters)
NULL
})
mfile(pathname)
mprint(warnings())
# Divert standard output (and make sure to close any other sinks opened)
pathname <- tempfile(fileext=".output2.txt")
mprint(pathname)
res <- withSink(file=pathname, {
print(letters)
pathnameT <- tempfile(fileext=".output3.txt")
sink(pathnameT, type="output")
print(LETTERS)
mstr(1:10)
}, append=TRUE)
mfile(pathname)
mprint(warnings())
# Assert that all connections opened were closed
cons1 <- showConnections()
mprint(cons0)
mprint(cons1)
stopifnot(all.equal(cons1, cons0))
# Reset how warnings are displayed
options(oopts)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Visibility
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
pathname <- tempfile(fileext=".output.txt")
res <- withVisible({
withSink({ print(1); 1 }, file=pathname)
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(res$visible)
x <- 0
res <- withVisible({
withSink({ print(1); x <- 1 }, file=pathname)
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(!res$visible)
stopifnot(all.equal(x, 1))
R.utils/tests/attachLocally.R 0000644 0001762 0000144 00000001531 14372747611 015677 0 ustar ligges users library("R.utils")
# A named list
x <- list(a=1, b=base::letters)
keys <- attachLocally(x)
stopifnot(identical(keys, names(x)))
for (key in keys) stopifnot(identical(get(key), x[[key]]))
# A list with "empty" names
x <- list(a=1, b=base::letters, "noname", "another one")
keys <- attachLocally(x)
stopifnot(identical(keys, setdiff(names(x), "")))
for (key in keys) stopifnot(identical(get(key), x[[key]]))
# An environment
x <- list(a=1, b=base::letters)
env <- list2env(x)
stopifnot(identical(ls(envir=env), names(x)))
keys <- attachLocally(env)
stopifnot(identical(keys, ls(envir=env)))
for (key in keys) stopifnot(identical(get(key), env[[key]]))
# A data.frame
df <- data.frame(a=1, b=base::letters, stringsAsFactors=FALSE)
keys <- attachLocally(df)
stopifnot(identical(keys, names(df)))
for (key in keys) stopifnot(identical(get(key), df[[key]]))
R.utils/tests/gcDLLs.R 0000644 0001762 0000144 00000000311 14372747611 014216 0 ustar ligges users library("R.utils")
message("*** getDLLs() ...")
dlls <- strayDLLs()
print(dlls)
dlls <- gcDLLs(quiet = TRUE)
print(dlls)
dlls <- gcDLLs(quiet = FALSE)
print(dlls)
message("*** getDLLs() ... DONE") R.utils/tests/extract.array.R 0000644 0001762 0000144 00000002600 14372747611 015700 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Example using an array with a random number of dimensions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
maxdim <- 4
dim <- sample(3:maxdim, size=sample(2:maxdim, size=1), replace=TRUE)
ndim <- length(dim)
dimnames <- list()
for (kk in 1:ndim)
dimnames[[kk]] <- sprintf("%s%d", letters[kk], 1:dim[kk])
x <- 1:prod(dim)
x <- array(x, dim=dim, dimnames=dimnames)
cat("\nArray 'x':\n")
print(x)
cat("\nExtract 'x[2:3,...]':\n")
print(extract(x, "1"=2:3))
cat("\nExtract 'x[3,2:3,...]':\n")
print(extract(x, "1"=3,"2"=2:3))
cat("\nExtract 'x[...,2:3]':\n")
print(extract(x, indices=2:3, dims=length(dim(x))))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Assertions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
y <- array(1:24, dim=c(2,3,4))
yA <- y[,,2:3]
yB <- extract(y, indices=list(2:3), dims=length(dim(y)))
stopifnot(identical(yB, yA))
yA <- y[,2:3,2]
yB <- extract(y, indices=list(2:3,2), dims=c(2,3), drop=TRUE)
stopifnot(identical(yB, yA))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Matrix
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
y <- matrix(1:24, nrow=6, ncol=4)
yA <- y[,2:3]
yB <- extract(y, indices=list(2:3), dims=length(dim(y)))
stopifnot(identical(yB, yA))
R.utils/tests/touchFile.R 0000644 0001762 0000144 00000001661 14372747611 015041 0 ustar ligges users library("R.utils")
# Create files
pathnames <- sapply(1:3, FUN=function(x) {
pathname <- tempfile()
cat(file=pathname, "Hello world!")
pathname
})
# Record checksums
md5a <- sapply(pathnames, FUN=digest::digest, file=TRUE)
# Record current time stamps
ta <- file.info(pathnames)$mtime
print(ta)
# Wait a bit...
Sys.sleep(1.2)
# Touch zero files
stopifnot(is.null(touchFile(NULL)))
stopifnot(is.null(touchFile(character(0L))))
# Touch multiple files
ta0 <- touchFile(pathnames)
tb <- file.info(pathnames)$mtime
print(tb)
# Verify return value
stopifnot(identical(ta0, ta))
# Verify that the timestamps got updated
stopifnot(tb > ta)
# Touch a single file
ta0 <- touchFile(pathnames[2L])
tb <- file.info(pathnames[2L])$mtime
print(tb)
# Verify that the timestamps got updated
stopifnot(tb > ta[2L])
# Verify that the content did not change
md5b <- sapply(pathnames, FUN=digest::digest, file=TRUE)
stopifnot(identical(md5a, md5b))
R.utils/tests/callHooks.R 0000644 0001762 0000144 00000003242 14372747611 015033 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Example 1
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# First, clean up if called more than once
setHook("myFunction.onEnter", NULL, action="replace")
setHook("myFunction.onExit", NULL, action="replace")
runConference <- function(...) {
callHooks("myFunction.onEnter")
cat("Speaker A: Hello there...\n")
callHooks("myFunction.onExit")
}
setHook("myFunction.onEnter", function(...) {
cat("Chair: Welcome to our conference.\n")
})
setHook("myFunction.onEnter", function(...) {
cat("Chair: Please welcome Speaker A!\n")
})
setHook("myFunction.onExit", function(...) {
cat("Chair: Please thanks Speaker A!\n")
})
runConference()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Example 2
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
setHook("randomNumber", NULL, action="replace")
setHook("randomNumber", rnorm) # By function
setHook("randomNumber", "rexp") # By name
setHook("randomNumber", "runiff") # Non-existing name
setHook("randomNumber", .GlobalEnv) # Not a function
res <- callHooks("randomNumber", n=1, removeCalledHooks=TRUE)
str(res)
cat("Number of hooks: ", length(res), "\n")
isErroneous <- unlist(lapply(res, FUN=function(x) !is.null(x$exception)))
cat("Erroneous hooks: ", sum(isErroneous), "\n")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Exception handling
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
res <- try(callHooks(character(0L)), silent=TRUE)
stopifnot(inherits(res, "try-error"))
res <- try(callHooks(c("a", "b")), silent=TRUE)
stopifnot(inherits(res, "try-error"))
R.utils/tests/withOptions.R 0000644 0001762 0000144 00000002611 14372747611 015442 0 ustar ligges users library("R.utils")
oopts <- options()
digits <- getOption("digits")
print(pi)
# Same, i.e. using default
withOptions({
print(pi)
stopifnot(getOption("digits") == digits)
})
# Printing with two digits
withOptions({
print(pi)
stopifnot(getOption("digits") == 2)
}, digits=2)
# Printing with two digits then with three more
withOptions({
print(pi)
withOptions({
print(pi)
stopifnot(getOption("digits") == 5)
}, digits=getOption("digits")+3)
stopifnot(getOption("digits")+3 == 5)
}, digits=2)
# Still printing with the default
print(pi)
stopifnot(getOption("digits") == digits)
# Reset also options set inside call
options(dummy=NULL)
withOptions({
print(pi)
options(digits=1L)
print(pi)
stopifnot(getOption("digits") == 1L)
options(dummy="Hello")
print(getOption("dummy"))
})
stopifnot(is.null(getOption("dummy")))
# Any modified or added option is undone
stopifnot(all.equal(options(), oopts))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Visibility
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
digits <- getOption("digits")+1L
res <- withVisible({
withOptions({ 1 }, digits=digits)
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(res$visible)
x <- 0
res <- withVisible({
withOptions({ x <- 1 }, digits=digits)
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(!res$visible)
stopifnot(all.equal(x, 1))
R.utils/tests/cout.R 0000644 0001762 0000144 00000002536 14372747611 014073 0 ustar ligges users library("R.utils")
show <- methods::show
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# General tests
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
x <- letters[1:8]
x2 <- c(x[-1], "\n")
x3 <- x2[-1]
y <- as.list(x[1:3])
cat("mprint():\n")
print(x)
cprint(x)
print(y)
cprint(y)
cat("mcat():\n")
cat(x, "\n")
ccat(x, "\n")
cat(x2)
ccat(x2)
cat(x3, sep=",")
ccat(x3, sep=",")
cat(x3, sep="\n")
ccat(x3, sep="\n")
cat("mstr():\n")
str(x)
cstr(x)
str(y)
cstr(y)
cat("mshow():\n")
show(x)
cshow(x)
show(y)
cshow(y)
cat("mprintf():\n")
printf("x=%d\n", 1:3)
cprintf("x=%d\n", 1:3)
cat("mout():\n")
writeLines(x)
cout(writeLines(x))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Tests related to closure
# - - - - - - - - - - - -- - - - - - - - - - - - - - - - - -
cfoo <- function(a=1) {
cprintf("a=%s\n", a)
}
cbar <- function(...) {
cfoo(...)
}
a <- 2
cfoo(a)
cfoo(3)
cbar(a)
cbar(3)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Assert that "console" messages cannot be captured/sunk
# via neither stdout nor stderr
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
res <- captureOutput({ ccat("Hello") })
str(res)
stopifnot(length(res) == 0L)
withSink({ ccat("Hello") }, file="foo.txt", type="message")
res <- readLines("foo.txt")
str(res)
stopifnot(length(res) == 0L)
R.utils/tests/nullfile.R 0000644 0001762 0000144 00000000045 14372747611 014724 0 ustar ligges users library("R.utils")
print(nullfile())
R.utils/tests/resample.R 0000644 0001762 0000144 00000000235 14372747611 014723 0 ustar ligges users library("R.utils")
x <- 1:5
y <- resample(x)
print(y)
stopifnot(length(y) == length(x))
x <- 5
y <- resample(x)
print(y)
stopifnot(length(y) == length(x))
R.utils/tests/seqToHumanReadable.R 0000644 0001762 0000144 00000001574 14372747611 016626 0 ustar ligges users library("R.utils")
## Empty
s <- seqToHumanReadable(integer(0L))
print(s)
stopifnot(s == "")
## Single
s <- seqToHumanReadable(0L)
print(s)
stopifnot(s == "0")
## Duplicates
s <- seqToHumanReadable(c(1:2, 1:2))
print(s)
stopifnot(s == "1, 2")
## Two
s <- seqToHumanReadable(1:2)
print(s)
stopifnot(s == "1, 2")
## Two
s <- seqToHumanReadable(c(1, 3))
print(s)
stopifnot(s == "1, 3")
## A few subsets
x <- c(1:3, 5:8, 15, 21:20, 25:26)
s <- seqToHumanReadable(x)
print(s)
stopifnot(s == "1-3, 5-8, 15, 20, 21, 25, 26")
## Other delimiters
s <- seqToHumanReadable(x, delimiter=":", collapse="; ")
print(s)
stopifnot(s == "1:3; 5:8; 15; 20; 21; 25; 26")
## Display 1:2 as 1-2
s <- seqToHumanReadable(x, tau=1L)
print(s)
stopifnot(s == "1-3, 5-8, 15, 20-21, 25-26")
## Display 1:3 as 1, 2, 3
s <- seqToHumanReadable(x, tau=3L)
print(s)
stopifnot(s == "1, 2, 3, 5-8, 15, 20, 21, 25, 26")
R.utils/tests/hpaste.R 0000644 0001762 0000144 00000004146 14372747611 014404 0 ustar ligges users library("R.utils")
# Some vectors
x <- 1:6
y <- 10:1
z <- LETTERS[x]
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Abbreviation of output vector
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
printf("x = %s.\n", hpaste(x))
## x = 1, 2, 3, ..., 6.
printf("x = %s.\n", hpaste(x, maxHead=2))
## x = 1, 2, ..., 6.
printf("x = %s.\n", hpaste(x, maxHead=3)) # Default
## x = 1, 2, 3, ..., 6.
# It will never output 1, 2, 3, 4, ..., 6
printf("x = %s.\n", hpaste(x, maxHead=4))
## x = 1, 2, 3, 4, 5 and 6.
# Showing the tail
printf("x = %s.\n", hpaste(x, maxHead=1, maxTail=2))
## x = 1, ..., 5, 6.
# Turning off abbreviation
printf("y = %s.\n", hpaste(y, maxHead=Inf))
## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
## ...or simply
printf("y = %s.\n", paste(y, collapse=", "))
## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Adding a special separator before the last element
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Change last separator
printf("x = %s.\n", hpaste(x, lastCollapse=" and "))
## x = 1, 2, 3, 4, 5 and 6.
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Empty input
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
s <- hpaste(integer(0))
stopifnot(identical(s, character(0L)))
s <- hpaste(integer(0), empty = "")
stopifnot(identical(s, ""))
s <- hpaste(integer(0), empty = NA_character_)
stopifnot(identical(s, NA_character_))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Backward compatibility with paste()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
s1 <- hpaste(x, maxHead=Inf)
s2 <- paste(x, collapse=", ")
printf("s = %s.\n", s1)
stopifnot(identical(s1, s2))
s1 <- hpaste('<', x, '>', maxHead=Inf)
s2 <- paste('<', x, '>', sep="", collapse=", ")
printf("s = %s.\n", s1)
stopifnot(identical(s1, s2))
s1 <- hpaste(x, y, z, sep="/", maxHead=Inf)
s2 <- paste(x, y, z, sep="/", collapse=", ")
printf("s = %s.\n", s1)
stopifnot(identical(s1, s2))
s1 <- hpaste(x, collapse=NULL, maxHead=Inf)
s2 <- paste(x, collapse=NULL)
stopifnot(identical(s1, s2))
R.utils/tests/absolute-relative-paths.R 0000644 0001762 0000144 00000004672 14526006463 017662 0 ustar ligges users library("R.utils")
warnifnot <- egsub("stop", "warning", stopifnot, value=FALSE)
message("Absolute and relative paths ...")
message("- Absolute and relative path of getwd()")
stopifnot(identical(getAbsolutePath("."), getwd()))
stopifnot(identical(getRelativePath("."), "."))
message("- Tilde expansion")
pathH0 <- normalizePath("~")
print(pathH0)
pathH <- normalizePath("~", winslash = "/")
print(pathH)
pathHA <- getAbsolutePath(pathH)
print(pathHA)
pathA <- getAbsolutePath("~", expandTilde=TRUE)
print(pathA)
warnifnot(identical(tolower(pathA), tolower(pathH)))
pathR <- getRelativePath("~")
print(pathR)
warnifnot(identical(tolower(getAbsolutePath(pathR)), tolower(pathH)))
pathR <- getRelativePath("~", caseSensitive=TRUE)
print(pathR)
message("- ~/../Documents")
pathA <- getAbsolutePath("~/../Documents", expandTilde=TRUE)
pathA0 <- file.path(getParent(pathH), "Documents")
## Account for the case when getParent(pathH) = "C:/", which in case
## we get C://Documents instead of C:/Documents
pathA0 <- normalizePath(pathA0, winslash = "/")
utils::str(list(pathA = pathA, pathA0 = pathA0))
stopifnot(pathA == pathA0)
message("- /tmp/")
pathA <- getAbsolutePath("/tmp/", expandTilde=TRUE)
print(pathA)
stopifnot(identical(pathA, "/tmp"))
message("- Microsoft Windows UNC paths")
stopifnot(identical(getAbsolutePath("//vinata/biomed"), "//vinata/biomed"))
stopifnot(identical(getAbsolutePath("//vinata///biomed"), "//vinata/biomed"))
message("- Vector of files")
paths <- c(".", "..", getwd())
print(paths)
pathsA <- getAbsolutePath(paths)
print(pathsA)
pathsR <- getRelativePath(paths)
print(pathsR)
pathsAR <- getRelativePath(pathsA)
print(pathsAR)
pathsRA <- getAbsolutePath(pathsR)
print(pathsRA)
# Sanity checks
stopifnot(all(isAbsolutePath(pathsA)))
stopifnot(all(!isAbsolutePath(pathsR)))
stopifnot(all(pathsRA == pathsA))
stopifnot(all(pathsAR == pathsR))
message("- Paths relative to given directories")
stopifnot(getRelativePath("foo", "foo") == ".")
stopifnot(getRelativePath("foo/bar", "foo") == "bar")
stopifnot(getRelativePath("foo/bar", "foo/bar/yah") == "..")
stopifnot(getRelativePath("foo/bar/cool", "foo/bar/yah/sub/") == "../../cool")
stopifnot(getRelativePath("/tmp/foo/", "/tmp/") == "foo")
stopifnot(getRelativePath("/tmp/bar/", "/bar/foo/") == "../../tmp/bar")
stopifnot(getRelativePath("C:/foo/bar/", "C:/bar/") == "../foo/bar")
stopifnot(getRelativePath("C:/foo/bar/", "D:/bar/") == "C:/foo/bar")
message("Absolute and relative paths ... DONE")
R.utils/tests/pushBackupFile.R 0000644 0001762 0000144 00000001661 14372747611 016024 0 ustar ligges users library("R.utils")
# Create a file
pathname <- "foobar.txt"
cat(file=pathname, "File v1\n")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# (a) Backup and restore a file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Turn it into a backup file
pathnameB <- pushBackupFile(pathname, verbose=TRUE)
print(pathnameB)
# Restore main file from backup
pathnameR <- popBackupFile(pathnameB, verbose=TRUE)
print(pathnameR)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# (b) Backup, create a new file and frop backup file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Turn it into a backup file
pathnameB <- pushBackupFile(pathname, verbose=TRUE)
print(pathnameB)
# Create a new file
cat(file=pathname, "File v2\n")
# Drop backup because a new main file was successfully created
pathnameR <- popBackupFile(pathnameB, verbose=TRUE)
print(pathnameR)
file.remove(pathname)
R.utils/tests/findFiles.R 0000644 0001762 0000144 00000002211 14372747611 015012 0 ustar ligges users message("Testing findFiles()...")
library("R.utils")
path <- system.file(".", package="R.utils")
pathname <- findFiles(paths=path, firstOnly=TRUE)
print(pathname)
pathnames <- findFiles(paths=path, firstOnly=FALSE)
str(pathnames)
pathnames <- findFiles(paths=path, recursive=TRUE, firstOnly=FALSE)
str(pathnames)
pathnames <- findFiles(pattern="[.]rds$", paths=path, recursive=TRUE, firstOnly=FALSE)
str(pathnames)
## Recursive searching
pathnames0 <- findFiles(paths=path, recursive=FALSE, firstOnly=FALSE)
str(pathnames)
pathnames <- findFiles(paths=path, recursive=0L, firstOnly=FALSE)
str(pathnames)
stopifnot(identical(pathnames, pathnames0))
pathnamesInf <- findFiles(paths=path, recursive=TRUE, firstOnly=FALSE)
str(pathnamesInf)
stopifnot(length(pathnamesInf) >= length(pathnames0))
pathnames <- findFiles(paths=path, recursive=+Inf, firstOnly=FALSE)
str(pathnames)
stopifnot(identical(pathnames, pathnamesInf))
pathnames2 <- findFiles(paths=path, recursive=2L, firstOnly=FALSE)
str(pathnames2)
stopifnot(length(pathnames2) >= length(pathnames0))
stopifnot(length(pathnames2) <= length(pathnamesInf))
message("Testing findFiles()...DONE")
R.utils/tests/loadObject.R 0000644 0001762 0000144 00000001351 14372747611 015161 0 ustar ligges users library("R.utils")
x <- 1:10
str(x)
file <- tempfile(fileext="")
file1 <- saveObject(x, file=file)
print(file1)
x1 <- loadObject(file1)
str(x1)
stopifnot(all.equal(x1, x))
file.remove(file1)
file2 <- saveObject(x, file=sprintf("%s.xdr", file))
print(file2)
x2 <- loadObject(file2)
str(x2)
stopifnot(all.equal(x2, x))
file.remove(file2)
file3 <- saveObject(x, file=sprintf("%s.rds", file))
print(file3)
x3 <- loadObject(file3, format="rds")
str(x3)
stopifnot(all.equal(x3, x))
file.remove(file3)
file4 <- saveObject(x, file=sprintf("%s.Rbin", file))
print(file4)
x4 <- loadObject(file4)
str(x4)
stopifnot(all.equal(x4, x))
file.remove(file4)
if (isPackageInstalled("digest")) {
file <- saveObject(x)
print(file)
file.remove(file)
}
R.utils/tests/Java.R 0000644 0001762 0000144 00000003632 14372747611 014000 0 ustar ligges users library("R.utils")
pathname <- tempfile()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Writing
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Open the temporary file for writing
out <- file(pathname, open="wb")
b <- -128:127
Java$writeByte(out, b)
s <- -32768:32767
Java$writeShort(out, s)
i <- c(-2147483648, -2147483647, -1, 0, +1, 2147483646, 2147483647)
Java$writeInt(out, i)
str <- c("This R string was written (using the UTF-8 format) using",
"the static methods of the Java class in the R.utils package.")
str <- paste(str, collapse="\n")
Java$writeUTF(out, str)
close(out)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Reading
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
for (as.character in c(TRUE, FALSE)) {
# Open the temporary file for reading
inn <- file(pathname, open="rb")
bfr <- Java$readByte(inn, n=length(b))
cat("Read ", length(bfr), " bytes.\n", sep="")
if (!identical(bfr, b))
throw("Failed to read the same data that was written.")
bfr <- Java$readShort(inn, n=length(s))
cat("Read ", length(bfr), " shorts.\n", sep="")
if (!identical(bfr, s))
throw("Failed to read the same data that was written.")
bfr <- Java$readInt(inn, n=length(i))
cat("Read ", length(bfr), " ints.\n", sep="")
if (!identical(bfr, i))
throw("Failed to read the same data that was written.")
bfr <- Java$readUTF(inn, as.character=TRUE)
if (is.character(bfr)) {
cat("Read ", nchar(bfr), " UTF characters:\n", "'", bfr, "'\n", sep="")
} else {
cat("Read ", length(bfr), " UTF character bytes:\n", "'", hpaste(bfr), "'\n", sep="")
}
# Trying to read more when there isn't anything else available
bfr <- Java$readUTF(inn, as.character=FALSE)
cat("Read ", length(bfr), " UTF character bytes:\n", "'", hpaste(bfr), "'\n", sep="")
close(inn)
} # for (as.character ...)
file.remove(pathname)
R.utils/tests/MultiVerbose.R 0000644 0001762 0000144 00000002263 14372747611 015536 0 ustar ligges users library("R.utils")
# Output to both standard output and to log file
stdoutLog <- Verbose(threshold=-1)
fileLog <- Verbose("foo.log", threshold=-1)
verbose <- MultiVerbose(list(stdoutLog, fileLog), threshold=-1)
header(verbose, "A verbose writer example", padding=0)
enter(verbose, "Analysis A")
for (kk in 1:10) {
printf(verbose, "step %d\n", kk)
if (kk == 2) {
cat(verbose, "Turning ON automatic timestamps")
timestampOn(verbose)
} else if (kk == 4) {
timestampOff(verbose)
cat(verbose, "Turned OFF automatic timestamps")
cat(verbose, "Turning OFF verbose messages for steps ", kk, "-6")
off(verbose)
} else if (kk == 6) {
on(verbose)
cat(verbose, "Turned ON verbose messages just before step ", kk+1)
}
if (kk %in% c(5,8)) {
enter(verbose, "Sub analysis ", kk)
for (jj in c("i", "ii", "iii")) {
cat(verbose, "part ", jj)
}
exit(verbose)
}
}
cat(verbose, "All steps completed!")
exit(verbose)
ruler(verbose)
cat(verbose, "Demo of some other methods:")
str(verbose, c(a=1, b=2, c=3))
print(verbose, c(a=1, b=2, c=3))
summary(verbose, c(a=1, b=2, c=3))
evaluate(verbose, rnorm, n=3, mean=2, sd=3)
ruler(verbose)
newline(verbose)
R.utils/tests/mkdirs.R 0000644 0001762 0000144 00000004201 14372747611 014401 0 ustar ligges users library("R.utils")
message("*** mkdirs() ...")
message("*** mkdirs(..., recursive=TRUE) ...")
pathT <- tempdir()
mprint(pathT)
stopifnot(isDirectory(pathT))
path <- file.path(pathT, "foo", "bar")
mprint(path)
mkdirs(path)
stopifnot(isDirectory(path))
paths <- c(dirname(path), path)
stopifnot(all(isDirectory(paths)))
path <- dirname(path)
removeDirectory(path, recursive=TRUE)
stopifnot(!isDirectory(path))
message("*** mkdirs(..., recursive=TRUE) ... DONE")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# EXCEPTIONS
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
message("*** mkdirs(..., mustWork=TRUE) ...")
path <- file.path(pathT, "foo")
res <- mkdirs(path)
stopifnot(isDirectory(path))
## Create file with same name
pathname <- file.path(path, "bar")
cat("Hello", file=pathname)
stopifnot(isFile(pathname))
res <- mkdirs(pathname)
stopifnot(isFile(pathname), !isDirectory(pathname))
res <- try(mkdirs(pathname, mustWork=TRUE), silent=TRUE)
cat(res)
stopifnot(inherits(res, "try-error"))
stopifnot(isFile(pathname), !isDirectory(pathname))
## Parent is a file, not a directory
path2 <- file.path(path, "bar", "yaa")
res <- try(mkdirs(path2, mustWork=TRUE), silent=TRUE)
cat(res)
stopifnot(inherits(res, "try-error"))
stopifnot(!isDirectory(path2))
removeDirectory(path, recursive=TRUE)
stopifnot(!isDirectory(path))
message("*** mkdirs(..., mustWork=TRUE) ... DONE")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# SPECIAL:
# Windows has a undocumented "feature" that for some set
# ups on some machines (not all) it will for instance
# silently drop a trailing period and create the directory
# without it, e.g. 'G.S.' becomes 'G.S', cf.help("dir.create").
# See also https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=15996
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
message("*** mkdirs('G.S.') ...")
path <- file.path(pathT, "G.S.")
mprint(path)
mkdirs(path)
tryCatch({
stopifnot(isDirectory(path))
removeDirectory(path)
}, error = function(ex) {
mprint(ex)
})
message("*** mkdirs('G.S.') ... DONE")
message("*** mkdirs() ... DONE")
R.utils/tests/createLink.R 0000644 0001762 0000144 00000003073 14372747611 015177 0 ustar ligges users library("R.utils")
verbose <- Verbose(threshold=-1)
options(warn = 1L)
pathname <- tempfile("foo_", fileext = ".txt")
pathname <- getAbsolutePath(pathname)
cat(file=pathname, "Hello world!\n")
## NOTE: Not all systems support creation of links, which is
## why we need to run the tests using tryCatch().
## Try all methods at once
link <- basename(pathname)
tryCatch({
linkR <- createLink(link=link, target=pathname)
verbose && cat(verbose, "Link returned: ", linkR)
linkR <- normalizePath(linkR)
link <- normalizePath(link)
if (linkR != link) {
throw("Requested and returned link are not the same: ", sQuote(linkR), " != ", sQuote(link))
}
}, error = function(ex) {
verbose && cat(verbose, "Failed to create link: ", ex$message)
})
## One method at the time
methods <- c("unix-symlink", "windows-ntfs-symlink", "windows-shortcut")
for (method in methods) {
verbose && enterf(verbose, "Method '%s'", method)
verbose && cat(verbose, "Target: ", pathname)
link <- sprintf("%s-to-%s", method, basename(pathname))
verbose && cat(verbose, "Link to create: ", link)
tryCatch({
linkR <- createLink(link=link, target=pathname, method=method)
verbose && cat(verbose, "Link returned: ", linkR)
linkR <- normalizePath(linkR)
link <- normalizePath(link)
if (linkR != link) {
throw("Requested and returned link are not the same: ", sQuote(linkR), " != ", sQuote(link))
}
}, error = function(ex) {
verbose && cat(verbose, "Failed to create link: ", ex$message)
})
verbose && exit(verbose)
}
if (isFile(pathname)) file.remove(pathname)
R.utils/tests/whichVector.R 0000644 0001762 0000144 00000001043 14372747611 015376 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - -
# Simulate two large named logical vectors,
# one with missing values one without
# - - - - - - - - - - - - - - - - - - - - - - - - - -
N <- 1e5
# Vector #1
x <- sample(c(TRUE, FALSE), size=N, replace=TRUE)
names(x) <- seq_along(x)
# Vector #2
y <- x
y[sample(N, size=0.1*N)] <- NA
# Validate consistency
stopifnot(identical(which(x), whichVector(x)))
stopifnot(identical(which(y), whichVector(y)))
# A matrix
x <- t(x)
stopifnot(identical(which(x), whichVector(x)))
R.utils/tests/queryRCmdCheck.R 0000644 0001762 0000144 00000000665 14372747611 015773 0 ustar ligges users
# Get the 'R CMD check' status, if any
status <- R.utils::queryRCmdCheck()
print(status)
if (status != "notRunning") {
cat("The current R session was launched by R CMD check. Status:", status, "\n")
} else {
cat("The current R session was not launched by R CMD check.\n")
}
# Display how R was launched
print(base::commandArgs())
# Display loaded packages etc.
print(search())
# Display current working directory
print(getwd())
R.utils/tests/findSourceTraceback.R 0000644 0001762 0000144 00000002036 14372747611 017015 0 ustar ligges users library("R.utils")
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Create two R script files where one source():s the other
# and both lists the traceback of filenames source():d.
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
path <- tempdir()
pathnameA <- Arguments$getWritablePathname("foo.R", path=path)
pathnameB <- Arguments$getWritablePathname("bar.R", path=path)
code <- 'cat("BEGIN foo.R\n")'
code <- c(code, 'print(findSourceTraceback());')
code <- c(code, sprintf('source("%s");', pathnameB))
code <- c(code, 'cat("END foo.R\n")')
code <- paste(code, collapse="\n")
cat(file=pathnameA, code)
code <- 'cat("BEGIN bar.R\n")'
code <- c(code, 'x <- findSourceTraceback();')
code <- c(code, 'print(x);')
code <- c(code, 'cat("END bar.R\n")')
code <- paste(code, collapse="\n")
cat(file=pathnameB, code)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Source the first file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
source(pathnameA, echo=TRUE)
R.utils/tests/ProgressBar.R 0000644 0001762 0000144 00000001150 14372747611 015341 0 ustar ligges users library("R.utils")
# A progress bar with default step length one.
pb <- ProgressBar(max=42)
reset(pb)
while (!isDone(pb)) {
x <- rnorm(3e4)
increase(pb)
# Emulate a slow process
if (interactive()) Sys.sleep(0.02)
}
cat("\n")
# A "faster" progress bar with default step length 1.4.
pb <- ProgressBar(max=42, stepLength=1.4)
reset(pb)
while (!isDone(pb)) {
x <- rnorm(3e4)
increase(pb)
# Emulate a slow process
if (interactive()) Sys.sleep(0.02)
}
cat("\n")
## Odds and ends
print(pb)
print(setStepLength(pb, 1L))
print(setMaxValue(pb, 100L))
print(setProgress(pb, 0.3))
print(setTicks(pb, 10L))
R.utils/tests/sourceTo.R 0000644 0001762 0000144 00000003162 14372747611 014720 0 ustar ligges users library("R.utils")
opager <- options(pager=mpager)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Example 1
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat("=== Example 1 ================================================\n")
foo <- function(file, ...) {
cat("Local objects before calling sourceTo():\n")
print(ls())
res <- sourceTo(file, ...)
cat("Local objects after calling sourceTo():\n")
print(ls())
}
cat("Global objects before calling foo():\n")
lsBefore <- NA
lsBefore <- ls()
foo(file=textConnection(c('a <- 1', 'b <- 2')))
cat("Global objects after calling foo():\n")
stopifnot(length(setdiff(ls(), lsBefore)) == 0)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Example 2 - with VComments preprocessor
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cat("=== Example 2 ================================================\n")
preprocessor <- function(lines, ...) {
cat("-----------------------------------------\n")
cat("Source code before preprocessing:\n")
displayCode(code=lines)
cat("-----------------------------------------\n")
cat("Source code after preprocessing:\n")
lines <- VComments$compile(lines)
displayCode(code=lines)
cat("-----------------------------------------\n")
lines
}
oldHooks <- getHook("sourceTo/onPreprocess")
setHook("sourceTo/onPreprocess", preprocessor, action="replace")
code <- c(
'x <- 2',
'#V1# threshold=-1',
'#Vc# A v-comment log message',
'print("Hello world")'
)
fh <- textConnection(code)
sourceTo(fh)
setHook("sourceTo/onPreprocess", oldHooks, action="replace")
options(opager)
R.utils/tests/withTimeout.R 0000644 0001762 0000144 00000012273 14372747611 015442 0 ustar ligges users library("R.utils")
oopts <- options(warn=1)
# - - - - - - - - - - - - - - - - - - - - - - - - -
# Function that takes "a long" time to run
# - - - - - - - - - - - - - - - - - - - - - - - - -
foo <- function() {
print("Tic")
for (kk in 1:20) {
print(kk)
Sys.sleep(0.1)
}
print("Tac")
42L
}
fib <- function(n) {
if (n == 0 | n == 1) return(n)
return (fib(n - 1) + fib(n - 2))
}
# - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluate code, if it takes too long, generate
# a TimeoutException error.
# - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() with error")
res <- tryCatch({
res <- withTimeout({
foo()
}, timeout=1.08)
}, TimeoutException=function(ex) {
cat("Timeout (", ex$message, "). Skipping.\n", sep="")
TRUE
})
stopifnot(isTRUE(res))
# - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluate code, if it takes too much CPU time,
# generate a TimeoutException error.
# - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() with error")
res <- tryCatch({
res <- withTimeout({
fib(30)
}, cpu=0.1, elapsed=Inf)
}, TimeoutException=function(ex) {
cat("Timeout (", ex$message, "). Skipping.\n", sep="")
TRUE
})
stopifnot(isTRUE(res))
# - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluate code, if it takes too long, generate
# a timeout warning.
# - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() with warning")
res <- withTimeout({
foo()
}, timeout=1.08, onTimeout="warning")
stopifnot(is.null(res))
res <- tryCatch({
res <- withTimeout({
foo()
}, timeout=1.08, onTimeout="warning")
}, warning=function(ex) {
cat("Timeout warning (", ex$message, "). Skipping.\n", sep="")
TRUE
})
stopifnot(isTRUE(res))
# - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluate code, if it takes too much CPU time,
# generate a timeout warning.
# - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() with warning")
res <- withTimeout({
fib(30)
}, cpu=0.1, elapsed=Inf, onTimeout="warning")
stopifnot(is.null(res))
res <- tryCatch({
res <- withTimeout({
fib(30)
}, cpu=0.1, elapsed=Inf, onTimeout="warning")
}, warning=function(ex) {
cat("Timeout warning (", ex$message, "). Skipping.\n", sep="")
TRUE
})
stopifnot(isTRUE(res))
# - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluate code, if it takes too long, generate
# a timeout, and return silently NULL.
# - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() with silent")
res <- withTimeout({
foo()
}, timeout=1.08, onTimeout="silent")
stopifnot(is.null(res))
# - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluate code, that does not timeout, then
# evaluate code that takes long, but should not
# timeout.
# - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() without timeout")
res <- withTimeout({
cat("Hello world!\n")
TRUE
}, timeout=1.08)
stopifnot(isTRUE(res))
# - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluate code, that does not timeout, but
# throws an error.
# - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() without timeout, but with error")
res <- tryCatch({
res <- withTimeout({
stop("boom")
}, timeout=1.08, onTimeout="warning")
}, error=function(ex) {
cat("Another error occured: ", ex$message, "\n", sep="")
TRUE
})
stopifnot(isTRUE(res))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Evalute expression
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() without timeout")
expr <- quote({ cat("Hello world!\n"); TRUE })
res <- withTimeout(expr, substitute = FALSE, timeout=1.08)
stopifnot(isTRUE(res))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Visibility
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() - visibility")
res <- withVisible({
withTimeout({ 1 }, timeout=1)
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(res$visible)
x <- 0
res <- withVisible({
withTimeout({ x <- 1 }, timeout=1)
})
str(res)
stopifnot(all.equal(res$value, 1))
stopifnot(!res$visible)
stopifnot(all.equal(x, 1))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Non-English settings
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
message("withTimeout() - other languages")
local({
olang <- Sys.getenv("LANGUAGE")
on.exit(Sys.setenv(LANGUAGE=olang))
Sys.setenv(LANGUAGE="fr")
res <- tryCatch({
res <- withTimeout({
foo()
}, timeout=1.08, onTimeout="warning")
}, warning=function(ex) {
cat("Timeout warning (", ex$message, "). Skipping.\n", sep="")
TRUE
})
stopifnot(isTRUE(res))
})
message("withTimeout() - switching language inside function (doesn't work)")
res <- tryCatch({
res <- withTimeout({
olang <- Sys.getenv("LANGUAGE")
on.exit(Sys.setenv(LANGUAGE=olang))
Sys.setenv(LANGUAGE="fr")
foo()
}, timeout=1.08, onTimeout="warning")
}, warning=function(ex) {
cat("Timeout warning (", ex$message, "). Skipping.\n", sep="")
TRUE
}, error=function(ex) {
warning("withTimeout() fails to detect timeouts when the language is temporarily switched")
FALSE
})
print(res)
# Undo
options(oopts)
R.utils/tests/seqToIntervals.R 0000644 0001762 0000144 00000001060 14372747611 016073 0 ustar ligges users library("R.utils")
x <- 1:10
y <- seqToIntervals(x)
print(y) # [1 10]
x <- c(1:10, 15:18, 20)
y <- seqToIntervals(x)
print(y) # [1 10; 15 18; 20 20]
z <- intervalsToSeq(y)
print(z)
stopifnot(all.equal(x,z))
y <- matrix(c(5,11, 1,10), ncol=2L, byrow=TRUE)
z <- intervalsToSeq(y, unique=FALSE)
print(z)
z <- intervalsToSeq(y, unique=TRUE)
print(z)
z <- intervalsToSeq(y, sort=TRUE)
print(z)
z <- intervalsToSeq(y, unique=TRUE, sort=TRUE)
print(z)
## Corner cases
x <- integer(0)
y <- seqToIntervals(x)
print(y)
str(y)
stopifnot(all.equal(dim(y), c(0,2)))
R.utils/tests/Settings.R 0000644 0001762 0000144 00000001477 14372747611 014724 0 ustar ligges users library("R.utils")
# Load settings from file, or create default settings
basename <- "some.settings"
settings <- Settings$loadAnywhere(basename)
if (is.null(settings))
settings <- Settings(basename)
print(isModified(settings))
# Set default options, if missing.
setOption(settings, "graphics/verbose", TRUE, overwrite=FALSE)
setOption(settings, "io/verbose", Verbose(threshold=-1), overwrite=FALSE)
# Save and reload settings
path <- tempdir()
str(list(path=path, file.info(path), file_test("-d", path)))
stopifnot(file_test("-d", path), isDirectory(path))
saveAnywhere(settings, path=path)
settings2 <- Settings$loadAnywhere(basename, paths=path)
print(isModified(settings2))
# Clean up
file.remove(getLoadedPathname(settings2))
# Assert correctness
stopifnot(equals(settings, settings2))
print(isModified(settings))
R.utils/MD5 0000644 0001762 0000144 00000071063 14757161202 012136 0 ustar ligges users 083da1149f1af3d94c3d4a178671df72 *DESCRIPTION
d6383dc737c9cc14e1c502477e9c91de *NAMESPACE
e8b7e3ab92cbc50c146b87f18727658b *NEWS.md
5b3e0291bcc049d9ada9005162c5259a *R/000.R
084f5fef1ad9ded4c99ca3a087ef0d20 *R/006.fixVarArgs.R
73362ebcfc5b9092dc96948d43c43087 *R/999.NonDocumentedObjects.R
13baed0fd191b9940300bd6397610fe9 *R/999.package.R
65a18b7c5ede979bc0fec27c31a59454 *R/Arguments.R
214814967bc916701323f8eb043de5a8 *R/Assert.R
48f811cd91497f439600d813f8301bbc *R/CmdArgsFunction.R
f15a2b2aaeec5e207014fd737b949821 *R/FileListTree.R
153326b425f2fa4b2f02d2756adbd959 *R/FileProgressBar.R
b81cf3f634735e6c127c37e549e790e9 *R/GString-class.R
19a31792ff0dd3da2e712b23364c8b65 *R/GenericSummary.R
26e7376bd4aedfb5a4c71f316c773697 *R/Java.R
37636532e8f5fb6cef377274bc2e0ca0 *R/LComments.R
449faac0226bdf5b65dac57c3a8bea3b *R/MultiVerbose.R
27222dd2773c26c1cef8e7c3e9d4741d *R/NullVerbose.R
cae3d2e0c747316e467521185f63bd02 *R/Options.R
a3c755ed5242ea85d968a0fb8c805bb4 *R/ProgressBar.R
7464eb0b64098816fb1b2eb0a401a222 *R/Settings.R
5a93d5ff881ed9d966423a56b729293c *R/SmartComments.R
69096d3e21b66661ed7148e250ff77c2 *R/Sys.readlink.Windows.R
76e3aa7c8d1b8779c1bca60f889bc499 *R/Sys.readlink2.R
3ba72c03d5269470258774a0b5fb48f2 *R/System.R
fb9b7c1ded05d714f77e29361cb99c46 *R/TextStatusBar.R
104ba521ede4da2017590cd4623f965b *R/TimeoutException.R
ac18b3a5e1071bbbc89c5885ab3ddf4e *R/VComments.R
154455e1cd430e5ff71139c5059cbec0 *R/Verbose.R
125af8581fd3e27cc93bcb50888f5286 *R/addFinalizerToLast.R
78b974018e05d94361d47c5aa62c94ef *R/attachLocally.R
09644c2c8db98b4d0f874e3544598be7 *R/beta/Options.ui.Rtodo
35d3d8c87a0fd1f892dad747ecf4b856 *R/beta/singularPlural.Rtrial
ce2dc0230be35e159edf51d3231caf34 *R/callHooks.R
d9277881cb116ead1ac1ba1cef828a57 *R/capitalize.R
b75522af0b2584369f9d593cbaec0547 *R/captureOutput.R
26d10ea27b278a99875862484f466d54 *R/cmdArgs.R
53d6095d8210e6a0f0626a52c2890b80 *R/colClasses.R
a4b1b73f5ebefc62de2da7f19e070572 *R/commandArgs.R
16bdadeeeffa48ca49931dc243fcf09f *R/compressFile.R
28df7c4f8ecc5d646e883874cfb60b33 *R/compressPDF.R
16fa643fb616da16991ec1f3d3770269 *R/copyDirectory.R
c3c01785551bc555584ed4e8c061e05f *R/copyFile.R
749804b58f650bffb671f384e74d7ede *R/countLines.R
40539abaf8821db23cae0478933170ae *R/createFileAtomically.R
8cac49df1b1fe32a0c5b38a54608b657 *R/createLink.R
e1c09c0828ea97d58758e6ee94b00fc1 *R/createWindowsShortcut.R
bd381c99ac3802832f8f0b75e2e7cf03 *R/dataFrame.R
317e2bbdf5e148b0d7486cc8f49b3b0f *R/density.EXTS.R
9ed2f621eeb5e8827130ef65fbc32096 *R/detachPackage.R
96686481cac450696814a007dca53c3a *R/detachPlain.R
c7566b3f1b72b9cc57ceae8a3db15a88 *R/devel/doCall.R
51c2f3f9d27280388f82d49ff21277d8 *R/devel/fileSizeToHumanReadable.R
5ebed4a1a8a146b85e0f9d7d9d5f3410 *R/devel/splitUrl.R
a6ef193702b4768dd8f36a34aae49b89 *R/dimNA.R
19a532b97c43b2cdd201e2db7288b120 *R/displayCode.R
cca5ba24b18e56bc47522d39db959c11 *R/doCall.R
6354e168e0c46205d0b861231b80906a *R/downloadFile.R
f1e73c2bf2b2620753cfaf6803426e79 *R/eget.R
a4157e3916f30d816c331e49a2abe435 *R/egsub.R
8eafadf361fd10de2ef53657d3487784 *R/env.R
4557f670d31dabc6245603231ef63e0a *R/extract.array.R
3abdfe77e668f081f2eb978553fc31f3 *R/fileAccess.R
3ea0666687b115840899b04cc6bf6643 *R/filePath.R
99f5f7106c07077c6c2fe2004a6e6bf1 *R/finalizeSession.R
6bf476f8487dcfcaa82d02094cb715e9 *R/findFiles.R
c8c48d9785f528128d45306641ca8ce9 *R/findSourceTraceback.R
eac0f6410c7569c5db8296d09b5ad406 *R/gcDLLs.R
7c2f62416d3b42c482e34909552ff937 *R/gcat.R
8278b1c2288509a3f65862145bce72f8 *R/getAbsolutePath.R
18068b0861d9cafd9f35ea6131c13b8a *R/getCommonPrefix.R
6ea0293453413f406d3083ff2998e9e0 *R/getParent.R
6a2d31b83f993aba9c76a12d7d5b7c8f *R/getPathIfEmpty.R
6448507b7e95d88ef6ad241ca8e21780 *R/getRelativePath.R
eab28efaa1fb59599e5b7921e97e53bf *R/gstring.R
875e87d67fb03536a4b296185504fdd5 *R/hasUrlProtocol.R
123437a531b1bb34d95690baedd7a7c2 *R/hpaste.R
eaceb526bdcc16823f19dc4bce3609ca *R/hsize.R
041de0efc388d4f0ff856dbafa844465 *R/inAnyInterval.R
c00383b54909ec73b3d7ef19f2637be8 *R/insert.R
749cb381502c398b768f46666ced794d *R/installPackages.R
581406349f161ab7fb83eaa57fafbf05 *R/intToHex.R
7d59477970a5adffbda3367e121c63ba *R/intervalsToSeq.R
701cbf33a1012b52eea81acca32c3af0 *R/isAbsolutePath.R
5225089f55043f1b283b8b38ddf3afb9 *R/isDirectory.R
94e2e9558ec7ca41a0fb023a87afc8b3 *R/isEof.connection.R
e2e52b80c147535a8ba0a3638720602f *R/isFile.R
075dc15dedeee0a0f06a2a52ff0b8bee *R/isOpen.character.R
4f854e74565a13302a777deead0dea30 *R/isPackageInstalled.R
45118eb74675a644648f3aaa359d44c5 *R/isPackageLoaded.R
107555122dfd85d6e32192e14fff24c7 *R/isReplicated.R
32e324595973f6c8b337669fa4058f11 *R/isSingle.R
3c53208a242d37ee74a521bce89d4348 *R/isUrl.R
ad1c7b74ce8e79075ee07ab730f37db2 *R/isZero.R
a09268fb3abc98d913d9972e7deb7f4a *R/lastModified.R
b46c17051335fc41e376e29010a8582e *R/listDirectory.R
ed753beea8d365690937ca2d27236b41 *R/loadObject.R
04553d849d3af2833b752a3a522c76a9 *R/loadToEnv.R
6f43531b4bf069e80e8fe99f0a28e95f *R/mapToIntervals.R
a8a85fc5306428578d6eecbb94012a2f *R/mergeByCommonTails.R
4b47f6b15cd82115841a6eefb6f2e1a3 *R/mergeIntervals.R
846be973f6273e6bcf72ff1912367c88 *R/mkdirs.R
e23fb020223a8bb1c8fb169a2a776155 *R/mout.R
4a5f28178327218c1937c105d6a4c4eb *R/moveInSearchPath.R
de63bbbc15eed57f20cfc3a2dcb4b604 *R/mpager.R
85b33b04073e28baee5dbbbe5e135219 *R/nullfile.R
f14d69f7134be46ca47df78bd9fb035f *R/onGarbageCollect.R
c5abd013ab2c8ddb793db393a6099518 *R/onSessionExit.R
2ecd60f46aff984fd422991494d5390e *R/parseArgs.R
f6458414c964b3a6e4acab5cd39a20bc *R/patchCode.R
96eb1137b6bcf8d519438221eda4f59b *R/popBackupFile.R
c00a4857419dc57fb4ce8a1962365b6c *R/popTemporaryFile.R
ce159c9746f2555883987a65b84c719e *R/printf.R
2d439b549feb601b97c4fa8206adce6a *R/pushBackupFile.R
6f87bfe10e607fb6b1f2ab25f2e6b772 *R/pushTemporaryFile.R
a7187a3089cbf1f9ab7e0e1029e2bbe0 *R/queryRCmdCheck.R
206e8f6a528ae9dfe77177adf381bb32 *R/readBinFragments.R
619b4a9cc048617d416fc5d40948cebb *R/readRdHelp.R
a7563d34c4be027ac6d2fe6a6c25b2fa *R/readTable.R
770edf2c95aba989dc3152d83213cf12 *R/readTableIndex.R
7eada7626f87a1f0caecdc79c8e29640 *R/readWindowsShellLink.R
ebc583dc1ab5f9b59c182db3b7a575f7 *R/readWindowsShortcut.R
e6007aa7e9b12c600b46c898725e9f5e *R/reassignInPackage.R
43dd2e37b935388354748625dfa0abaa *R/removeDirectory.R
47580f4d5bccf89ba428f61e7d2ca7c9 *R/renameFile.R
a977334bbf5a0697d00dd284a04eece2 *R/resample.R
82d724d3b47c92db3776d7852f880de6 *R/saveObject.R
3d72eab62f14cbf6c6812d662315d466 *R/seqToHumanReadable.R
fab1752663a9e459353b84cb53e04899 *R/seqToIntervals.R
15a7e7cf7ea977fe07a78568b4bbd2c2 *R/setOption.R
038e08a1016199ea634c29decc23ff7a *R/shell.exec2.R
fe2ea7f51ff1ecbd0d37e5c1317bd46b *R/sourceDirectory.R
2a6e446bf508be557bb66155d2e73035 *R/sourceTo.R
273eef6742421d5cf3d72339b9a75985 *R/splitByCommonTails.R
7a756731208f880746d4ff2deba0282b *R/splitByPattern.R
14d0af09e0c8f5f28ea598c5ae95d667 *R/stext.R
d5f1644530528a8306945639798d1c0a *R/subplots.R
40579e6fb388cc4e8a57a79d4c016a30 *R/systemR.R
986a0f64600503e293a48d1dfd42f40d *R/tempvar.R
320efe5a2131d26585e245ade9439c14 *R/tmpfile.R
959ab5030d750e2311f558c92fa32483 *R/toAsciiRegExprPattern.R
35d2d93e4fb11f0c02c4c05a7cc807a3 *R/toCamelCase.R
697f76853818ad544eb789c2a07f83d7 *R/toUrl.R
b650347bcbc9b83bb56152cfbfa09afa *R/touchFile.R
3f6051c1b61db0d840e6c637904bc7d0 *R/unwrap.array.R
4f3c7b9f5b7ec4e6659512eba2c7ea9b *R/use.R
dc910054ec0e3f6bba4e36a114b625d0 *R/useRepos.R
5d70959a9e051a5666c0524ad97022d9 *R/utils.R
5fc530e624bb558f7df5ceeb27bb6c2e *R/whichVector.R
b2649ce1f6324b1fa48be66928379e55 *R/withCapture.R
9e99926bf9c32812d7840fe24185a55c *R/withLocale.R
12bb56f357bee89fb75f1a8d87eaf19b *R/withOptions.R
1eaa04562a09fb5d1898a60c7cb051fe *R/withRepos.R
3ffd91dac1773a4ffd193c0f30da6f20 *R/withSeed.R
c72ff0d9ad024d1c24a9140ccd5fa3d2 *R/withSink.R
85fabce9d68e5e3dea492498cf17065d *R/withTimeout.R
0caa0b615bd896ef3288a35b5cc1dbac *R/wrap.array.R
6d12cc8e1df282f9cd92ac874ede60b6 *R/writeBinFragments.R
59252ec83a39398928add900e7a06d6d *R/writeDataFrame.R
5550da3fd031fb81c728186f07554300 *R/zzz.R
094a0a9397437ce080424faaea209af4 *inst/WORDLIST
97b23af5ae2ec44f41b1340c85efccf6 *inst/data-ex/HISTORY.LNK
637b485d438f840b23761205cd3963ac *inst/data-ex/NEWS.LNK
7f850ac9c29ed473c440080f9ab26f44 *inst/data-ex/exampleVComments.R
7d30d107dbcee8a415ba69362f2eae9b *inst/data-ex/lnkFileWith10BitsInFlag.lnk
b377942643fcf93832012078e9857c21 *man/000.Last.lib.Rd
d748551ca15e86e6e3661c0783d0fa65 *man/Arguments.Rd
aa17d64882bf1fe1d6728041153443c6 *man/Assert.Rd
bba8ad7d25e012e6059344e54c42de2d *man/FileProgressBar.Rd
ee912203e9c036dbae97760438dd410b *man/GString-class.Rd
619ad6ff5c2aca152b958b0391584b1f *man/Java.Rd
39061a29de8384d08f0c7033dd8e61bd *man/LComments.Rd
eeead605fe5528827a3cb5ae21c4ca16 *man/MultiVerbose.Rd
5981e8ae741933d2e5c7f9e8a9c2e2fc *man/Non-documented_objects.Rd
06fb8fbb2911a8caee50420a572f602a *man/NullVerbose.Rd
1795e2df8b0589b1a8530e840916f555 *man/Options.Rd
214962e942e370c0e34193c31cd3e834 *man/ProgressBar.Rd
2f4dd517f23bdbbca789d699a3b5e383 *man/R.utils-package.Rd
48302dcafe70a3438586dcf0122b6b08 *man/Settings.Rd
f43df6bd9c30d3768f2601a961cd5f8a *man/SmartComments.Rd
38364aa41846fbd022617a7f93786b5a *man/Sys.readlink2.Rd
8ec52272fad2671f303a57061ebb001f *man/System.Rd
e94f6de5e1c90826f5a18e897891e086 *man/TextStatusBar.Rd
962f32959115b79f5032e6703a3efda5 *man/TimeoutException.Rd
940631a912514ebf8651a68146175dae *man/VComments.Rd
993e3bc778c0a0bfe8f4083236a349ee *man/Verbose.Rd
c366c029b7c251644fcf76d5821a535b *man/addFinalizerToLast.Rd
781576574d1a10e529cce2d3fac68ec7 *man/as.character.GString.Rd
dfa29f5299da734576c2b9ef81322646 *man/as.character.Options.Rd
a1dfac301e5392c6bf76a2ca63f460ed *man/as.character.ProgressBar.Rd
4e58c75b8e908562aaea2bae326eb920 *man/as.character.Verbose.Rd
1ee83d26a7bfef402e8772bb5f5ee5d1 *man/as.double.Verbose.Rd
4274a2ee6e785c512d9af83566694ff6 *man/as.list.MultiVerbose.Rd
4393d45c6ee5267b1a91d60c67a4cea1 *man/as.list.Options.Rd
7964c30b7d09751d2cc671c17d6c4a3c *man/as.logical.Verbose.Rd
6d32bb23b82b377848e7f2448e7a7210 *man/asByte.Java.Rd
215ff4fda907e057b26582ff72c063eb *man/asInt.Java.Rd
c9fe99e2f0b04f2c436f871075964248 *man/asLong.Java.Rd
182e3248144d77b4ffdcf72aea4f0d64 *man/asShort.Java.Rd
cafb41d6b5bd08b67d86c9a37ad24853 *man/attachLocally.list.Rd
a9fefc8b9f34904edeaec40eb2b27fa5 *man/callHooks.Rd
3e8bc7981f430452d1a4b6d07f8ec80a *man/callHooks.function.Rd
faf3d7dc565e0a56a70dc6978675069f *man/capitalize.Rd
f63777d4a9c4639fe9f12141fca937d6 *man/capture.Verbose.Rd
2f6bd65823e89421f6a24a1396aaec7c *man/captureOutput.Rd
a90c9bbbbff09d258ac0e8600807f23b *man/cat.Verbose.Rd
da825fef5a0d8745e1dbcf2893c86e3e *man/check.Assert.Rd
b92b029744a6c44f2b7d2adca74ef495 *man/cleanup.FileProgressBar.Rd
f31acaefc8030e38057f4e0026fdd36e *man/cmdArgs.Rd
883e8d84d743cad7893a806b92662c39 *man/cmdArgsCall.Rd
2b685382ce094ecf0b8389638c364684 *man/colClasses.Rd
0a17f2ba8d4d29fcc9569343f89622e7 *man/commandArgs.Rd
38a9c7776a64d4b1984222b57fe8237e *man/compile.SmartComments.Rd
122973a5f256429b6099ce9a139b7cd0 *man/compressFile.Rd
b242af88983f5705acf5c4dc1986da00 *man/compressPDF.Rd
a11749b463ff39b65939fb934bdd96c0 *man/convertComment.SmartComments.Rd
9e3d14b2f1f94b72ccceddf2e83361cb *man/convertComment.VComments.Rd
6fa5739f6a4b4502eb3c6f4f6b7d305b *man/copyDirectory.Rd
ac6b4a8d1954673f2874c7ba507e4c34 *man/copyFile.Rd
0a4a82d6ed1059a45fd85ef5a15ee122 *man/countLines.Rd
8bb1f0264769bed8417fcce10097c0ea *man/createFileAtomically.Rd
2f2306140da5b22602af2c06dfff1d3f *man/createLink.Rd
acdb0dbeb90e782b0e6ef13f97e10f83 *man/createWindowsShortcut.Rd
83b9900df8b6bf057c8df692f24f6b81 *man/currentTimeMillis.System.Rd
1082a6007c60ecb1e12fd64af572dcde *man/dataFrame.Rd
ebb3459c1bd2d09df97bdf23f2f27444 *man/detachPackage.Rd
94f79f25d04f764cda701f5951be87b3 *man/dimNALT_-.Rd
01f0f6de8ad32da8744d1e19277a469b *man/displayCode.Rd
12a7994a98574f7a76c2bc6cbe98f854 *man/doCall.Rd
f683236346b5781d75da4abef06d9684 *man/downloadFile.character.Rd
177c72dc6378d1eced3f9931c2e0a01b *man/draw.density.Rd
245dcf814d588bb29c9da516b4442fe4 *man/eget.Rd
c690b529e0c7c071f30626366daf8c1d *man/egsub.Rd
038e4fc5fba4a515bc16fa41b287fbf5 *man/enter.Verbose.Rd
47d99d391499634f47ce1c4ee09921d6 *man/env.Rd
eeb87a74fff7beeea276ecd25dd13826 *man/equals.Options.Rd
8cf1adae1b79e16d4251cf0b630be07e *man/equals.Verbose.Rd
a20873e3799b53f3bb03ad9cc5c18933 *man/evaluate.GString.Rd
5ba3182528aa26cc78e5d186ece2c401 *man/evaluate.Verbose.Rd
a27608db1b994303687d7cfe9f42178c *man/exit.Verbose.Rd
71205565a290410adae12a3382feb4f7 *man/extract.array.Rd
ab73bbf146cf6162f26542c99ceef785 *man/file.info2.Rd
20c1013de001a7547e264d7681d7c51d *man/fileAccess.Rd
e419c7b2cd6376d54c6e4a42eff2b1d6 *man/filePath.Rd
c296c9f5490cc0d0b1bcf0656e24dd71 *man/finalizeSession.Rd
ff97dd68d72e9cb6374be778cac155d9 *man/findFiles.Rd
e2706583e181e4ef4902194f12e1c446 *man/findGhostscript.System.Rd
610620750f480d6c1496e0720c02a87b *man/findGraphicsDevice.System.Rd
d53cb36d56dc8042605e707be691ddf4 *man/findSettings.Settings.Rd
00493d5ee4250772e9711661720afcf1 *man/findSourceTraceback.Rd
5ff260dbc288c4821c477c5eb26d6c93 *man/flush.TextStatusBar.Rd
4b0f98b737dd366dc0ee2ce1a881de1c *man/format.binmode.Rd
97be4fd348881a4ddc87223df907813f *man/gcDLLs.Rd
e52ee90006b99a0c4dabc90300974b30 *man/gcat.Rd
afd5299bc4c69c3b8aada2ab0d846ea6 *man/getAbsolutePath.Rd
957b30ec9f988eb20cc249c12268d7ab *man/getBarString.ProgressBar.Rd
6fc08095b679b1f7fddb18abd524ea6a *man/getBuiltinDate.GString.Rd
4e060c9497225f189ad8ed4572b6abf7 *man/getBuiltinDatetime.GString.Rd
4487a16c6c9b6eec64a96072c2aa0930 *man/getBuiltinHostname.GString.Rd
e0b35b67cb0f6e9ecc6133452f69e26c *man/getBuiltinOs.GString.Rd
ff5f683695d7f5692f2a6cb58478d303 *man/getBuiltinPid.GString.Rd
da9190b9ab19f830e9154c45413f4e2c *man/getBuiltinRhome.GString.Rd
0a21bdf201df08aa44dbdd2b9d4f3fe0 *man/getBuiltinRversion.GString.Rd
8dbb1e035c67b4ceee857079f8b18e53 *man/getBuiltinTime.GString.Rd
9c23c120e5c69ee759d97b043b2de913 *man/getBuiltinUsername.GString.Rd
4ef52cebc6d483f40784744e3620abe6 *man/getCharacters.Arguments.Rd
7be1a62b4b7ab039d49c6b343cd11259 *man/getDoubles.Arguments.Rd
5510c638a9e9f0d07f317e126176b279 *man/getEnvironment.Arguments.Rd
43ae5a6a534888f522106984abcbea06 *man/getFilename.Arguments.Rd
f6b8fcd1a30c80d2fccfc0b9f2b36054 *man/getHostname.System.Rd
5a3eb7a493787441c55f10e8d5fa1aa1 *man/getIndices.Arguments.Rd
4eb6cf1d7b0893117c594a9618bc4a43 *man/getInstanceOf.Arguments.Rd
b950a7ad29be07a2837dd92474f61def *man/getIntegers.Arguments.Rd
f65f5d6b92ffff17409d9bf3cccf59bd *man/getLabel.TextStatusBar.Rd
cb562c5b4755f3c65679f4cb245fc890 *man/getLeaves.Options.Rd
e91a512853a0b792bbe772cfc01af09a *man/getLoadedPathname.Settings.Rd
02dca95ca1f3ca42e02579407895ed20 *man/getLogicals.Arguments.Rd
3cd40acc6a31820cb0aa8e23b4ffd1f7 *man/getMessage.TimeoutException.Rd
4123100936f54b24cc3bda402db06ff9 *man/getNumerics.Arguments.Rd
d1d770d72489014cd2a1441c266ee49c *man/getOption.Options.Rd
335d84ae38efc6364cca908e038ed3a5 *man/getParent.Rd
388a20be290853e7316427dad5d4b586 *man/getRaw.GString.Rd
784998f427c6a21bf11ced9d78cf6c0d *man/getReadablePathname.Arguments.Rd
7578fa85bbefb13a190f3f1196cb989f *man/getReadablePathnames.Arguments.Rd
8c603cf36d74d051e62b14910985fced *man/getRegularExpression.Arguments.Rd
05560ea9ddd67a27f2a93e94c0867961 *man/getRelativePath.Rd
afe52ba398c9b89274f428fbd7d8adf0 *man/getThreshold.Verbose.Rd
7df836d6501234bdc7e42fc28538fc52 *man/getTimestampFormat.Verbose.Rd
bc3a11c2f870628334cd36877abc9b9f *man/getUsername.System.Rd
aee6c7f3cb24d58bed97fafcac867eb3 *man/getVariableValue.GString.Rd
874d24e49a87f43e7638c03e71ecddd7 *man/getVector.Arguments.Rd
8b28e4762fa8e716a3586415718dd71a *man/getVerbose.Arguments.Rd
393751479a9730b648310de92fc30c3b *man/getWritablePathname.Arguments.Rd
51d08c0701ca4a098578709a5d04ba35 *man/gstring.Rd
ced5ccc7810e1e28b75b61432c21f9cb *man/hasOption.Options.Rd
0ebe206fe5f3eed5f5705ff720dd9b8f *man/hasUrlProtocol.Rd
89cb323104457dc5ebbb1e88334042e8 *man/header.Verbose.Rd
ff57ba59e2cd55fdea19bc261c9a5d8c *man/hpaste.Rd
4cb7e8e78b926cab7f3851a677532bdb *man/hsize.Rd
9fc50ea17695945758e45496021d1ee9 *man/inAnyInterval.numeric.Rd
2e0833a62210f83c068eb4c87b943ae3 *man/increase.ProgressBar.Rd
88f30547adf67f36c603768c05964c8a *man/inheritsFrom.Assert.Rd
4d15f9a8ba58aadcfdad0d7fbbcc45ea *man/insert.Rd
2c81c1bf81c1d24a1d896f5b742ce7d0 *man/installPackages.Rd
c6c908d26b9ea08d68f09f8c30a5631a *man/intToBin.Rd
f8b69a0a4afa099b1ff0d7890c1c6745 *man/intervalsToSeq.matrix.Rd
de0d54f119c661059750a615283dd60a *man/isAbsolutePath.Rd
8ed02e65889d3ae432bed7b400085bf4 *man/isDirectory.Rd
11a67bdd46e3b6c5cb9e200d1fa53626 *man/isDone.ProgressBar.Rd
ec4a0fb8421d795eab0e60213042fbb1 *man/isEof.connection.Rd
d043f1004e392fe97e17b41ab243adcd *man/isFile.Rd
4d3d032906625e942c148d88755d6b7e *man/isMatrix.Assert.Rd
aa9b98c472e10dbd372121cafecf281a *man/isModified.Settings.Rd
c9fe74525a06b1fe42701402756ea2cb *man/isOn.NullVerbose.Rd
3f6e33a616d4c4d9c680c8a28ee5ba6e *man/isOn.Verbose.Rd
282a02e81c24f0df950b55a1d2ca89cd *man/isOpen.character.Rd
fd07008f20f2068c0b1b085a405c62c1 *man/isPackageInstalled.Rd
85c02449e8e99dd399806c16d8c51208 *man/isPackageLoaded.Rd
67aeaaf34b378fd8d3fdf50fcd58e0cd *man/isReplicated.Rd
3e8cdf524b9dd771a571eec35d39027e *man/isScalar.Assert.Rd
399378239c303326b4e1de6218736ebd *man/isSingle.Rd
8d64987abac7766467bb6186a3ee4fb9 *man/isUrl.Rd
f5187ac96be3d27e47da87eedef46b2d *man/isVector.Assert.Rd
65c3880ef2f554d4a6088a53bc7d08d9 *man/isVisible.NullVerbose.Rd
7a5875b748451a418b080ea99bed1861 *man/isVisible.Verbose.Rd
7a4b2c37f16e7e9349a9c20379d238a8 *man/isZero.Rd
219befe52eb5c466eb18d674ecb0e26a *man/lastModified.Rd
a636c3ab5dee6ee62da4033155a7855b *man/less.Verbose.Rd
cab3ca0a0527d00f83c86b314c3e4924 *man/listDirectory.Rd
3134ae47e6d8b5d7fe4f8b60a1f1e2f1 *man/loadAnywhere.Settings.Rd
a563155223e05773868bc955bcf0aab3 *man/loadObject.Rd
a5ecc8c98689d1d13cc56f9408fb8933 *man/loadToEnv.Rd
16b058342778268b827c236a61af333f *man/mapToIntervals.numeric.Rd
6e51be00789219f57bfdeb217240c3a4 *man/mergeIntervals.numeric.Rd
2803885c3cb4a9f56131f66e3b69f6a0 *man/mkdirs.Rd
f4008a5b6dce38af6903fe52f1ff74ec *man/more.Verbose.Rd
c1014affeee4ad34e39d6eded4ccde83 *man/mout.Rd
f091ff97f2e4dfc07975fe14cf3014ca *man/moveInSearchPath.Rd
68b9444a3cb16a16910fe04ec249a7a5 *man/mpager.Rd
98771530ab6540200b87e03c0861d6c4 *man/names.Options.Rd
861f03d04270f6f7d5043e25eb061284 *man/nbrOfOptions.Options.Rd
9c62d7ad633f32bf453755c0538ad7d0 *man/newline.TextStatusBar.Rd
84b15a62b961682198e9fcf2b2f861fb *man/newline.Verbose.Rd
1a10accf545b5a261be1ce6aaf747427 *man/nullfile.Rd
9251ce2e7651c50a875791da883db340 *man/off.Verbose.Rd
19e5fcda8159fa72aa7304551482d783 *man/on.Verbose.Rd
b703af8ae44946e21c3ce4f225ecaa31 *man/onGarbageCollect.Rd
c0daadba672edd075b1b6e196c20785e *man/onSessionExit.Rd
3e71219a6db65ed42c7f460122a3826a *man/openBrowser.System.Rd
fc882b8b7ae43186dec07f5134ecf298 *man/parse.GString.Rd
535acd818049fd29c49695e06466e55a *man/parse.SmartComments.Rd
e83a5b82bb71efd55a4ff3daa54d7cba *man/parseDebian.System.Rd
4e2513c3f2da9604731357907ed7c414 *man/patchCode.Rd
b27ef8f1604680ad4600acad99062b11 *man/popBackupFile.Rd
643c2d8e85e6079420ae5a56a89d8a26 *man/popMessage.TextStatusBar.Rd
c326c2cb8b456e2dc1f3d78fa9273c49 *man/popTemporaryFile.Rd
3bc70e67b86d9ab7706bb782865e8b89 *man/print.GString.Rd
1f988953661ddff98cdf8182de60a0d2 *man/print.Verbose.Rd
f6584c22217f8136f6a3642ece07aca8 *man/printWarnings.Verbose.Rd
4f36d70952c274155e04a52f43333bbb *man/printf.Rd
0c009dc50256193bc9933e41f07a357b *man/printf.Verbose.Rd
00380954458e78a9e45245e19befcb0e *man/promptAndSave.Settings.Rd
97ab76726c1a3a29b185b9c11eb8fd77 *man/pushBackupFile.Rd
1d643fe2fb5412f03573fbf46be5d231 *man/pushState.Verbose.Rd
7620913ed1fdd12c5e100ca82faf71e9 *man/pushTemporaryFile.Rd
e92e82115a9ea42d7c39330f0ae8e177 *man/queryRCmdCheck.Rd
32a5c8a51f73e6e8b7a2fd4efdd2cb81 *man/readBinFragments.Rd
fb8615ebc5cbcef7df9ba58fd8278940 *man/readByte.Java.Rd
7a6205f626adf8551eae3febb17ca9e1 *man/readInt.Java.Rd
a238fcea6b6984892277ccfd267fdae1 *man/readRdHelp.Rd
2bde2b32a78f3b70bd441d416ec41421 *man/readShort.Java.Rd
1e7f53b458f5d83e600cd6e8bc7fb674 *man/readTable.Rd
616b3b4e800a2383822903a6aa54ecc0 *man/readTableIndex.Rd
287e4c3c098dbf34d81b98437e0ac414 *man/readUTF.Java.Rd
c1697fab420f61ab76ebb0b0ea6498e9 *man/readWindowsShellLink.Rd
23a5089bda7e40b2a4ed4761b6f285c4 *man/readWindowsShortcut.Rd
ebd21fc2fb6116d71ab01caf5940a058 *man/reassignInPackage.Rd
71a202f543a77dd1aa0e84ecd1a0f59d *man/removeDirectory.Rd
e2c2ce24eb2acbcd971bc3647d11516b *man/renameFile.Rd
958c68a482b02a3bc8d5a59374a0b80a *man/resample.Rd
3c8d4e1214fd5dddef8c342eaa58a60f *man/reset.ProgressBar.Rd
d80126be1bc6e376c5543791820a2fa1 *man/reset.SmartComments.Rd
16b9964094c3f54d597a5d9b6822cf76 *man/reset.VComments.Rd
0fa36a3c310a30c270662fd800e8d686 *man/ruler.Verbose.Rd
32b67ffec940167e9a009ac5b5b1910d *man/saveAnywhere.Settings.Rd
967d6334450f49dd665202315a98d505 *man/saveObject.Rd
0f4c61017b052bc8febf37219aa41ea1 *man/seqToHumanReadable.Rd
2e7384d88d9b4703501c268129254a06 *man/seqToIntervals.Rd
afbf27e4b0684ff74b468ffbd18e1f96 *man/setDefaultLevel.Verbose.Rd
5d563f3140461152350493094dd21624 *man/setLabel.TextStatusBar.Rd
0676637c064cbe7a0b20d4f02de967e3 *man/setLabels.TextStatusBar.Rd
4fd7aaa89a3d61dbe5b5d202543871bb *man/setMaxValue.ProgressBar.Rd
2a8503c2f381809d3de63a4a3ad87ef4 *man/setOption.Options.Rd
f4541c1dc5f58299d333d4e0f623f7b5 *man/setOption.Rd
7f8a3ae54fbc02bea0cf1fcfc80d44ae *man/setProgress.ProgressBar.Rd
ea957410cbc7cf0c1aeda6c527cc7e78 *man/setStepLength.ProgressBar.Rd
78f10268f2e7313a3a0ecd6f7da6e22e *man/setThreshold.Verbose.Rd
4bc859d15df948bfdf27b9cb4d22b598 *man/setTicks.ProgressBar.Rd
98146ae96fd66418a9ea75ad949a386c *man/setTimestampFormat.Verbose.Rd
63b9612bb5b281427c66b167515777c9 *man/setValue.ProgressBar.Rd
3887c4b2d7a14286253f6be288d6e121 *man/shell.exec2.Rd
d5188ff0eaa4bd2c8cc2b82b124c8418 *man/sourceDirectory.Rd
3b8ea70f4ff4e9cfa551776e3ce87397 *man/sourceTo.Rd
a1e0c2bb204f7bb4a4ef6eee47067bec *man/splitByPattern.Rd
5924ec0a3d8ec2c03ddfd24181056cc2 *man/stext.Rd
6dfb4e5fe2981eafef4356e4be593adc *man/str.Options.Rd
7b6ce9844132f32aa62b142208387186 *man/str.Verbose.Rd
9e683d8ab0a7521ac0c14d24e9eadb2d *man/subplots.Rd
88942082c8f2c9bd3b08d27fe8f9bfa7 *man/summary.Verbose.Rd
68387c8fd4e494a9bf05a1c8c566ec2f *man/swapXY.density.Rd
fe105e4f6d7798730e5b2e14119fa5a1 *man/systemR.Rd
a3b2edc9498a2cd51e3750696bd492b7 *man/tempvar.Rd
b47bc90e93ae475b8d5e82fb3da74cc5 *man/timestamp.Verbose.Rd
b5611c8ba9f6d3a20e3890fd6a708fad *man/timestampOn.Verbose.Rd
bf20f527399595dd701853cd15b99ac6 *man/tmpfile.Rd
021c30352aceabeeaae310e7eaeada89 *man/toCamelCase.Rd
28f3dd0baa84676a67404b6ecbb89c04 *man/toUrl.Rd
b1e41b5092d91a8972620495f05ff864 *man/touchFile.Rd
5f751883342f5b0b3595e7e5fa230dbc *man/unwrap.array.Rd
433b24e2cf936368a1b94f06c920a9a6 *man/update.FileProgressBar.Rd
ff458aa7f19ecf86a06640230be8909f *man/update.ProgressBar.Rd
71a78c510f478eb6733d3e71e8f37692 *man/update.TextStatusBar.Rd
ec2ffdd6f3e8b1a0021cd982a6be0da2 *man/updateLabels.TextStatusBar.Rd
a360b8982948dd1f60310210ac604414 *man/use.Rd
d2cc11a3f15df972e4efedc16692cc92 *man/useRepos.Rd
ff26588b099baf948ca5ca87dd7518ab *man/validate.SmartComments.Rd
6af991e15355e4853892834bfcf8e192 *man/validate.VComments.Rd
84c5b1157dd561a87500672f3eb8507c *man/whichVector.logical.Rd
dfa0eaf257073c077e8d69127bf33b77 *man/withCapture.Rd
5cfc890f51bf3fe3bbdf6aca06578ee8 *man/withLocale.Rd
cfac4c6bb8b67b623ce487e1b5e7b5fc *man/withOptions.Rd
044754db05680d00f554eaf04ddb6105 *man/withRepos.Rd
71c7d5dfa0e6afc0a7f24695511feb37 *man/withSeed.Rd
2f1c064fbdb63579f8923b01047f56a7 *man/withSink.Rd
e9c952880eb1f983746674c618162984 *man/withTimeout.Rd
10da0eab23112b2cd3506aae370c0c2c *man/wrap.array.Rd
e748a256e5c8fd1154b5547d3f4672d0 *man/writeBinFragments.Rd
937af8b9679438990e355f6d2e18c8cf *man/writeByte.Java.Rd
084225ec04e65c16b45186a6aec0ed73 *man/writeDataFrame.data.frame.Rd
4d98cbdf19edc3965fa285a17e706080 *man/writeInt.Java.Rd
1d3fb4b404549b7e1de00bd0986b472a *man/writeRaw.MultiVerbose.Rd
717671ab5520db4d75063b4d1756558f *man/writeRaw.NullVerbose.Rd
7be53d4e9e258f90c9dad951c3d85e2b *man/writeRaw.Verbose.Rd
8bea6a3c00fa7b8905580a8fcc45f44b *man/writeShort.Java.Rd
bfa88b9488b31ffa53aaad33858f725e *man/writeUTF.Java.Rd
e0c0c3409dd64aa0cdbda485386f8c0c *tests/Arguments-FILES.R
3abe6f9d16044d4ac93ee989c1942743 *tests/FileProgressBar.R
e99b92e5479f5157600ac40975c5d09c *tests/GString.R
727adaa0df33a2bd528fe401d4ee81e1 *tests/Java.R
2ee06e2e4bba653b5746fd85ae79c3a8 *tests/MultiVerbose.R
aee20372d95dd57cc4270ac176aaaad5 *tests/NullVerbose.R
d13b407a5435b94399da227917296d67 *tests/Options.R
3726553f767ea5868fbe7d89bcd5988c *tests/ProgressBar.R
9f2c0635644adc91d584c4c05944b86f *tests/Settings.R
4ae7ac9fcf19676f15d0e990a4a6bef5 *tests/System.R
73b0565d0ce616408491ff79f754a685 *tests/TextStatusBar.R
5cb624febf4f541cf4fb8ae9e662dcda *tests/VComments.R
3028c3f435992168f227bebfb969dfad *tests/Verbose.R
b57d6175e2db21d2289bc64b23f1418e *tests/absolute-relative-paths.R
f4a00f773932cdd5ca4ab087bd331245 *tests/attachLocally.R
8ee8169f726d80f9d5f152220a2e8ce9 *tests/callHooks.R
a747624373f822ac7ef99e4dfeb0d105 *tests/capitalize.R
c998fbcc4d2aec9f16f1a0c3ad6a7244 *tests/captureOutput.R
affe26a37b2cf68fda15ab98b0e93437 *tests/cmdArgs.R
cff2de3251b2b7fc3002c5c996e136be *tests/colClasses.R
5397035a68c803d08b25ea84da0a5dee *tests/commandArgs.R
dbe219586657a4b1fdf9a9773513c7b2 *tests/compressFile.R
3f9ba2723c36524813de51e06f5d1571 *tests/compressPDF.R
9622d38ede285a5dc5eccd4340a8700d *tests/copyRenameFile.R
b2a952d5e9c6414b845916909466dcd1 *tests/countLines.R
33e6eb4740978544ab317db8a01c0185 *tests/cout.R
e2e15cd59b070b67cdf1fdb81488f47c *tests/createFileAtomically.R
5309be77da0e537e22dbbeb6c36515b3 *tests/createLink.R
c3a0573d7355d4001c1d12c75f1b8eb7 *tests/dataFrame.R
045373e11d83a8beefbd99d1bba342aa *tests/dimNA.R
f1426919ae7e4a45d8288a65b0b4a07d *tests/displayCode.R
5f0c6f143d242f1fd2c0efcdc75e993e *tests/doCall.R
3705f5c3ca3f261d7058df65bf24c952 *tests/eget.R
99523adcaea700e56b3e274b9eb4ba34 *tests/egsub.R
7d667e96e14b81282aed8bd7547ec01b *tests/env.R
b963293a22eb9eb98c0e024310403e19 *tests/extract.array.R
d7afe1d65d5836c66c44d598ff912ea0 *tests/fileAccess.R
66ee03a7703081dfaf9ff688313a377a *tests/filePath.R
f2cf49873a6138acc58e57119730042f *tests/findFiles.R
0314b27a216d7fa49a609987550f6e89 *tests/findSourceTraceback.R
ae291e4a8ccaca5bbfe9ae9151cee1cb *tests/gcDLLs.R
7316ba0e18d969e1b96670a35bcd6c96 *tests/gcat.R
e0c08f51d22240b1997972ca0e694f78 *tests/getOption.R
748b1fa844820112d8ce3069569ec2ec *tests/getParent.R
d34745a8c6e9d4cf779e442bbfc036ea *tests/hpaste.R
70cbff8412721cce5d1703388eb5f4ce *tests/insert.R
7ab249c5082fcee89795aa69a9d4942d *tests/intToHex.R
8e30d7476c7b3d5d9b3fd71fff8b6f3a *tests/isPackageLoaded.R
f917873152716fc629ac2191a0d4f13d *tests/isReplicated.R
df6848e2c00461c1937db1bb1a8640c5 *tests/isUrl.R
578176f80e651163f9ccaec2cf7ff2c1 *tests/isZero.R
23c87e748cff781bb26a63e9aeca5eda *tests/listDirectory.R
7da952a9e82bba3d0b017294316d043e *tests/loadObject.R
b3cf5d5157121387d849cc28fd3fa644 *tests/loadToEnv.R
d3b66d5438125c325be258f703db4e1a *tests/mkdirs.R
9ed41150019a9a4bd23b1519e101d87f *tests/mout.R
9aa7f3ff98259d90f9668fe76d1e2bb5 *tests/mpager.R
ef8863916e34245ff9a74e08f84a6e57 *tests/nullfile.R
94b0c66364a8ed939bc3de70abc10c21 *tests/parseRepos.R
890d16f09fdd963cb642d71809341cbb *tests/pushBackupFile.R
cb61dec46188558db99c7ec419682e14 *tests/pushTemporaryFile.R
66bbcb92a015242a219fda91d0269ff5 *tests/queryRCmdCheck.R
52fa9427e9c1fc2efbbe889617033bcd *tests/readBinFragments.R
b042e5513403949714028e00e777d027 *tests/readWindowsShellLink.R
e81abde49e1ce611d5ab5a8f3a74694a *tests/readWindowsShortcut.R
ea11b5ab54c78497ee33aa298a9db0e7 *tests/resample.R
05c19c6183fc703542262fd6fdde5304 *tests/seqToHumanReadable.R
dd556e486d0616df82b70d60c151c0d9 *tests/seqToIntervals.R
ec6464e16b2c025205997c1415302f92 *tests/sourceDirectory.R
49fcec14b8a6aeae1e5aedbeccc52da7 *tests/sourceTo.R
bbf0c7d1ba45fd93f3a6493a0c0bd44b *tests/splitByPattern.R
4eac4d6b9327308c782e0ea0878dc08a *tests/subplots.R
bdd86d58ecf5017c477ba4047008c32e *tests/symlinks,dirs.R
feb305c9f506888267f1241dd27e70fb *tests/symlinks,files.R
2e205ff4db55b6a4e6a146cedadc71a3 *tests/systemR.R
fef92152fdeadf9f1546696b2e6152ae *tests/tempvar.R
e069d9d0afbf1988d8f99d092ba5fbe9 *tests/tmpfile.R
812e8686ddfe343629873162d3ded8ae *tests/toCamelCase.R
600a095475e6d4ca326fd0c2b4fa858f *tests/touchFile.R
fee35af25a4071d25865343b6c2e3bce *tests/use.R
3b31277725c97bc3d57491a7ea990f0e *tests/useRepos.R
2958c72c21b285b370aabc0258a008c4 *tests/whichVector.R
b9c174f31723e22da9c82f95448537f2 *tests/withCapture.R
ed0c9f673fbd73d7c17a2bc0fb578b7b *tests/withLocale.R
e010e122955a78dde55795f875b7a5e3 *tests/withOptions.R
0b5aadcaa780f666429520045fcf2602 *tests/withRepos.R
7bf388f9e7d268b5aec36e90cb182225 *tests/withSeed.R
777ac19bf7bcb0029d73aa110e14aaaa *tests/withSink.R
8a8b154f0735635b20593cd8c6f8b44b *tests/withTimeout.R
e8f3a0700bf2a7ab6d52e70559032312 *tests/wrap.array.R
21b9f51280af498f487603743dd28899 *tests/writeDataFrame.R
84ed613188920118b43ffce5cf1432e6 *tests/zzz_finalizer_crash.R
R.utils/R/ 0000755 0001762 0000144 00000000000 14757146024 012025 5 ustar ligges users R.utils/R/tempvar.R 0000644 0001762 0000144 00000004331 14372747611 013631 0 ustar ligges users ###########################################################################/**
# @RdocFunction tempvar
#
# @title "Gets a unique non-existing temporary variable name"
#
# \description{
# @get "title", and optionally assigns it an initial value.
# }
#
# @synopsis
#
# \arguments{
# \item{prefix}{A @character string specifying the prefix of the
# temporary variable name.}
# \item{value}{(optional) If given, a variable with the temporary
# name is assigned this value. Only works if \code{envir} is an
# environment.}
# \item{envir}{An @environment, a named @list, or a named @data.frame,
# whose elements the temporary variable should not clash with.}
# \item{inherits}{A @logical specifying whether the enclosing frames
# of the environment should be searched or not.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @examples "../incl/tempvar.Rex"
#
# @author
#
# \seealso{
# @see "base::tempfile" and @see "base::assign".
# }
#
# @keyword programming
# @keyword internal
#*/###########################################################################
tempvar <- function(prefix="var", value, envir=parent.frame(), inherits=FALSE) {
maxTries <- 1e6
maxInt <- .Machine$integer.max
isEnv <- is.environment(envir)
if (!isEnv) {
names <- names(envir)
if (is.null(names)) {
stop("Argument 'envir' specifies an object without names attributes: ", mode(envir))
}
if (!missing(value)) {
stop("Can only assign a value to a temporary variables in an environment: ", mode(envir))
}
}
ii <- 0L
while (ii < maxTries) {
# Generate random variable name
idx <- sample.int(maxInt, size=1L)
name <- sprintf("%s%d", prefix, idx)
# Is it available?
if (isEnv) {
if (!exists(name, envir=envir, inherits=inherits)) {
# Assign a value?
if (!missing(value)) {
assign(name, value, envir=envir, inherits=inherits)
}
return(name)
}
} else {
if (!is.element(name, names)) {
return(name)
}
}
# Next try
ii <- ii + 1L
}
# Failed to find a unique temporary variable name
throw(sprintf("Failed to generate a unique non-existing temporary variable with prefix '%s'", prefix))
} # tempvar()
R.utils/R/printf.R 0000644 0001762 0000144 00000002304 14372747611 013453 0 ustar ligges users ###########################################################################/**
# @RdocDefault printf
#
# @title "C-style formatted output"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{fmt}{A @character vector of format strings.
# See same argument for @see "base::sprintf".}
# \item{...}{Additional arguments @see "base::sprintf".}
# \item{sep}{A @character @vector of strings to append after each element.}
# \item{file}{A @connection, or a @character of a file to print to.
# See same argument for @see "base::cat".}
# }
#
# \value{
# Returns nothing.
# }
#
# \examples{
# cat("Hello world\n")
# printf("Hello world\n")
#
# x <- 1.23
# cat(sprintf("x=\%.2f\n", x))
# printf("x=\%.2f\n", x)
#
# y <- 4.56
# cat(sprintf(c("x=\%.2f\n", "y=\%.2f\n"), c(x,y)), sep="")
# printf(c("x=\%.2f\n", "y=\%.2f\n"), c(x,y))
# }
#
# @author
#
# \seealso{
# For C-style formatting of @character strings, see @see "base::sprintf".
# }
#
# @keyword utilities
#*/###########################################################################
setMethodS3("printf", "default", function(fmt, ..., sep="", file="") {
base::cat(base::sprintf(fmt, ...), file=file, sep=sep)
})
R.utils/R/popTemporaryFile.R 0000644 0001762 0000144 00000007021 14757126655 015461 0 ustar ligges users ########################################################################/**
# @RdocDefault popTemporaryFile
#
# @title "Drops a temporary suffix from the temporary pathname"
#
# @synopsis
#
# \description{
# @get "title" and, by default, renames an existing temporary file
# accordingly.
# }
#
# \arguments{
# \item{filename}{The filename of the temporary file.}
# \item{path}{The path of the temporary file.}
# \item{suffix}{The suffix of the temporary filename to be dropped.}
# \item{isFile}{If @TRUE, the temporary file must exist and
# will be renamed. If @FALSE, it is only the pathname string
# that will be modified. For details, see below.}
# \item{...}{Not used.}
# \item{verbose}{A @logical or @see "Verbose".}
# }
#
# \value{
# Returns the pathname with the temporary suffix dropped.
# }
#
# \details{
# If \code{isFile} is @FALSE, the pathname where the suffix of the
# temporary pathname has been dropped is returned.
# If \code{isFile} is @TRUE, the temporary file is renamed.
# Then, if the temporary file does not exists or it was not successfully
# renamed, an exception is thrown.
# }
#
# @author
#
# \seealso{
# See @see "pushTemporaryFile" for more details and an example.
# }
#
# @keyword "utilities"
# @keyword "programming"
# @keyword "IO"
#*/#########################################################################
setMethodS3("popTemporaryFile", "default", function(filename, path=NULL, suffix=".tmp", isFile=TRUE, ..., verbose=FALSE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'isFile':
isFile <- Arguments$getLogical(isFile)
# Argument 'filename' & 'path':
pathnameT <- Arguments$getWritablePathname(filename, path=path,
mustExist=isFile, mustNotExist=!isFile)
# Argument 'suffix':
suffix <- Arguments$getCharacter(suffix)
# Argument 'verbose':
verbose <- Arguments$getVerbose(verbose)
if (verbose) {
pushState(verbose)
on.exit(popState(verbose))
}
verbose && enter(verbose, "Dropping temporary suffix from file")
verbose && cat(verbose, "Temporary pathname: ", pathnameT)
verbose && cat(verbose, "Suffix: ", suffix)
# Drop suffix from temporary pathname
pattern <- sprintf("%s$", suffix)
pattern <- gsub(".", "\\.", pattern, fixed=TRUE)
pattern <- gsub("[\\$]+$", "$", pattern)
pattern <- Arguments$getRegularExpression(pattern)
verbose && cat(verbose, "Regular expression for suffix: ", pattern)
# Assert that suffix exists in the temporary pathname
if (regexpr(pattern, pathnameT) == -1) {
throw(sprintf("Cannot rename temporary pathname. The specified temporary pathname does not contain the specified suffix ('%s'): %s", suffix, pathnameT))
}
pathname <- gsub(pattern, "", pathnameT)
verbose && cat(verbose, "Pathname: ", pathname)
pathname <- Arguments$getWritablePathname(pathname, mustNotExist=TRUE)
if (isFile) {
verbose && enter(verbose, "Renaming existing file")
res <- file.rename(pathnameT, pathname)
verbose && cat(verbose, "Result: ", res)
verbose && exit(verbose)
if (!isFile(pathname)) {
throw("Failed to rename temporary file (final file does not exist): ", pathnameT, " -> ", pathname)
}
if (isFile(pathnameT)) {
throw("Failed to rename temporary file (temporary file still exists): ", pathnameT, " -> ", pathname)
}
} # if (isFile)
verbose && exit(verbose)
pathname
}) # popTemporaryFile()
R.utils/R/capitalize.R 0000644 0001762 0000144 00000004256 14525311762 014300 0 ustar ligges users #########################################################################/**
# @RdocDefault capitalize
# @alias decapitalize
# @alias decapitalize.default
#
# @title "Capitalizes/decapitalizes each character string in a vector"
#
# \description{
# Capitalizes/decapitalized (making the first letter upper/lower case) of
# each character string in a vector.
# }
#
# \usage{
# @usage capitalize,default
# @usage decapitalize,default
# }
#
# \arguments{
# \item{str}{A @vector of @character strings to be capitalized.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @vector of @character strings of the same length as the input
# vector.
# }
#
# @author
#
# @examples "../incl/capitalize.Rex"
#
# \seealso{
# @see "R.utils::toCamelCase".
# }
#
# @keyword "programming"
#*/#########################################################################
setMethodS3("capitalize", "default", function(str, ...) {
# Nothing to do?
n <- length(str)
if (n == 0L) {
return(str)
}
# Missing values?
nas <- is.na(str)
idxs <- which(nas)
# All missing values? => nothing to do.
if (length(idxs) == n) {
return(str)
}
# Allocate result
res <- character(length=n)
# Preserve missing values
if (length(idxs) > 0L) {
res[idxs] <- NA_character_
}
# Capitilize
idxs <- which(!nas)
if (length(idxs) > 0L) {
t <- str[idxs]
first <- substring(t, first=1L, last=1L)
tail <- substring(t, first=2L)
first <- toupper(first)
res[idxs] <- paste(first, tail, sep="")
}
res
})
setMethodS3("decapitalize", "default", function(str, ...) {
# Nothing to do?
n <- length(str)
if (n == 0L) {
return(str)
}
# Missing values?
nas <- is.na(str)
idxs <- which(nas)
# All missing values? => nothing to do.
if (length(idxs) == n) {
return(str)
}
# Allocate result
res <- character(length=n)
# Preserve missing values
if (length(idxs) > 0L) {
res[idxs] <- NA_character_
}
# Decapitilize
idxs <- which(!nas)
if (length(idxs) > 0L) {
t <- str[idxs]
first <- substring(t, first=1L, last=1L)
tail <- substring(t, first=2L)
first <- tolower(first)
res[idxs] <- paste(first, tail, sep="")
}
res
})
R.utils/R/onGarbageCollect.R 0000644 0001762 0000144 00000002266 14372747611 015353 0 ustar ligges users ###########################################################################/**
# @RdocDefault onGarbageCollect
#
# @title "Registers a function to be called when the R garbage collector
# is (detected to be) running"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{fcn}{A @function to be called without argument.}
# \item{action}{A @character string specifying how the hook function is
# added to list of hooks.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) the hooks successfully called.
# }
#
# @author
#
# \examples{\dontrun{
# onGarbageCollect(function(...) {
# message("The R garbage collector is running!")
# })
# }}
#
# @keyword programming
#*/###########################################################################
setMethodS3("onGarbageCollect", "default", function(fcn, action=c("prepend", "append", "replace"), ...) {
# Argument 'fcn':
if (!is.function(fcn)) {
throw("Argument 'fcn' is not a function: ", class(fcn)[1])
}
# Argument 'action':
action <- match.arg(action)
## setHook("onGarbageCollect", fcn, action=action)
dummyEnv <- new.env()
reg.finalizer(dummyEnv, fcn, onexit=FALSE)
invisible()
})
R.utils/R/mout.R 0000644 0001762 0000144 00000007366 14372747611 013152 0 ustar ligges users ###########################################################################/**
# @RdocFunction mout
# @alias mprint
# @alias mshow
# @alias mcat
# @alias mstr
# @alias mprintf
# @alias cmsg
# @alias cout
# @alias cprint
# @alias cshow
# @alias ccat
# @alias cstr
# @alias cprintf
#
# @title "Miscellaneous functions for outputting via message()"
#
# \description{
# @get "title".
# These "m*" methods work analogously to their corresponding "*" methods
# @see "base::print", @see "base::cat", @see "methods::show",
# @see "utils::str", and @see "printf" but uses @see "base::message"
# to output the content, which in turn outputs to standard error.
# The \code{mout()} method can be used for all other output methods,
# e.g. \code{mout(write(x, file=stdout()))}.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to the underlying output method.}
# \item{appendLF}{A @logical specifying whether to append a newline at
# the end or not.}
# }
#
# \value{
# Returns what the @see "base::message" returns.
# }
#
# \examples{
# print(letters[1:8])
# mprint(letters[1:8])
#
# cat(c(letters[1:8], "\n"))
# mcat(c(letters[1:8], "\n"))
#
# str(letters[1:8])
# mstr(letters[1:8])
#
# printf("x=\%d\n", 1:3)
# mprintf("x=\%d\n", 1:3)
# }
#
# @author
#
# @keyword utilities
#*/###########################################################################
mout <- function(..., appendLF=FALSE) {
bfr <- captureOutput(..., envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
message(bfr, appendLF=appendLF)
}
mprint <- function(..., appendLF=FALSE) {
bfr <- captureOutput(print(...), envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
message(bfr, appendLF=appendLF)
}
mcat <- function(..., appendLF=FALSE) {
bfr <- captureOutput(cat(...), envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
message(bfr, appendLF=appendLF)
}
mstr <- function(..., appendLF=FALSE) {
bfr <- captureOutput(str(...), envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
message(bfr, appendLF=appendLF)
}
mshow <- function(..., appendLF=FALSE) {
bfr <- captureOutput(show(...), envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
message(bfr, appendLF=appendLF)
}
mprintf <- function(..., appendLF=FALSE) {
bfr <- sprintf(...)
message(bfr, appendLF=appendLF)
}
cmsg <- function(..., appendLF=FALSE) {
## Write output to a temporary file
## FIXME: Do we have worry about encoding?!? /HB 2015-02-01
fh <- tempfile()
on.exit(file.remove(fh))
cat(..., file=fh)
if (appendLF) cat("\n", file=fh, append=TRUE)
## Display file such that it cannot be
## captured/intercepted by R.
if (.Platform$OS.type == "windows") {
file.show(fh, pager="console", header="", title="", delete.file=FALSE)
} else {
system(sprintf("cat %s", fh))
}
invisible()
}
cout <- function(..., appendLF=FALSE) {
bfr <- captureOutput(..., envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
cmsg(bfr, appendLF=appendLF)
}
cprint <- function(..., appendLF=FALSE) {
bfr <- captureOutput(print(...), envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
cmsg(bfr, appendLF=appendLF)
}
ccat <- function(..., appendLF=FALSE) {
bfr <- captureOutput(cat(...), envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
cmsg(bfr, appendLF=appendLF)
}
cstr <- function(..., appendLF=FALSE) {
bfr <- captureOutput(str(...), envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
cmsg(bfr, appendLF=appendLF)
}
cshow <- function(..., appendLF=FALSE) {
bfr <- captureOutput(show(...), envir=parent.frame())
bfr <- paste(c(bfr, ""), collapse="\n")
cmsg(bfr, appendLF=appendLF)
}
cprintf <- function(..., appendLF=FALSE) {
bfr <- sprintf(...)
cmsg(bfr, appendLF=appendLF)
}
R.utils/R/wrap.array.R 0000644 0001762 0000144 00000011407 14372747611 014243 0 ustar ligges users ###########################################################################/**
# @set "class=array"
# @RdocMethod wrap
# @alias wrap.matrix
# @alias wrap.data.frame
#
# @title "Reshape an array or a matrix by permuting and/or joining dimensions"
#
# \description{
# @get "title".
#
# A useful application of this is to reshape a multidimensional @array
# to a @matrix, which then can be saved to file using for instance
# \code{write.table()}.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{An @array or a @matrix.}
# \item{map}{A @list of length equal to the number of dimensions in the
# reshaped array. Each element should be an @integer @vectors specifying
# the dimensions to be joined in corresponding new dimension.
# One element may equal @NA to indicate that that dimension should be
# a join of all non-specified (remaining) dimensions.
# Default is to wrap everything into a @vector.
# }
# \item{sep}{A @character pasting joined dimension names.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns an @array of \code{length(map)} dimensions, where the first
# dimension is of size \code{prod(map[[1]])}, the second
# \code{prod(map[[2]])}, and so on.
# }
#
# \details{
# If the indices in \code{unlist(map)} is in a non-increasing order,
# \link[base:aperm]{aperm()} will be called, which requires reshuffling
# of array elements in memory. In all other cases, the reshaping of the
# array does not require this, but only fast modifications of
# attributes \code{dim} and \code{dimnames}.
# }
#
# @examples "../incl/wrap.array.Rex"
#
# @author
#
# \seealso{
# @seemethod "unwrap".
# See \link[base:aperm]{aperm()}.
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("wrap", "array", function(x, map=list(NA), sep=".", ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'x':
if (!is.array(x) && !is.matrix(x))
throw("Argument 'x' is not an array or a matrix: ", class(x)[1])
if (!is.list(map))
throw("Argument 'map' is not a list: ", class(map)[1])
umap <- unlist(map)
if (any(duplicated(umap))) {
throw("Argument 'map' contains duplicated dimension indices: ",
paste(umap[duplicated(umap)], collapse=", "))
}
# Extract information
dim <- dim(x)
ndims <- length(dim)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate dimension map
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Look for missing dimension indices
missingDims <- setdiff(1:ndims, umap)
if (length(missingDims) > 0) {
wildcard <- is.na(map)
if (any(wildcard)) {
map[[which(wildcard)]] <- missingDims
umap <- unlist(map)
} else {
throw("Argument 'map' miss some dimensions: ",
paste(missingDims, collapse=", "))
}
}
# Look for non-existing dimension indices
falseDims <- setdiff(umap, 1:ndims)
if (length(falseDims) > 0) {
throw("Argument 'map' contains non-existing dimensions: ",
paste(falseDims, collapse=", "))
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Permute dimensions?
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (any(diff(umap) < 0)) {
# Permute dimensions
perm <- umap
x <- aperm(x, perm=perm)
# Remap old dimension indices to the new ones for the map
map <- lapply(map, FUN=function(ii) match(ii, perm))
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Reshape array
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Calculate the dimension sizes of the new array
dim <- dim(x)
dim2 <- unlist(lapply(map, FUN=function(ii) prod(dim[ii])), use.names = FALSE)
# Generate the new dimension names.
# Note that the values in array 'x' are stored such that the *leftmost*
# subscript moves fastest. When we change the reshape the array by
# changing the dimensions, the dimension names must be consistent with
# this rule.
dimnames <- dimnames(x)
dimnames2 <- lapply(map, FUN=function(iis) {
names <- NULL
for (ii in iis) {
if (is.null(names)) {
names <- dimnames[[ii]]
} else {
names <- paste(names, rep(dimnames[[ii]], each=length(names)), sep=sep)
}
}
names
})
# Now, reshape the array
dim(x) <- dim2
dimnames(x) <- dimnames2
x
})
setMethodS3("wrap", "matrix", function(x, ...) {
wrap.array(x, ...)
})
setMethodS3("wrap", "data.frame", function(x, ...) {
wrap(as.matrix(x), ...)
})
R.utils/R/FileProgressBar.R 0000644 0001762 0000144 00000005133 14372747611 015205 0 ustar ligges users ###########################################################################/**
# @RdocClass FileProgressBar
#
# @title "A progress bar that sets the size of a file accordingly"
#
# \description{
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{The pathname of the output file.}
# \item{...}{Other arguments accepted by the @see "ProgressBar"
# constructor.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \details{
# @get "title". This class useful to check the progress of a batch job by
# just querying the size of a file, for instance, via ftp.
# }
#
# \examples{
# \dontrun{
# @include "../incl/FileProgressBar.Rex"
# }
# }
#
# @author
#*/###########################################################################
setConstructorS3("FileProgressBar", function(pathname=NULL, ...) {
this <- extend(ProgressBar(..., newlineWhenDone=FALSE), "FileProgressBar",
pathname=as.character(pathname)
)
if (!is.null(pathname)) {
# Resets the progress bar and creates the file
reset(this)
}
this
})
#########################################################################/**
# @RdocMethod update
#
# @title "Updates file progress bar"
#
# @synopsis
#
# \description{
# @get "title".
# }
#
# \arguments{
# \item{visual}{If @TRUE, the file is resized according to the value of
# the progress bar, otherwise not.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("update", "FileProgressBar", function(object, visual=TRUE, ...) {
# To please R CMD check...
this <- object
if (visual) {
# Create bar string
s <- getBarString(this)
# Cut initial character representing value zero off.
s <- substring(s, 2)
# Creates an empty file
cat(file=this$pathname, s)
}
})
#########################################################################/**
# @RdocMethod cleanup
#
# @title "Removes the progress file for a file progress bar"
#
# @synopsis
#
# \description{
# @get "title".
# }
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) @TRUE, if there is no progress file afterwards.
# Otherwise, @FALSE is returned.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("cleanup", "FileProgressBar", function(object, ...) {
# To please R CMD check...
this <- object
if (isFile(this$pathname))
file.remove(this$pathname)
invisible(isFile(this$pathname))
})
R.utils/R/isPackageLoaded.R 0000644 0001762 0000144 00000002115 14372747611 015151 0 ustar ligges users ###########################################################################/**
# @RdocDefault isPackageLoaded
#
# @title "Checks if a package is loaded or not"
#
# \description{
# @get "title".
# Note that, contrary to \code{\link[base:library]{require}()},
# this function does not load the package if not loaded.
# }
#
# @synopsis
#
# \arguments{
# \item{package}{The name of the package.}
# \item{version}{A @character string specifying the version to test for.
# If @NULL, any version is tested for.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @logical.
# }
#
# @author
#
# \seealso{
# To check if a package is installed or not, see @see "isPackageInstalled".
# }
#
# @keyword utilities
# @keyword package
#*/###########################################################################
setMethodS3("isPackageLoaded", "default", function(package, version=NULL, ...) {
s <- search()
if (is.null(version)) {
s <- sub("_[0-9.-]*", "", s)
} else {
package <- paste(package, version, sep="_")
}
pattern <- sprintf("package:%s", package)
(pattern %in% s)
})
R.utils/R/compressPDF.R 0000644 0001762 0000144 00000010426 14372747611 014342 0 ustar ligges users ###########################################################################/**
# @RdocDefault compressPDF
#
# @title "Compresses a PDF (into a new PDF)"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{filename, path}{The filename and (optional) path of the
# PDF to be compressed.}
# \item{outFilename, outPath}{The generated PDF.}
# \item{skip}{If @TRUE and an existing output file, then it is returned.}
# \item{overwrite}{If @FALSE, an error is thrown if the output file
# already exists, otherwise not.}
# \item{compression}{A @character @vector of compression methods
# to apply. This overrides any low-level arguments passed via
# \code{...} that @see "tools::compactPDF".}
# \item{...}{Additional arguments passed to @see "tools::compactPDF",
# e.g. \code{gs_quality}.}
# }
#
# \value{
# Returns the pathname of the generated PDF.
# }
#
# \examples{\dontrun{
# pathnameZ <- compressPDF("report.pdf")
# }}
#
# @author
#
# \seealso{
# Internally @see "tools::compactPDF" is utilized.
# }
#
# @keyword file
# @keyword IO
#*/###########################################################################
setMethodS3("compressPDF", "default", function(filename, path=NULL, outFilename=basename(pathname), outPath="compressedPDFs", skip=FALSE, overwrite=FALSE, compression="gs(ebook)+qpdf", ...) {
## Argument 'filename' and 'path':
pathname <- Arguments$getReadablePathname(filename, path=path)
## Argument 'outFilename' and 'outPath':
pathnameD <- Arguments$getWritablePathname(outFilename, path=outPath, mustNotExist=FALSE)
## Argument 'compression':
if (!is.null(compression)) {
compression <- Arguments$getCharacters(compression)
compression <- trim(compression)
compression <- compression[nzchar(compression)]
}
## Skipping?
if (isFile(pathnameD)) {
if (skip) return(pathnameD)
if (!overwrite) Arguments$getWritablePathname(pathnameD, mustNotExist=TRUE)
}
## Parse 'compression' argument
compress_args <- list()
if (length(compression) > 0L) {
compressionT <- unlist(strsplit(compression, split="+", fixed=TRUE))
compressionT <- trim(compressionT)
compressionT <- compressionT[nzchar(compressionT)]
cmethod <- gsub("[(].*", "", compressionT)
carg <- gsub("[)].*", "", gsub(".*[(]", "", compressionT))
keep <- is.element(cmethod, c("gs", "qpdf"))
if (any(!keep)) {
warning("Ignoring unknown PDF compression method: ",
paste(sQuote(cmethod[!keep]), collapse=", "))
compression <- compression[keep]
cmethod <- cmethod[keep]
carg <- carg[keep]
}
for (kk in seq_along(cmethod)) {
if (cmethod[kk] == "gs") {
opts <- unlist(strsplit(carg[kk], split=",", fixed=TRUE))
if (length(opts) > 0L) compress_args$gs_quality <- opts[1L]
if (length(opts) > 1L) compress_args$gs_extras <- opts[-1L]
}
}
} # if (length(compression) > 0L)
## WORKAROUND #1: tools::compactPDF(paths) compresses all PDFs in paths
## if length(paths) == 1 so working with a temporary directory.
pathD <- dirname(pathnameD)
pathT <- sprintf("%s.tmp", pathD)
pathT <- Arguments$getWritablePath(pathT)
on.exit(removeDirectory(pathT))
## WORKAROUND #2: tools::compactPDF(paths) does not handle spaces
## in filenames.
pathnameDT <- tempfile(tmpdir=pathT, fileext=".pdf")
copyFile(pathname, pathnameDT)
## File size before
size0 <- file.info(pathnameDT)$size
## Arguments to tools::compactPDF()
args <- list(paths=pathT, ...)
## Override with 'compression' specifications
for (name in names(compress_args)) {
args[[name]] <- compress_args[[name]]
}
## Call tools::compactPDF()
res <- do.call(tools::compactPDF, args=args)
## File size after
size1 <- file.info(pathnameDT)$size
## If compression < 10% or < 10kB, then considered not worth it
## by tools::compactPDF()
if (nrow(res) == 0L) {
warning(sprintf("PDF compression saved less than 10%% or less than 10kB on the original file size (%g bytes) so tools::compactPDF() decided to keep the PDF as is: %s", file.info(pathnameDT)$size, pathnameDT))
}
renameFile(pathnameDT, pathnameD, overwrite=TRUE)
## Report on compression ratio
comp <- c(size0, size1)
names(comp) <- c(pathname, pathnameD)
attr(pathnameD, "result") <- comp
pathnameD
})
R.utils/R/Sys.readlink.Windows.R 0000644 0001762 0000144 00000003761 14757126520 016155 0 ustar ligges users # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# WARNING:
.Windows.Sys.readlink <- function(path) {
if (!file.exists(path)) return(NA_character_)
## If equal to tempdir(), then we assume it's not a symbolic link
if (path == tempdir()) return(path)
# Only files with zero size are candidates for symbolic file links
info <- file.info(path)
if (is.na(info$size) || info$size > 0) return("")
## Skip on Windows?
## REASON/BACKGROUND:
## The below shell("dir", ...) approach is very slow (~20-30s) for folders
## with 1,000s of files and folders, e.g. the parent folder of tempdir()
## on CRAN's MS Windows hosts. /Uwe Ligges 2023-11-21, /HB 2024-02-17
## See https://github.com/HenrikBengtsson/R.utils/issues/152
if (!isTRUE(getOption("R.utils::Sys.readlinks2.Windows", TRUE))) {
return("")
}
# Temporarily change working directory
path <- normalizePath(path, mustWork=FALSE)
dir <- dirname(path)
opwd <- setwd(dir)
on.exit(setwd(opwd))
path <- basename(path)
# List all files
bfr <- shell("dir", shell=Sys.getenv("COMSPEC"),
mustWork=TRUE, intern=TRUE)
setwd(opwd)
# Search for symbolic file or directory links
pattern <- sprintf(".*[ ]+[ ]+(%s)[ ]+\\[(.+)\\][ ]*$", path)
# On R > 4.3, bfr encoding may be problematic in some locales
# https://github.com/HenrikBengtsson/R.utils/issues/152
bfr <- suppressWarnings(grep(pattern, bfr, value=TRUE))
# Not a symbolic link?
if (length(bfr) == 0L) return("")
# Sanity check
link <- gsub(pattern, "\\2", bfr)
.stop_if_not(identical(link, path))
# Extract the target
target <- gsub(pattern, "\\3", bfr)
# Relative path?
if (!isAbsolutePath(target)) {
# Prepend working directory
target <- file.path(dir, target)
# Return the relative pathname, iff possible
target <- getRelativePath(target)
}
target
} # .Windows.Sys.readlink()
R.utils/R/hsize.R 0000644 0001762 0000144 00000005613 14526006463 013273 0 ustar ligges users ###########################################################################/**
# @RdocFunction hsize
# @alias hsize.numeric
# @alias hsize.object_size
#
# @title "Convert byte sizes into human-readable byte sizes"
#
# \description{
# @get "title".
# }
#
# \usage{
# @usage hsize,numeric
# @usage hsize,object_size
# }
#
# \arguments{
# \item{sizes}{A @numeric @vector of sizes.}
# \item{digits}{Number of digits to be presented in the give unit.}
# \item{units}{A @character string specifying type of units to use.}
# \item{bytes}{The string used for units of bytes without a prefix.
# Applied only if \code{units="auto"}.}
# \item{...}{Not used.}
# }
#
# \value{
# A @character @vector.
# }
#
# @examples "../incl/hsize.Rex"
#
# @author
#
# \seealso{
# @see "utils::object.size".
# }
#
# @keyword programming
# @keyword internal
#*/###########################################################################
setMethodS3("hsize", "numeric", function(sizes, digits=1L, units="auto", standard=getOption("hsize.standard", "IEC"), bytes=getOption("hsize.bytes", "B"), ...) {
standard <- match.arg(standard, choices=c("IEC", "JEDEC", "SI"))
.stop_if_not(is.character(units), length(units) == 1L)
.stop_if_not(is.numeric(digits), length(digits) == 1L)
.stop_if_not(is.character(bytes), length(bytes) == 1L)
nsizes <- length(sizes)
kunits <- list(
IEC = c(bytes=0, B=0, KiB=1, MiB=2, GiB=3, TiB=4, PiB=5, EiB=6, ZiB=7, YiB=8),
JEDEC = c(bytes=0, B=0, KB=1, MB=2, GB=3),
SI = c(bytes=0, B=0, kB=1, MB=2, GB=3, TB=4, PB=5, EB=6, ZB=7, YB=8)
)
## Infer standard from unit?
if (units != "auto") {
idx <- which(sapply(kunits, FUN=function(x) any(units == names(x))))
if (length(idx) == 0L) {
stop(sprintf("Unknown units: %s", sQuote(units)))
}
standard <- names(idx[1])
}
kunits <- kunits[[standard]]
base <- switch(standard, IEC=1024, JEDEC=1024, SI=1000)
if (units == "auto") {
## Keep the "bytes" alternative specified
excl <- setdiff(c("bytes", "B"), bytes)
kunits <- kunits[-which(names(kunits) == excl)]
exps <- log(sizes, base=base)
exps <- floor(exps)
exps[exps < 0] <- 0
maxexp <- max(kunits)
exps[exps > maxexp] <- maxexp
units <- names(kunits)[exps+1L]
positions <- rep(digits, length.out=nsizes)
positions[exps == 0] <- 0L
} else {
exps <- kunits[units]
if (is.na(exps)) {
stop(sprintf("Unknown units for standard %s: %s", sQuote(standard), sQuote(units)))
}
units <- rep(units, times=nsizes)
}
## Use '1 byte' (not '1 bytes')
ones <- which(sizes == 1)
if (length(ones) > 0) units[ones] <- gsub("s$", "", units[ones])
sizes <- round(sizes / base^exps, digits=digits)
positions <- rep(digits, length.out=nsizes)
positions[exps == 0] <- 0L
sprintf("%.*f %s", positions, sizes, units)
})
setMethodS3("hsize", "object_size", function(sizes, ...) {
hsize(as.numeric(sizes), ...)
})
R.utils/R/isReplicated.R 0000644 0001762 0000144 00000002440 14372747611 014562 0 ustar ligges users ###########################################################################/**
# @RdocFunction isReplicated
# @alias replicates
#
# @title "Identifies all entries with replicated values"
#
# \description{
# @get "title", that is, with values that exist more than once.
# }
#
# \usage{
# isReplicated(x, ...)
# replicates(x, ...)
# }
#
# \arguments{
# \item{x}{A @vector of length K.}
# \item{...}{Additional arguments passed to @see "base::duplicated".}
# }
#
# \value{
# A @logical @vector of length K,
# where @TRUE indicates that the value exists elsewhere,
# otherwise not.
# }
#
# \details{
# Let \code{reps <- isReplicated(x)}. Then it always holds that:
# \itemize{
# \item \code{reps == rev(isReplicated(rev(x)))}
# \item \code{reps == duplicated(x) | duplicated(x, fromLast=TRUE)}
# \item \code{reps == !is.element(x, setdiff(x, unique(x[duplicated(x)])))}
# }
# }
#
# @examples "../incl/isReplicated.Rex"
#
# @author
#
# \seealso{
# Internally @see "base::duplicated" is used.
# See also @see "isSingle".
# }
#*/###########################################################################
isReplicated <- function(x, ...) {
dupsF <- duplicated(x, ...)
dupsR <- duplicated(x, ..., fromLast=TRUE)
(dupsF | dupsR)
}
replicates <- function(x, ...) {
x[isReplicated(x, ...)]
}
R.utils/R/NullVerbose.R 0000644 0001762 0000144 00000006616 14372747611 014423 0 ustar ligges users ###########################################################################/**
# @RdocClass NullVerbose
#
# @title "A Verbose class ignoring everything"
#
# \description{
# @classhierarchy
#
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Ignored.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @examples "../incl/NullVerbose.Rex"
#
# @author
#
# @keyword programming
# @keyword IO
#*/###########################################################################
setConstructorS3("NullVerbose", function(...) {
extend(Verbose(core=FALSE, ...), "NullVerbose")
})
###########################################################################/**
# @RdocMethod writeRaw
# @aliasmethod cat
# @aliasmethod printf
# @aliasmethod enter
# @aliasmethod exit
# @aliasmethod print
# @aliasmethod str
# @aliasmethod summary
# @aliasmethod evaluate
# @aliasmethod newline
# @aliasmethod ruler
# @aliasmethod header
#
# @title "All output methods"
#
# \description{
# @get "title" of this class ignores their input arguments and outputs
# nothing.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Ignored.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
# Create all methods that Verbose have, but make them ignore everything.
setMethodS3("writeRaw", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("cat", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("printf", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("enter", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("exit", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("print", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("str", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("summary", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("evaluate", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("newline", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("ruler", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
setMethodS3("header", "NullVerbose", function(...) {invisible(FALSE)}, protected=TRUE)
###########################################################################/**
# @RdocMethod isVisible
#
# @title "Checks if a certain verbose level will be shown or not"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns always @FALSE.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("isVisible", "NullVerbose", function(this, ...) {
FALSE
})
###########################################################################/**
# @RdocMethod isOn
#
# @title "Checks if the output is on"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns always @FALSE.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("isOn", "NullVerbose", function(this, ...) {
FALSE
})
R.utils/R/Options.R 0000644 0001762 0000144 00000032215 14372747611 013610 0 ustar ligges users #########################################################################/**
# @RdocClass Options
#
# @title "The Options class"
#
# @synopsis
#
# \arguments{
# \item{options}{A tree @list structure of options.}
# \item{...}{Not used.}
# }
#
# \description{
# @classhierarchy
#
# A class to set and get either options stored in a @list tree structure.
#
# Each option has a pathname. The format of a pathname is similar to a
# (Unix) filesystem pathname, e.g. "graphics/cex". See examples for
# more details.
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \value{
# The constructor returns an Options object.
# }
#
# \details{
# Note, this class and its methods do \emph{not} operate on the global
# options structure defined in \R (\link{options}).
# }
#
# @examples "../incl/Options.Rex"
#
# @author
#
# @keyword programming
#*/#########################################################################
setConstructorS3("Options", function(options=list(), ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'options':
if (!is.list(options))
throw("Argument 'options' must be a list: ", mode(options))
extend(Object(), "Options",
.options = options
)
})
###########################################################################/**
# @RdocMethod "as.character"
#
# @title "Returns a character string version of this object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("as.character", "Options", function(x, ...) {
# To please R CMD check
this <- x
s <- paste(class(this)[1], ": ", nbrOfOptions(this), " options set.", sep="")
s
})
#########################################################################/**
# @RdocMethod as.list
#
# @title "Gets a list representation of the options"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns a tree @list structure.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("as.list", "Options", function(x, ...) {
# To please R CMD check
this <- x
as.list(this$.options)
})
#########################################################################/**
# @RdocMethod equals
#
# @title "Checks if this object is equal to another Options object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{other}{Another Options object.}
# \item{...}{Not used.}
# }
#
# \value{Returns @TRUE if they are equal, otherwise @FALSE.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("equals", "Options", function(this, other, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
equals.list <- function(list1, list2) {
if (length(list1) != length(list2))
return(FALSE)
for (kk in seq_along(list1)) {
obj1 <- list1[[kk]]
obj2 <- list2[[kk]]
if (is.list(obj1)) {
comp <- equals.list(obj1, obj2)
} else {
comp <- equals(obj1, obj2)
}
if (!comp)
return(comp)
} # for (kk ...)
TRUE
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Main comparison
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (!inherits(other, "Options"))
return(FALSE)
list1 <- as.list(this)
list2 <- as.list(other)
equals.list(list1, list2)
})
###########################################################################/**
# @RdocMethod str
#
# @title "Prints the structure of the options"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{header}{A @character string header to be printed at the top.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("str", "Options", function(object, header=paste(class(this)[1], ":\n", sep=""), ...) {
# To please R CMD check
this <- object
cat(header)
res <- list()
for (name in names(this))
res[[name]] <- getOption(this, name)
str(res)
})
#########################################################################/**
# @RdocMethod names
#
# @title "Gets the full pathname of all (non-list) options"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns a @vector of @character strings.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("names", "Options", function(x, ...) {
# To please R CMD check
this <- x
names(getLeaves(this, ...))
})
#########################################################################/**
# @RdocMethod getLeaves
#
# @title "Gets all (non-list) options in a flat list"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns a flat @list structure.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("getLeaves", "Options", function(this, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
getLeaves <- function(list, ...) {
if (length(list) == 0)
return(NULL)
names <- names(list)
isList <- unlist(lapply(list, FUN=is.list))
leafs <- list[!isList]
trees <- list[isList]
treeNames <- names(trees)
for (kk in seq_along(trees)) {
tree <- trees[[kk]]
treeName <- treeNames[kk]
treeLeaves <- getLeaves(tree, ...)
names(treeLeaves) <- paste(treeName, names(treeLeaves), sep="/")
leafs <- c(leafs, treeLeaves)
}
leafs
}
getLeaves(as.list(this))
})
#########################################################################/**
# @RdocMethod nbrOfOptions
#
# @title "Gets the number of options set"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns an @integer.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("nbrOfOptions", "Options", function(this, ...) {
length(names(this))
})
#########################################################################/**
# @RdocMethod hasOption
#
# @title "Checks if an option exists"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{A single or a @vector of @character strings specifying
# the paths to the options to be queried.}
# \item{...}{Not used.}
# }
#
# \value{Returns a @logical (@vector).}
#
# @author
#
# \seealso{
# @seemethod "getOption".
# @seemethod "setOption".
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("hasOption", "Options", function(this, pathname, ...) {
if (length(pathname) > 1) {
res <- c()
for (kk in seq_along(pathname))
res[kk] <- hasOption(this, pathname[kk])
names(res) <- pathname
return(res)
}
# Argument 'pathname':
pathname <- as.character(pathname)
if (length(pathname) != 1) {
throw("Argument 'pathname' must be a single character string: ",
paste(pathname, collapse=", "))
}
if (regexpr("\\.", pathname) != -1) {
throw("Argument 'pathname' must not contain a period: ", pathname)
}
pathname <- unlist(strsplit(pathname, split="/"))
if (any(nchar(pathname, type="chars") == 0))
throw("Argument 'pathname' contains a zero length elements.")
cur <- as.list(this)
if (length(cur) == 0)
return(FALSE)
depth <- length(pathname)
for (kk in seq_len(depth)) {
key <- pathname[kk]
keys <- names(cur)
if (key %in% keys) {
cur <- cur[[key]]
if (kk == depth)
return(TRUE)
} else {
return(FALSE)
}
if (!is.list(cur))
break
}
FALSE
})
#########################################################################/**
# @RdocMethod getOption
#
# @title "Gets an option"
#
# \description{
# @get "title" in the options tree structure or return a default value.
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{A single or a @vector of @character strings specifying
# the paths to the options to be queried.
# By default the complete options structure is returned.}
# \item{defaultValue}{The default value to be returned, if option is
# missing. If multiple options are queried at the same times, multiple
# default values may be specified as a @vector or a @list.}
# \item{...}{Not used.}
# }
#
# \value{If a single option is queried, a single value is returned.
# If a @vector of options are queried, a @list of values are returned.
# For non-existing options, the default value is returned.}
#
# @author
#
# \seealso{
# @seemethod "hasOption".
# @seemethod "setOption".
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("getOption", "Options", function(this, pathname=NULL, defaultValue=NULL, ...) {
if (length(pathname) > 1) {
defaultValue <- rep(defaultValue, length.out=length(pathname))
res <- list()
for (kk in seq_along(pathname))
res[[kk]] <- getOption(this, pathname[kk], defaultValue[kk])
names(res) <- pathname
return(res)
}
if (is.null(pathname))
return(as.list(this))
# Argument 'pathname':
pathname <- as.character(pathname)
if (length(pathname) != 1) {
throw("Argument 'pathname' must be a single character string: ",
paste(pathname, collapse=", "))
}
# if (regexpr("\\.", pathname) != -1) {
# throw("Argument 'pathname' must not contain a period: ", pathname)
# }
pathname <- unlist(strsplit(pathname, split="/"))
if (any(nchar(pathname, type="chars") == 0))
throw("Argument 'pathname' contains a zero length elements.")
cur <- as.list(this)
if (length(pathname) == 0)
return(cur)
if (length(cur) == 0)
return(defaultValue)
depth <- length(pathname)
for (kk in seq_len(depth)) {
key <- pathname[kk]
keys <- names(cur)
if (key %in% keys) {
cur <- cur[[key]]
if (kk == depth)
return(cur)
} else {
return(defaultValue)
}
if (!is.list(cur))
break
}
defaultValue
})
#########################################################################/**
# @RdocMethod setOption
#
# @title "Sets an option"
#
# \description{
# @get "title" in the options tree structure.
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{A single @character string specifying the path to the
# option.}
# \item{value}{The value to be assigned to the option.}
# \item{overwrite}{If @TRUE, already existing options are overwritten,
# otherwise not.}
# \item{...}{Not used.}
# }
#
# \value{Returns (invisibly) the old option value.}
#
# @author
#
# \seealso{
# @seemethod "hasOption".
# @seemethod "setOption".
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("setOption", "Options", function(this, pathname, value, overwrite=TRUE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
setOptionList <- function(list, path, value) {
if (length(path) == 1) {
list[[path]] <- value
} else {
name <- path[1]
if (!is.list(list[[name]]))
list[[name]] <- list()
list[[name]] <- setOptionList(list[[name]], path[-1], value)
}
list
} # setOptionList()
# Argument 'pathname':
pathname <- as.character(pathname)
if (length(pathname) != 1) {
throw("Argument 'pathname' must be a single character string: ",
paste(pathname, collapse=", "))
}
# if (regexpr("\\.", pathname) != -1) {
# throw("Argument 'pathname' must not contain a period: ", pathname)
# }
oldValue <- getOption(this, pathname)
# If option is already set, should it be overwritten.
if (!is.null(oldValue) && !overwrite)
return(invisible(oldValue))
pathname <- unlist(strsplit(pathname, split="/"))
if (any(nchar(pathname, type="chars") == 0))
throw("Argument 'pathname' contains a zero length elements.")
if (is.null(this$.options))
this$.options <- list()
this$.options <- setOptionList(this$.options, pathname, value)
invisible(oldValue)
})
R.utils/R/mpager.R 0000644 0001762 0000144 00000002747 14372747611 013437 0 ustar ligges users ###########################################################################/**
# @RdocFunction mpager
#
# @title "A \"pager\" function that outputs to standard error"
#
# \description{
# @get "title" and is compatible with @see "base::file.show".
# }
#
# @synopsis
#
# \arguments{
# \item{files}{A @character @vector of K pathnames.}
# \item{header}{A @character @vector of K headers.}
# \item{title}{A @character string.}
# \item{delete.file}{If @TRUE, the files are deleted after displayed,
# otherwise not.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @see "base::file.show" and argument \code{pager}.
# }
#
# @keyword programming
# @keyword IO
# @keyword file
#*/###########################################################################
mpager <- function(files, header=NULL, title="R Information", delete.file=FALSE) {
mbar <- function(ch="-", width=getOption("width")-1L) {
mprintf("%s\n", paste(rep(ch, times=width), collapse=""))
}
if (length(title) > 0L && is.character(title) && nchar(title) > 0L) {
mbar("=")
mprintf("%s\n", title)
mbar("=")
mcat("\n")
}
for (ii in seq_along(files)) {
file <- files[ii]
hdr <- header[ii]
if (length(hdr) > 0L && is.character(hdr) && nchar(hdr) > 0L) {
if (ii > 1L) mcat("\n")
mbar("-")
mprintf("%s\n", hdr)
mbar("-")
}
bfr <- readLines(file)
mcat(bfr, sep="\n", collapse="\n")
if (delete.file) {
file.remove(file)
}
}
} # mpager()
R.utils/R/000.R 0000644 0001762 0000144 00000000313 14372747611 012446 0 ustar ligges users ## Look for existing generic functions also in imported namespaces.
## This will affect whether setGenericS3() creates a generic function
## or not.
options("R.methodsS3:checkImports:setGenericS3"=TRUE)
R.utils/R/writeDataFrame.R 0000644 0001762 0000144 00000013064 14372747611 015055 0 ustar ligges users ########################################################################/**
# @set "class=data.frame"
# @RdocMethod writeDataFrame
# @alias writeDataFrame
#
# @title "Writes a data.frame to tabular text file"
#
# @synopsis
#
# \description{
# @get "title" with an optional header.
# }
#
# \arguments{
# \item{data}{A @data.frame.}
# \item{file}{A @connection or a filename to write to.}
# \item{path}{The directory where the file will be written.}
# \item{sep, quote, row.names, col.names, ...}{Additional arguments
# passed to @see "utils::write.table".}
# \item{header}{An optional named @list of header rows to be written
# at the beginning of the file. If @NULL, no header will be written.}
# \item{createdBy, createdOn, nbrOfRows}{If non-@NULL, common header
# rows to be added to the header.}
# \item{headerPrefix}{A @character string specifying the prefix of each
# header row.}
# \item{headerSep}{A @character string specifying the character
# separating the header name and header values.}
# \item{append}{If @TRUE, the output is appended to an existing file.}
# \item{overwrite}{If @TRUE, an existing file is overwritten.}
# }
#
# \value{
# Returns (invisibly) the pathname to the file written
# (or the @connection written to).
# }
#
# @author
#
# \seealso{
# @see "utils::write.table".
# @see "readTable".
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("writeDataFrame", "data.frame", function(data, file, path=NULL, sep="\t", quote=FALSE, row.names=FALSE, col.names=!append, ..., header=list(), createdBy=NULL, createdOn=format(Sys.time(), format="%Y-%m-%d %H:%M:%S %Z"), nbrOfRows=nrow(data), headerPrefix="# ", headerSep=": ", append=FALSE, overwrite=FALSE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'file' & 'path':
if (inherits(file, "connection")) {
con <- file
} else {
pathname <- Arguments$getWritablePathname(file, path=path,
mustNotExist=(!append && !overwrite))
con <- NULL
}
# Argument 'sep':
if (!is.character(sep)) {
throw("Argument 'sep' must be a character: ", mode(sep))
## TO ADD? read.table() requires nchar(sep) == 1 /HB 2015-10-09
## } else if (nchar(sep) != 1L) {
## throw("Argument 'sep' must be a single character: ", sQuote(sep))
}
# Argument 'header':
if (!is.null(header)) {
if (!is.list(header)) {
throw("Argument 'header' is not a list: ", class(header)[1])
}
}
# Argument 'headerPrefix':
headerPrefix <- Arguments$getCharacter(headerPrefix)
# Argument 'headerSep':
headerSep <- Arguments$getCharacter(headerSep)
# Argument 'createdBy':
if (!is.null(createdBy)) {
createdBy <- Arguments$getCharacter(createdBy)
}
# Argument 'createdOn':
if (!is.null(createdOn)) {
createdOn <- Arguments$getCharacter(createdOn)
}
# Argument 'nbrOfRows':
if (!is.null(nbrOfRows)) {
nbrOfRows <- Arguments$getInteger(nbrOfRows)
}
# Argument 'append':
append <- Arguments$getLogical(append)
if (append) {
# Don't write headers when appending
if (missing(header)) header <- NULL
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Pre-write assertions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Assert that none of the fields contains a 'sep' character
if (is.logical(quote) && !quote) {
for (kk in seq_along(data)) {
value <- data[[kk]]
if (any(grepl(sep, value))) {
throw(sprintf("Cannot write data using this field separator (sep=%s) without quotes (quote=FALSE), because column #%d contains the same symbol", sQuote(sep), kk))
}
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Build header
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (!is.null(header)) {
if (!is.null(createdBy)) {
header$createdBy <- createdBy
}
if (!is.null(createdOn)) {
header$createdOn <- createdOn
}
header$nbrOfRows <- nbrOfRows
header$nbrOfColumns <- ncol(data)
header$columnNames <- colnames(data)
header$columnClasses <- sapply(data, FUN=function(x) class(x)[1L])
header <- lapply(header, FUN=paste, collapse=sep)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Write to file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (is.null(con)) {
# Remove existing file?
if (!append && overwrite && isFile(pathname)) {
file.remove(pathname)
}
# Write to a temporary file (which may be an existing file)
pathnameT <- pushTemporaryFile(pathname, isFile=isFile(pathname))
# Open file connection
open <- ifelse(append, "at", "wt")
con <- file(pathnameT, open=open)
on.exit({
if (!is.null(con)) {
close(con)
con <- NULL
}
})
}
# Write header
if (!is.null(header)) {
bfr <- paste(headerPrefix, names(header), headerSep, header, sep="")
cat(file=con, bfr, sep="\n")
}
# Write data section
write.table(file=con, data, sep=sep, quote=quote,
row.names=row.names, col.names=col.names, ...)
if (inherits(file, "connection")) {
res <- con
} else {
# Close opened file connection
close(con)
con <- NULL
# Rename temporary file
pathname <- popTemporaryFile(pathnameT)
res <- pathname
}
invisible(res)
}) # writeDataFrame()
R.utils/R/dataFrame.R 0000644 0001762 0000144 00000002304 14372747611 014035 0 ustar ligges users ###########################################################################/**
# @RdocDefault dataFrame
#
# @title "Allocates a data frame with given column classes"
#
# @synopsis
#
# \description{
# @get "title".
# }
#
# \arguments{
# \item{colClasses}{A @character @vector of column classes,
# cf. @see "utils::read.table".}
# \item{nrow}{An @integer specifying the number of rows of the
# allocated data frame.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns an NxK @data.frame where N equals \code{nrow} and
# K equals \code{length(colClasses)}.
# }
#
# \examples{
# df <- dataFrame(colClasses=c(a="integer", b="double"), nrow=10)
# df[,1] <- sample(1:nrow(df))
# df[,2] <- rnorm(nrow(df))
# print(df)
# }
#
# \seealso{
# @data.frame.
# }
#
# @keyword manip
# @keyword utilities
#*/###########################################################################
setMethodS3("dataFrame", "default", function(colClasses, nrow=1, ...) {
df <- vector("list", length=length(colClasses))
names(df) <- names(colClasses)
for (kk in seq_along(df)) {
df[[kk]] <- vector(colClasses[kk], length=nrow)
}
attr(df, "row.names") <- seq_len(nrow)
class(df) <- "data.frame"
df
}, private=TRUE)
R.utils/R/downloadFile.R 0000644 0001762 0000144 00000020551 14757126520 014561 0 ustar ligges users ###########################################################################/**
# @set "class=character"
# @RdocMethod downloadFile
# @alias downloadFile
#
# @title "Downloads a file"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{url}{A @character string specifying the URL to be downloaded.}
# \item{filename, path}{(optional) @character strings specifying the
# local filename and the path of the downloaded file.}
# \item{skip}{If @TRUE, an already downloaded file is skipped.}
# \item{overwrite}{If @TRUE, an already downloaded file is overwritten,
# otherwise an error is thrown.}
# \item{...}{Additional arguments passed to @see "utils::download.file".}
# \item{username, password}{@character strings specifying the username
# and password for authenticated downloads. The alternative is to
# specify these via the URL.}
# \item{binary}{If @TRUE, the file is downloaded exactly "as is", that is,
# byte by byte (recommended).}
# \item{dropEmpty}{If @TRUE and the downloaded file is empty, the file
# is ignored and @NULL is returned.}
# \item{verbose}{A @logical, @integer, or a @see "Verbose" object.}
# }
#
# \value{
# Returns the local pathname to the downloaded filename,
# or @NULL if no file was downloaded.
# }
#
# \details{
# Currently arguments \code{username} and \code{password} are only used
# for downloads via URL protocol 'https'. The 'https' protocol requires
# that either of 'curl' or 'wget' are available on the system.
# }
#
# \examples{\dontrun{
# pathname <- downloadFile("https://www.r-project.org/index.html", path="www.r-project.org/")
# print(pathname)
# }}
#
# @author
#
# \seealso{
# Internally @see "utils::download.file" is used.
# That function may generate an empty file if the URL is not available.
# }
#
# @keyword programming
# @keyword file
#*/###########################################################################
setMethodS3("downloadFile", "character", function(url, filename=basename(url), path=NULL, skip=TRUE, overwrite=!skip, ..., username=NULL, password=NULL, binary=TRUE, dropEmpty=TRUE, verbose=FALSE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'url':
url <- Arguments$getCharacter(url)
# Argument 'skip':
skip <- Arguments$getLogical(skip)
# Argument 'overwrite':
overwrite <- Arguments$getLogical(overwrite)
# Argument 'filename' & 'path':
filename <- Arguments$getReadablePathname(filename, adjust="url",
mustExist=FALSE)
pathname <- Arguments$getWritablePathname(filename, path=path,
mustNotExist=(!overwrite && !skip))
# Argument 'username':
if (!is.null(username)) {
username <- Arguments$getCharacter(username)
}
# Argument 'password':
if (!is.null(password)) {
password <- Arguments$getCharacter(password)
}
# Argument 'binary':
binary <- Arguments$getLogical(binary)
# Argument 'verbose':
verbose <- Arguments$getVerbose(verbose)
if (verbose) {
pushState(verbose)
on.exit(popState(verbose))
}
verbose && enter(verbose, "Downloading URL")
verbose && cat(verbose, "URL: ", url)
protocol <- gsub("^([^:]*)://.*", "\\1", url, ignore.case=TRUE)
protocol <- tolower(protocol)
verbose && cat(verbose, "Protocol: ", protocol)
# Is username and password given by the URL?
pattern <- "^([^:]*)://([^:]*):([^:]*)@.*"
if (regexpr(pattern, url) != -1) {
if (!is.null(username)) {
warning("Argument 'username' was overridden by username specified by argument 'url'.")
}
if (!is.null(password)) {
warning("Argument 'password' was overridden by password specified by argument 'url'.")
}
username <- gsub(pattern, "\\2", url)
password <- gsub(pattern, "\\3", url)
}
verbose && cat(verbose, "Pathname: ", pathname)
if (isFile(pathname)) {
if (skip) {
verbose && cat(verbose, "Already downloaded. Skipping.")
verbose && exit(verbose)
return(pathname)
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Download to a temporary pathname
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
pathnameT <- sprintf("%s.tmp", pathname)
pathnameT <- Arguments$getWritablePathname(pathnameT, mustNotExist=TRUE)
on.exit({
if (isFile(pathnameT)) {
file.remove(pathnameT)
}
}, add=TRUE)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Download file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
verbose && enter(verbose, "Downloading")
if (is.element(protocol, c("https"))) {
verbose && enter(verbose, "Downloading via HTTPS")
# Locate external executables
bin <- Sys.which(c("curl", "wget"))
verbose && cat(verbose, "Available external executables:")
verbose && print(verbose, bin)
keep <- nzchar(bin)
if (!any(keep)) {
throw("Cannot download file over HTTPS protocol. Failed to locate external download software (%s): %s", paste(sQuote(names(bin)), collapse=", "), url)
}
bin <- bin[keep]
bin <- bin[1L]
verbose && printf(verbose, "Using external download software %s: %s\n", sQuote(names(bin)), bin)
verbose && enter(verbose, "Setting up command-line options")
# Command-line options
args <- NULL
timeout <- getOption("timeout")
if (!is.null(timeout)) {
timeout <- as.integer(timeout)
stopifnot(length(timeout) == 1L, !is.na(timeout))
}
if (names(bin) == "curl") {
# Less strict (=more likely to succeed)
arg <- "--insecure"
args <- c(args, arg)
# Follow redirects
arg <- "--location"
args <- c(args, arg)
if (!is.null(username)) {
arg <- sprintf("--user %s", username)
if (!is.null(password)) {
arg <- sprintf("%s:%s", arg, password)
}
args <- c(args, arg)
}
# Timeout?
if (!is.null(timeout)) {
arg <- sprintf("--connect-timeout %d", timeout)
args <- c(args, arg)
}
# Output file
arg <- sprintf("--output \"%s\"", pathnameT)
args <- c(args, arg)
# URL to download
args <- c(args, url)
} else if (names(bin) == "wget") {
# Less strict (=more likely to succeed)
arg <- "--no-check-certificate"
args <- c(args, arg)
if (!is.null(username)) {
arg <- sprintf("--http-user=%s", username)
args <- c(args, arg)
}
if (!is.null(password)) {
arg <- sprintf("--http-passwd=%s", password)
args <- c(args, arg)
}
# Timeout?
if (!is.null(timeout)) {
arg <- sprintf("--timeout=%d", timeout)
args <- c(args, arg)
}
# Output file
arg <- sprintf("--output-document=\"%s\"", pathnameT)
args <- c(args, arg)
# URL to download
args <- c(args, url)
}
verbose && print(verbose, args)
verbose && exit(verbose)
res <- system2(bin, args=args)
verbose && exit(verbose)
} else {
mode <- ifelse(binary, "wb", "w")
verbose && cat(verbose, "Download mode: ", mode)
res <- download.file(url, destfile=pathnameT, mode=mode,
quiet=!isVisible(verbose), ...)
}
verbose && cat(verbose, "Downloading finished\n")
verbose && cat(verbose, "Download result:", res)
verbose && exit(verbose)
# Remove failed or "empty" downloads
fi <- file.info2(pathnameT)
verbose && cat(verbose, "Downloaded file:")
verbose && str(verbose, fi)
if (res != 0 || is.na(fi$size) || (dropEmpty && fi$size == 0)) {
file.remove(pathnameT)
verbose && cat(verbose, "Removed downloaded file because download failed or the file was empty: ", pathnameT)
pathnameT <- NULL
pathname <- NULL
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Rename temporary pathname
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (!is.null(pathnameT)) {
file.rename(pathnameT, pathname)
if (!isFile(pathname)) {
throw("Failed to rename temporary filename: ",
pathnameT, " -> ", pathname)
}
if (isFile(pathnameT)) {
throw("Failed to remove temporary filename: ", pathnameT)
}
}
verbose && exit(verbose)
pathname
})
R.utils/R/subplots.R 0000644 0001762 0000144 00000005611 14372747611 014030 0 ustar ligges users #########################################################################/**
# @RdocDefault subplots
#
# @title "Creates a grid of subplots"
#
# \description{
# @get "title" in the current figure. If arguments
# \code{nrow} and \code{ncol} are given a \code{nrow}-by-\code{ncol}
# grid of subplots are created. If only argument \code{n} is given
# then a r-by-s grid is created where |r-s| <= 1, i.e. a square or almost
# a square of subplots is created. If \code{n} and \code{nrow} is
# given then a grid with \code{nrow} rows and at least \code{n} subplots
# are created. Similar if \code{n} and \code{ncol} is given.
# The argument \code{byrow} specifies if the order of the subplots
# should be rowwise (\code{byrow=TRUE}) or columnwise.
# }
#
# @synopsis
#
# \arguments{
# \item{n}{If given, the minimum number of subplots.}
# \item{nrow}{If given, the number of rows the grid of subplots should
# contain.}
# \item{ncol}{If given, the number of columns the grid of subplots should
# contain.}
# \item{byrow}{If @TRUE, the panels are ordered row by row in the grid,
# otherwise column by column.}
# \item{...}{Not used.}
# }
#
# \value{Returns the @matrix containing the order of plots.}
#
# @author
#
# \examples{
# subplots(nrow=2, ncol=3) # 2-by-3 grid of subplots
# subplots(n=6, nrow=2) # 2-by-3 grid of subplots
# subplots(n=5, ncol=2) # 3-by-2 grid of subplots
# subplots(1) # (Reset) to a 1-by-1 grid of subplots
# subplots(2) # 1-by-2 grid of subplots
# subplots(3) # 2-by-2 grid of subplots
# l <- subplots(8) # 3-by-3 grid of subplots
# layout.show(length(l))
# }
#
# \seealso{
# @see "graphics::layout" and \code{layout.show}().
# }
#*/#########################################################################
setMethodS3("subplots", "default", function(n=1, nrow=NULL, ncol=NULL,
byrow=TRUE, ...) {
# If a vector was passed, then use the length of the vector for 'n'
if (!missing(n) && length(n) > 1)
n <- length(n)
if (!is.null(nrow) && !is.null(ncol) && !missing(n)) {
if (n != nrow*ncol)
stop("Arguments 'nrow' and 'ncol' is incompatible with argument 'n'. Do you really want to specify all three?!")
}
if (missing(n)) {
layout <- matrix(seq_len(nrow*ncol), nrow=nrow, ncol=ncol, byrow=byrow)
} else {
if (n == 1) {
nrow <- ncol <- 1
} else if (!is.null(nrow)) {
ncol <- ceiling(n / nrow)
} else if (!is.null(ncol)) {
nrow <- ceiling(n / ncol)
} else {
side <- sqrt(n)
nrow <- floor(side)
ncol <- ncol-1
ncol <- ceiling(n / nrow)
if (ncol - nrow > 1) {
nrow <- nrow+1
ncol <- ceiling(n / nrow)
}
}
layout <- matrix(seq_len(nrow*ncol), nrow=nrow, ncol=ncol, byrow=byrow)
}
layout(layout, ...)
invisible(layout)
})
R.utils/R/saveObject.R 0000644 0001762 0000144 00000006371 14372747611 014246 0 ustar ligges users ###########################################################################/**
# @RdocDefault saveObject
#
# @title "Saves an object to a file or a connection"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{The object to be saved.}
# \item{file}{A filename or @connection where the object should be saved.
# If @NULL, the filename will be the hash code of the object plus ".xdr".}
# \item{path}{Optional path, if \code{file} is a filename.}
# \item{format}{File format.}
# \item{compress}{If @TRUE, the file is compressed to, otherwise not.}
# \item{...}{Other arguments accepted by \code{save()} in the base package.}
# \item{safe}{If @TRUE and \code{file} is a file, then, in order to lower
# the risk for incomplete files, the object is first written to a
# temporary file, which is then renamed to the final name.}
# }
#
# \value{
# Returns (invisibly) the pathname or the @connection.
# }
#
# @author
#
# \seealso{
# @see "loadObject" to load an object from file.
# @see "digest::digest" for how hash codes are calculated from an object.
# See also @see "base::saveRDS".
# }
#
# @keyword programming
# @keyword IO
#*/###########################################################################
setMethodS3("saveObject", "default", function(object, file=NULL, path=NULL, format=c("auto", "xdr", "rds"), compress=TRUE, ..., safe=TRUE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'format':
format <- match.arg(format)
# Infer 'format' from filename extension? Default is "xdr"
if (format == "auto") {
format <- tools::file_ext(file)
format <- tolower(format)
## Here 'format' can be character(0L) or nchar(format) >= 0L
if (!isTRUE(is.element(format, c("xdr", "rds")))) format <- "xdr"
}
# Argument 'file':
if (is.null(file)) {
requireNamespace("digest") || throw("Package not loaded: digest")
file <- digest::digest(as.list(object)) # Might be slow.
file <- sprintf("%s.%s", file, format)
}
saveToFile <- (!inherits(file, "connection"))
if (saveToFile) {
file <- filePath(path, file, expandLinks="any")
}
# Write to a temporary file?
if (safe && saveToFile) {
# Final pathname
pathname <- file
# Temporary pathname
pathnameT <- sprintf("%s.tmp", pathname)
if (file.exists(pathnameT)) {
throw("Cannot save to file. Temporary file already exists: ", pathnameT)
}
# Write to a temporary file
file <- pathnameT
on.exit({
if (!is.null(pathnameT) && file.exists(pathnameT)) {
file.remove(pathnameT)
}
}, add=TRUE)
}
if (format == "xdr") {
saveLoadReference <- object
base::save(saveLoadReference, file=file, ..., compress=compress, ascii=FALSE)
} else if (format == "rds") {
saveRDS(object, file=file, ascii=FALSE, compress=compress, ...)
}
# Rename temporary file?
if (safe && saveToFile) {
file.rename(pathnameT, pathname)
if (!file.exists(pathname) || file.exists(pathnameT)) {
throw("Failed to rename temporary file: ", pathnameT, " -> ", pathname)
}
pathnameT <- NULL
file <- pathname
}
invisible(file)
}) # saveObject()
R.utils/R/splitByPattern.R 0000644 0001762 0000144 00000003332 14372747611 015137 0 ustar ligges users #########################################################################/**
# @RdocDefault splitByPattern
#
# @title "Splits a single character string by pattern"
#
# \description{
# @get "title". The main difference compared to @see "base::strsplit"
# is that this method also returns the part of the string that matched
# the pattern. Also, it only takes a single character string.
# }
#
# @synopsis
#
# \arguments{
# \item{str}{A single @character string to be split.}
# \item{pattern}{A regular expression @character string.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a named @character @vector with names equal to \code{"TRUE"}
# if element is a pattern part and \code{"FALSE"} otherwise.
# }
#
# @examples "../incl/splitByPattern.Rex"
#
# @author
#
# \seealso{
# Compare to @see "base::strsplit".
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("splitByPattern", "default", function(str, pattern, ...) {
# Argument 'str':
str <- Arguments$getCharacter(str)
# Argument 'pattern':
pattern <- Arguments$getCharacter(pattern)
parts <- c()
while(TRUE) {
pos <- regexpr(pattern, str)
if (pos == -1)
break
text <- substring(str, first=1, last=pos-1); # This is allowed!
lastPos <- pos+attr(pos, "match.length")-1
flag <- substring(str, first=pos, last=lastPos)
str <- substring(str, first=lastPos+1)
parts <- c(parts, text, flag)
}
if (nchar(str) > 0)
parts <- c(parts, str)
# Add indicator if a pattern string or not.
isPattern <- rep(c(FALSE, TRUE), length.out=length(parts))
names(parts) <- isPattern
if (nchar(parts[1]) == 0)
parts <- parts[-1]
parts
}) # splitByPattern()
R.utils/R/Arguments.R 0000644 0001762 0000144 00000114533 14564045444 014124 0 ustar ligges users ###########################################################################/**
# @RdocClass Arguments
#
# @title "Static class to validate and process arguments"
#
# \description{
# @classhierarchy
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# @keyword programming
#*/###########################################################################
setConstructorS3("Arguments", function(...) {
extend(Object(), "Arguments")
})
#########################################################################/**
# @RdocMethod getFilename
#
# @title "Gets and validates a filename"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{filename}{A @character string.}
# \item{nchar}{An @integer @vector of length two specifying the range
# of valid filename lengths.}
# \item{class}{A @character string specifying the class of valid
# filenames.}
# \item{.name}{The name of the argument validated.}
# \item{.type}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string if filename is valid,
# otherwise an exception is thrown.
# }
#
# \section{Missing values}{
# If \code{filename} is a missing value, then an exception is thrown.
# }
#
# \details{
# When argument \code{class="safe"}, the following 86 ASCII characters
# are allowed in filenames:
# \preformatted{
# #$%&'()+,-.0123456789;= (24 including initial space)
# @ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_ (31)
# `abcdefghijklmnopqrstuvwxyz{|}~ (31)
# }
# This class of filenames has been extensively tested on for
# cross-platform support on Microsoft Windows, macOS, and various
# Unix flavors.
# }
#
# \references{
# [1] Microsoft, \emph{Naming Files, Paths, and Namespaces}, 2018.
# \url{https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file}.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("getFilename", "Arguments", function(static, filename, nchar=c(1,128), class=c("safe"), .name=NULL, .type="filename", ...) {
##
## OLD NOTES:
## Valid filename characters:
## * The FTP RFCs require (7-bit) ASCII characters (and presumably not control
## characters either). The 95 printable ASCII characters are (note initial
## space):
##
## !"#$%&'()*+,-./0123456789:;<=>? (32)
## @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_ (32)
## `abcdefghijklmnopqrstuvwxyz{|}~ (31)
##
## * On Windows the following 9 characters aren't allowed: \ / : * ? " < > !.
## This leaves us with:
##
## #$%&'()+,-.0123456789;= (24)
## @ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_ (31)
## `abcdefghijklmnopqrstuvwxyz{|}~ (31)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument '.name':
if (is.null(.name)) {
.name <- as.character(deparse(substitute(filename)))
}
# Argument 'filename':
if (is.na(filename)) {
throw("Argument 'filename' cannot be a missing value: ", filename)
}
filename <- getCharacter(static, filename, nchar=nchar, .name=.name)
# Argument 'class':
class <- match.arg(class)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Filter out valid characters
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
chars <- filename
# Always valid characters
chars <- gsub("[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0-9_.,]", "", chars)
chars <- gsub("[-]", "", chars)
chars <- gsub("[+]", "", chars)
# Filter out according to classes.
if ("safe" %in% class) {
chars <- gsub("[ ]", "", chars)
chars <- gsub("[\\[\\]]", "", chars)
chars <- gsub("[#$%&'()`{|}~]", "", chars)
chars <- gsub("[=]", "", chars)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Check for remaining (=invalid) characters
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (nchar(chars, type="chars") > 0L) {
chars <- unlist(strsplit(chars, split=""))
chars <- sort(unique(chars))
chars <- sprintf("'%s'", chars)
chars <- paste(chars, collapse=", ")
throw(sprintf("Not a valid %s. Argument '%s' contains non-valid %s characters (%s): %s", .type, .name, .type, chars, filename))
}
filename
}, static=TRUE, private=TRUE)
#########################################################################/**
# @RdocMethod getReadablePathname
#
# @title "Gets a readable pathname"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{file}{A @character string specifying the file.}
# \item{path}{A @character string specifying the path.}
# \item{mustExist}{If @TRUE, the pathname must exists and be readable,
# otherwise an exception is thrown. If @FALSE, no such test is
# performed.}
# \item{absolute}{If @TRUE, the absolute pathname is returned.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string of the absolute pathname of the file.
# }
#
# \section{Missing values}{
# If \code{file} or \code{path} is @NA and \code{mustExist} is @FALSE,
# then (character) @NA is returned, otherwise an exception is thrown.
# }
#
# \section{Windows}{
# If a too long pathname is detected on Windows, an informative warning
# is given.
# The maximum number of symbols in a Windows pathname is 256, including
# file separators '/' or '\', but excluding the drive letter, and initial
# file separator (e.g. 'C:/'), and the string terminator ('\\0'), cf.
# 'MSDN - Naming a File or Directory', Microsoft. In R, the limit is
# one symbol less, i.e. 255.
# }
#
# @author
#
# \seealso{
# @seemethod "getWritablePathname"
# @see "R.utils::filePath".
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getReadablePathname", "Arguments", function(static, file=NULL, path=NULL, mustExist=TRUE, absolute=FALSE, adjust=c("none", "url"), ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'file':
if (!is.null(file)) {
if (inherits(file, "connection")) {
throw("In this context, argument 'file' cannot be a connection.")
}
file <- getCharacter(static, file, length=c(1,1))
}
# Ignore 'path'?
if (isAbsolutePath(file)) path <- NULL
# Argument 'path':
if (!is.null(path)) {
path <- getCharacter(static, path, length=c(1,1))
}
if (is.null(file) && is.null(path)) {
throw("Both argument 'file' and 'path' are NULL.")
}
# Argument 'mustExist':
mustExist <- getLogical(static, mustExist)
# Backward compatibility (absolutePath -> absolute)
absolutePath <- list(...)$absolutePath
if (!is.null(absolutePath)) absolute <- absolutePath
# Argument 'absolute':
absolute <- getLogical(static, absolute)
# Argument 'adjust':
adjust <- match.arg(adjust)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Process arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (mustExist) {
if (!is.null(file) && is.na(file)) {
throw("No such file/directory because argument 'file' is NA.")
}
if (!is.null(path) && is.na(path)) {
throw("No such file/directory because argument 'path' is NA.")
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Make sure / is properly split up
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (is.null(path)) {
pathname <- file
} else if (is.null(file)) {
pathname <- path
} else {
pathname <- file.path(path, file)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Windows: The maximum number of symbols in a Windows pathname is 256,
# in R it's 255. For more details, see:
# https://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (.Platform$OS.type == "windows") {
if (!is.na(pathname) && nchar(pathname, type="chars") > 255L) {
msg <- sprintf("A too long pathname (%d characters) was detected on Windows, where maximum number of symbols is 256 and in R it is one less: %s", nchar(pathname, type="chars"), pathname)
warning(msg)
}
}
path <- dirname(pathname)
file <- basename(pathname)
pathname <- NULL
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Adjust filename?
# FIXME: Adjust also directory names. /HB 2014-05-04
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (adjust == "url") {
# Decode non-problematic filename characters, e.g. '%20' -> ' '
file <- URLdecode(file)
# But encode problematic ones, e.g. ':', '*'
file <- gsub(":", "%3A", file, fixed=TRUE)
file <- gsub("*", "%2A", file, fixed=TRUE)
file <- gsub("\\", "%5C", file, fixed=TRUE)
# Encode tilde (~) unless first character
# FIX ME: Needed or not? /HB 2014-05-04
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Expand links
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# NB: Here 'mustExist=TRUE' means that filePath() will always return
# a pathname, not that it will give an error if file does not exist.
pathname <- filePath(path, file, expandLinks="any", mustExist=TRUE)
if (absolute) {
pathname <- getAbsolutePath(pathname)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Windows: The maximum number of symbols in a Windows pathname is 256,
# in R it's 255. For more details, see:
# https://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (.Platform$OS.type == "windows") {
if (!is.na(pathname) && nchar(pathname, type="chars") > 255L) {
msg <- sprintf("A too long pathname (%d characters) was detected on Windows, where maximum number of symbols is 256 and in R it is one less: %s", nchar(pathname, type="chars"), pathname)
warning(msg)
}
}
if (mustExist) {
# Check if file exists
if (!file.exists(pathname)) {
# Locate the first parent directory that does not exist
depth <- 1
while(TRUE) {
parent <- getParent(pathname, depth=depth)
if (is.na(parent) || is.null(parent) || isDirectory(parent))
break
depth <- depth + 1
} # while()
reason <- NULL
if (is.na(parent) || is.null(parent)) {
parent <- getParent(pathname)
if (is.na(parent) || is.null(parent)) {
reason <- "no such file in the current working directory"
} else {
reason <- sprintf("none of the parent directories [%s/] exist", parent)
}
} else {
reason <- sprintf("%s/ exists, but nothing beyond", parent)
}
if (!is.null(reason) && !isAbsolutePath(pathname)) {
reason <- sprintf("%s; current directory is '%s'", reason, getwd())
}
reason <- sprintf(" (%s)", reason)
throw("Pathname not found: ", pathname, reason)
}
# Check if file permissions allow reading
if (fileAccess(pathname, mode=4) == -1) {
throw("Pathname exists, but there is no permission to read file: ", pathname)
}
} # if (mustExist)
pathname
}, static=TRUE)
setMethodS3("getReadablePath", "Arguments", function(static, path=NULL, mustExist=TRUE, ...) {
if (is.null(path))
return(NULL)
path <- getReadablePathname(static, path=path, mustExist=mustExist, ...)
if (mustExist && !is.na(path) && !isDirectory(path)) {
throw("Argument 'path' is not a directory: ", path)
}
path
}, static=TRUE, protected=TRUE)
#########################################################################/**
# @RdocMethod getReadablePathnames
#
# @title "Gets a readable pathname"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{files}{A @character @vector of filenames.}
# \item{paths}{A @character @vector of paths.}
# \item{...}{Arguments passed to @seemethod "getReadablePathname".}
# }
#
# \value{
# Returns a @character @vector of the pathnames for the files.
# }
#
# @author
#
# \seealso{
# @seemethod "getReadablePathname"
# @see "R.utils::filePath".
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getReadablePathnames", "Arguments", function(static, files=NULL, paths=NULL, ...) {
nbrOfFiles <- length(files)
# Argument 'paths':
if (length(paths) > nbrOfFiles) {
throw("Argument 'paths' is longer than argument 'files': ",
length(paths), " > ", nbrOfFiles)
}
# Expand argument 'paths' to be of same length as 'files'
if (!is.null(paths)) {
paths <- rep(paths, length.out=nbrOfFiles)
}
pathnames <- list()
for (kk in seq_len(nbrOfFiles)) {
pathnames[[kk]] <- getReadablePathname(static, files[kk],
path=paths[kk], ...)
}
unlist(pathnames)
}, static=TRUE)
#########################################################################/**
# @RdocMethod getWritablePathname
#
# @title "Gets a writable pathname"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @seemethod "getReadablePathname".}
# \item{mustExist}{If @TRUE and the pathname does not exists,
# an Exception is thrown, otherwise not.}
# \item{mustNotExist}{If the file exists, and \code{mustNotExist} is
# @TRUE, an Exception is thrown. If the file exists, and
# \code{mustNotExist} is @FALSE, or the file does not exists, the
# pathname is accepted.}
# \item{mkdirs}{If @TRUE, \code{mustNotExist} is @FALSE, and the path to
# the file does not exist, it is (recursively) created.}
# \item{maxTries}{A positive @integer specifying how many times the
# method should try to create a missing directory before giving up.
# For more details, see @see "R.utils::mkdirs".}
# }
#
# \value{
# Returns a @character string of the pathname of the file.
# If the argument was invalid an @see "R.oo::Exception" is thrown.
# }
#
# \section{Missing values}{
# If any argument in \code{...} is @NA, an exception is thrown.
# }
#
# @author
#
# \seealso{
# @seemethod "getReadablePathname".
# @see "R.utils::filePath".
# @see "R.utils::mkdirs".
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getWritablePathname", "Arguments", function(static, ..., mustExist=FALSE, mustNotExist=FALSE, mkdirs=TRUE, maxTries=5L) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'mustExist':
mustExist <- getLogical(static, mustExist)
# Argument 'mustNotExist':
mustNotExist <- getLogical(static, mustNotExist)
# Argument 'mkdirs':
mkdirs <- getLogical(static, mkdirs)
# Create pathname
pathname <- getReadablePathname(static, ..., mustExist=mustExist)
if (is.na(pathname)) {
throw("Cannot retrieve writable file/directory because it is NA.")
}
if (isFile(pathname)) {
# Check if it is ok that the file already exists
if (mustNotExist) {
throw("File already exists: ", pathname)
}
# Check if file permissions allow to modify existing
if (fileAccess(pathname, mode=2) == -1) {
throw("No permission to modify existing file: ", pathname)
}
} else {
# Check if directory exists
path <- getParent(pathname)
if (!isDirectory(path)) {
# Does the directory have to exists (mkdirs=FALSE)?
if (!mkdirs) {
path <- getReadablePath(static, path, mustExist=TRUE)
}
# If not, first try to create the parent directory, iff missing.
# This should give a more informative error message, if it fails.
pathP <- getParent(path)
createParent <- !isDirectory(pathP)
if (createParent) {
pathnameP <- getWritablePathname(static, file="dummy-not-tested", path=pathP, mustExist=FALSE, mustNotExist=FALSE, mkdirs=TRUE, maxTries=maxTries)
}
# Try to create the directory
mkdirs(path, mustWork=TRUE, maxTries=maxTries)
}
filename <- basename(pathname)
if (filename != "dummy-not-tested") {
# Check if file permissions allow to create a file in the directory
pathT <- ifelse(is.null(path), ".", path)
if (fileAccess(pathT, mode=2) == -1) {
throw("No write permission for directory: ", path)
}
# Try to create a file
filenameT <- basename(tempfile())
pathnameT <- filePath(path, filenameT)
on.exit({
if (isFile(pathnameT)) {
# Try to remove the temporary file
res <- FALSE
suppressWarnings({
for (tt in 1:maxTries) {
res <- file.remove(pathnameT)
if (res) break
# If not, wait a bit and try again...
Sys.sleep(0.5)
}
})
if (!res) {
warning("Failed to remove temporary file: ", sQuote(pathnameT))
}
}
}, add=TRUE)
tryCatch({
cat(file=pathnameT, Sys.time())
}, error = function(ex) {
throw("No permission to create a new file in directory: ", path)
})
} # if (filename != "dummy-not-tested")
} # if (isFile(pathname))
pathname
}, static=TRUE)
setMethodS3("getWritablePath", "Arguments", function(static, path=NULL, ...) {
# Special case: If path == NULL, the skip
if (is.null(path))
return(NULL)
pathname <- getWritablePathname(static, file="dummy-not-created", path=path, ...)
getParent(pathname)
}, static=TRUE, protected=TRUE)
setMethodS3("getDirectory", "Arguments", function(static, path=NULL, ..., mustExist=FALSE, mkdirs=TRUE) {
# Argument 'mustExist':
mustExist <- getLogical(static, mustExist)
# Argument 'mkdirs':
mkdirs <- getLogical(static, mkdirs)
# Create pathname
pathname <- getReadablePathname(static, path=path, ..., mustExist=mustExist)
if (is.na(pathname)) {
throw("Cannot retrieve directory because it is NA.")
}
# Nothing to do?
if (isDirectory(pathname)) {
return(pathname)
}
if (!mkdirs) {
throw("Directory does not exist: ", pathname)
}
mkdirs(pathname, mustWork=TRUE)
pathname
}, static=TRUE, protected=TRUE)
#########################################################################/**
# @RdocMethod getVector
#
# @title "Validates a vector"
#
# \description{
# @get "title" by checking its length (number of elements).
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A single @vector.}
# \item{length}{A @numeric @vector of length two or more. If two, it
# is the minimum and maximum length of \code{x}. Otherwise, it is the
# set of possible lengths of \code{x}.}
# \item{.name}{A @character string for name used in error messages.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns the same @vector, if it is valid. Otherwise an exception is
# thrown.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getVector", "Arguments", function(static, x, length=NULL, .name=NULL, ...) {
if (length(length) == 0)
return(x)
if (is.null(.name))
.name <- as.character(deparse(substitute(x)))
# See ?is.vector for how it is defined. /HB 2009-05-19
attrs <- attributes(x)
attributes(x) <- attrs[intersect(names(attrs), c("names", "dim"))]
if (length[1] > 0 && !is.vector(x)) {
throw(sprintf("Argument '%s' is not a vector: %s", .name, storage.mode(x)))
}
xlen <- length(x)
if (length(length) == 1)
length <- c(1,length)
if (length(length) == 2) {
if (xlen < length[1] || xlen > length[2]) {
if (length[1] == length[2] && length[1] == 1) {
throw(sprintf("Argument '%s' should be a single value not %d values.", .name, xlen))
} else if (length[1] == length[2]) {
throw(sprintf("Number of elements in argument '%s' should be exactly %d not %d value(s).", .name, length[1], xlen))
} else {
throw(sprintf("Number of elements in argument '%s' is out of range [%d,%d]: %d", .name, length[1], length[2], xlen))
}
}
} else {
if (!is.element(xlen, length)) {
throw(sprintf("Number of elements in argument '%s' is not in {%s}: %d",
.name, seqToHumanReadable(length), xlen))
}
}
attributes(x) <- attrs
x
}, static=TRUE, private=TRUE)
#########################################################################/**
# @RdocMethod getCharacters
# @aliasmethod getCharacter
#
# @title "Coerces to a character vector and validates"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{s}{A @vector.}
# \item{nchar}{A @numeric @vector of length one or two. If one,
# the maximum number of characters ("length") in \code{s}. If two,
# the minimum and maximum length of \code{s}.}
# \item{useNames}{If @TRUE, the 'names' attribute is preserved, otherwise
# it is dropped.}
# \item{asGString}{If @TRUE, each string is treated as a @see "GString".}
# \item{.name}{A @character string for name used in error messages.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character @vector, if it is valid. Otherwise an exception is
# thrown.
# }
#
# \section{Missing values}{
# If \code{s} contains missing values, and \code{nchar} is not @NULL,
# then an exception is thrown.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getCharacters", "Arguments", function(static, s, length=NULL, trim=FALSE, nchar=NULL, useNames=TRUE, asGString=getOption("Arguments$getCharacters/args/asGString", TRUE), .name=NULL, ...) {
if (is.null(.name))
.name <- as.character(deparse(substitute(s)))
s <- getVector(static, s, length=length, .name=.name)
# Nothing to check?
if (length(s) == 0L)
return(s)
# Coerce GString:s to character strings?
if (asGString) {
# Treat only strings with GString markup. This avoids lots of
# GString overhead if there are no GStrings.
hasMarkup <- (regexpr("${", s, fixed=TRUE) != -1)
idxs <- which(hasMarkup & !is.na(s))
s[idxs] <- unlist(lapply(s[idxs], FUN=function(x) {
x <- GString(x)
as.character(x)
}), use.names=FALSE)
}
if (trim) {
# Trim the strings
# (using s[] to preserve attributes)
s[] <- unlist(lapply(s, FUN=trim), use.names=FALSE)
}
# Coerce to character strings
# (using s[] to preserve attributes)
s[] <- unlist(lapply(s, FUN=as.character), use.names=FALSE)
if (!useNames) {
names(s) <- NULL
}
# Nothing to check?
if (is.null(nchar))
return(s)
# At this point, missing values are not allowed
if (any(is.na(s))) {
throw("Argument 'nchar' cannot be specified if character vector contains missing values: ", hpaste(sQuote(s)))
}
if (length(nchar) == 1L)
nchar <- c(1L, nchar)
# Check the string length of each character string
for (kk in seq_along(s)) {
slen <- nchar(s[kk], type="chars")
if (slen < nchar[1L] || slen > nchar[2L]) {
throw(sprintf("String length of elements #%d in '%s' is out of range [%d,%d]: %d '%s'", kk, .name, nchar[1L], nchar[2L], slen, s[kk]))
}
}
s
}, static=TRUE)
setMethodS3("getCharacter", "Arguments", function(static, ..., length=c(0,1)) {
getCharacters(static, ..., length=length)
}, static=TRUE)
#########################################################################/**
# @RdocMethod getNumerics
# @aliasmethod getNumeric
#
# @title "Coerces to a numeric vector and validates"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A @vector.}
# \item{range}{Two @numerics for the allowed ranged. If @NULL, range is
# not checked.}
# \item{asMode}{A @character specifying the mode to coerce to.}
# \item{disallow}{A @character @vector specifying disallowed value sets,
# i.e. \code{"NA"}, \code{"NaN"}, and/or \code{"Inf"}.}
# \item{...}{Arguments passed to @method "getVector".}
# \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
# Returns a @numeric @vector.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getNumerics", "Arguments", function(static, x, range=NULL, asMode=NULL, disallow=NULL, ..., .name=NULL) {
# Argument '.name':
if (is.null(.name)) {
.name <- as.character(deparse(substitute(x)))
}
x <- getVector(static, x, ..., .name=.name)
xMode <- storage.mode(x)
# Coerce the mode of 'x'
if (is.null(asMode)) {
if (is.element(xMode, c("integer", "double"))) {
asMode <- xMode
} else {
asMode <- "double"
}
}
# Update/coerce mode?
if (xMode != asMode) {
storage.mode(x) <- asMode
}
# Nothing to do?
if (length(x) == 0)
return(x)
if (!is.null(disallow)) {
if (is.element("NaN", disallow) && any(is.nan(x))) {
throw(sprintf("Argument '%s' contains %d NaN value(s).",
.name, sum(is.nan(x))))
}
if (is.element("NA", disallow) && any(is.na(x) & !is.nan(x))) {
throw(sprintf("Argument '%s' contains %d NA value(s).",
.name, sum(is.na(x))))
}
# For conveniency, disallow 'Inf' here too; other range takes care of it.
if (is.element("Inf", disallow) && any(is.infinite(x))) {
throw(sprintf("Argument '%s' contains %d (-/+)Inf value(s).",
.name, sum(is.infinite(x))))
}
}
# Nothing to check?
if (is.null(range))
return(x)
# Argument 'range':
if (length(range) != 2) {
throw("Argument 'range' should be of length 2: ", length(range))
}
if (range[2] < range[1]) {
throw(sprintf("Argument 'range' is not ordered: c(%s,%s)", range[1], range[2]))
}
# Suppress warnings when there are no finite values in x.
suppressWarnings({
xrange <- range(x, na.rm=TRUE)
})
if (xrange[1] < range[1] || xrange[2] > range[2]) {
xrange <- as.character(xrange)
range <- as.character(range)
if (length(x) == 1) {
throw(sprintf("Argument '%s' is out of range [%s,%s]: %s",
.name, range[1], range[2], x))
} else {
throw(sprintf("Range of argument '%s' is out of range [%s,%s]: [%s,%s]",
.name, range[1], range[2], xrange[1], xrange[2]))
}
}
x
}, static=TRUE)
setMethodS3("getNumeric", "Arguments", function(static, ..., length=1) {
getNumerics(static, ..., length=length)
}, static=TRUE)
#########################################################################/**
# @RdocMethod getDoubles
# @aliasmethod getDouble
#
# @title "Coerces to a double vector and validates"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @method "getNumeric".}
# \item{disallow}{Disallowed values. See @method "getNumerics" for details.}
# }
#
# \value{
# Returns a @double @vector.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getDoubles", "Arguments", function(static, ..., disallow=c("NA","NaN")) {
getNumerics(static, ..., asMode="double", disallow=disallow)
}, static=TRUE)
setMethodS3("getDouble", "Arguments", function(static, ..., length=1) {
getDoubles(static, ..., length=length)
}, static=TRUE)
#########################################################################/**
# @RdocMethod getIntegers
# @aliasmethod getInteger
#
# @title "Coerces to a integer vector and validates"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @method "getNumeric".}
# \item{disallow}{Disallowed values. See @method "getNumerics" for details.}
# }
#
# \value{
# Returns a @integer @vector.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getIntegers", "Arguments", function(static, ..., disallow=c("NA","NaN")) {
getNumerics(static, ..., asMode="integer", disallow=disallow)
}, static=TRUE)
setMethodS3("getInteger", "Arguments", function(static, ..., length=1) {
getIntegers(static, ..., length=length)
}, static=TRUE)
#########################################################################/**
# @RdocMethod getIndices
# @aliasmethod getIndex
#
# @title "Coerces to a integer vector and validates"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A single @vector. If @logical, @see "base::which" is used.}
# \item{...}{Arguments passed to @method "getIntegers".}
# \item{range}{Allowed range. See @method "getNumerics" for details.}
# \item{max}{The maximum of the default range.}
# \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
# Returns an @integer @vector.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getIndices", "Arguments", function(static, x, ..., max=Inf, range=c(1*(max > 0L),max), .name=NULL) {
if (is.null(.name))
.name <- as.character(deparse(substitute(x)))
# Argument 'x':
if (is.logical(x)) {
x <- which(x)
}
# Argument 'max':
if (length(max) != 1) {
throw("Argument 'max' must be a single value: ", length(max))
}
max <- as.numeric(max)
if (is.na(max)) {
throw("Argument 'max' is NA/NaN: ", max)
} else if (max < 0) {
throw("Argument 'max' must be positive: ", max)
}
# Argument 'range':
if (!is.null(range)) {
if (length(range) != 2) {
throw("Argument 'range' should be of length 2: ", length(range))
}
if (range[2] < range[1]) {
throw(sprintf("Argument 'range' is not ordered: c(%s,%s)", range[1], range[2]))
}
}
# Identify indices
x <- getIntegers(static, x, ..., range=range, .name=.name)
# Special dealing with range = c(0,0)
if (!is.null(range)) {
if (range[2] < 1L) {
xt <- x[is.finite(x)]
if (length(xt) > 0) {
throw(sprintf("Argument 'x' contains %d non-missing indices although the range ([%s,%s]) implies that there should be none.", length(xt), range[1L], range[2L]))
}
}
}
x
}, static=TRUE)
setMethodS3("getIndex", "Arguments", function(static, ..., length=1) {
getIndices(static, ..., length=length)
}, static=TRUE)
#########################################################################/**
# @RdocMethod getLogicals
# @aliasmethod getLogical
#
# @title "Coerces to a logical vector and validates"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A @vector.}
# \item{disallow}{A @character @vector specifying disallowed value sets
# after coercing, i.e. \code{"NA"}.}
# \item{...}{Arguments passed to @method "getVector".}
# \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
# Returns a @numeric @vector.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getLogicals", "Arguments", function(static, x, ..., disallow=c("NA", "NaN"), coerce=FALSE, .name=NULL) {
if (is.null(.name))
.name <- as.character(deparse(substitute(x)))
x <- getVector(static, x, ..., .name=.name)
# Coerce to logicals?
if (coerce)
x <- as.logical(x)
if (!is.null(disallow)) {
if (is.element("NA", disallow) && any(is.na(x))) {
throw(sprintf("Argument '%s' contains %d NA value(s).",
.name, sum(is.na(x))))
}
}
# Assert that 'x' is logical before returning
if (any(!is.logical(x)))
throw(sprintf("Argument '%s' is non-logical: %s", .name, class(x)))
x
}, static=TRUE)
setMethodS3("getLogical", "Arguments", function(static, ..., length=1) {
getLogicals(static, ..., length=length)
}, static=TRUE)
#########################################################################/**
# @RdocMethod getVerbose
#
# @title "Coerces to Verbose object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{verbose}{A single object. If a @see "Verbose", it is immediately
# returned. If a @numeric value, it is used as the threshold.
# Otherwise the object is coerced to a @logical value and if @TRUE,
# the threshold is \code{defaultThreshold}.}
# \item{defaultThreshold}{A @numeric value for the default threshold, if
# \code{verbose} was interpreted as a @logical value.}
# \item{useNullVerbose}{If \code{verbose} can be interpreted as @FALSE,
# return a @see NullVerbose object if @TRUE.}
# \item{...}{Passed to the constructor of @see "Verbose".}
# \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
# Returns a @see Verbose (or a @see "NullVerbose") object.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getVerbose", "Arguments", function(static, verbose, defaultThreshold=-1, useNullVerbose=TRUE, ..., .name=NULL) {
if (inherits(verbose, "Verbose"))
return(verbose)
if (is.null(.name))
.name <- as.character(deparse(substitute(verbose)))
if (is.numeric(verbose)) {
verbose <- getDouble(static, verbose, .name=.name)
verbose <- Verbose(threshold=verbose, ...)
} else {
verbose <- getLogical(static, verbose, .name=.name)
if (!verbose && useNullVerbose) {
verbose <- NullVerbose()
} else {
defaultThreshold <- getNumeric(static, defaultThreshold)
verbose <- Verbose(threshold=defaultThreshold, ...)
}
}
verbose
}, static=TRUE)
#########################################################################/**
# @RdocMethod getRegularExpression
#
# @title "Gets a valid regular expression pattern"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{pattern}{A @character string to be validated.}
# \item{.name}{A @character string for name used in error messages.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @see "base::grep".
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getRegularExpression", "Arguments", function(static, pattern=NULL, ..., .name=NULL) {
if (is.null(.name)) {
.name <- as.character(deparse(substitute(pattern)))
}
if (is.null(pattern)) {
throw(sprintf("Argument '%s' is not a valid regular expression: NULL",
.name))
}
pattern <- getCharacter(static, pattern, .name=.name, length=c(1,1))
# Validate it
tryCatch({
regexpr(pattern, "dummy string", ...)
}, error = function(ex) {
throw(sprintf("Argument '%s' is not a valid regular expression: %s. Error message from regexpr() was: %s", .name, pattern, ex$message))
})
pattern
}, static=TRUE)
#########################################################################/**
# @RdocMethod getEnvironment
#
# @title "Gets an existing environment"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{envir}{An @environment, the name of a loaded package, or @NULL.
# If @NULL, the global environment is returned.}
# \item{.name}{A @character string for name used in error messages.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns an @environment.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getEnvironment", "Arguments", function(static, envir=NULL, .name=NULL, ...) {
if (is.null(.name))
.name <- as.character(deparse(substitute(envir)))
if (is.null(envir)) {
return(.GlobalEnv)
}
if (is.character(envir)) {
name <- getCharacter(static, envir, length=c(1,1))
envirs <- gsub("^package:", "", search())
pos <- which(name == envirs)
if (length(pos) == 0)
throw("Argument 'envir' is not the name of a loaded package: ", envir)
envir <- pos.to.env(pos)
}
if (!is.environment(envir)) {
throw(sprintf("Argument '%s' is not an environment: %s",
.name, class(envir)[1]))
}
}, static=TRUE)
#########################################################################/**
# @RdocMethod getInstanceOf
#
# @title "Gets an instance of the object that is of a particular class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{The object that should be returned as an instance of
# class \code{class}.}
# \item{class}{A @character string specifying the name of the class that
# the returned object should inherit from.}
# \item{coerce}{If @TRUE and the object is not of the wanted class, then
# method will be coerced to that class, if possible. Otherwise,
# an error is thrown.}
# \item{...}{Not used.}
# \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
# Returns an object inheriting from class \code{class}.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("getInstanceOf", "Arguments", function(static, object, class, coerce=FALSE, ..., .name=NULL) {
if (is.null(.name)) {
.name <- as.character(deparse(substitute(object)))
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'class':
class <- getCharacter(static, class)
# Argument 'coerce':
coerce <- getLogical(static, coerce)
# Argument 'object':
if (!inherits(object, class)) {
if (coerce) {
object <- as(object, class, ...)
} else {
throw(sprintf("Argument '%s' is neither of nor inherits class %s: %s",
.name, class[1], paste(class(object), collapse=", ")))
}
}
# Return the object
object
}, static=TRUE, protected=TRUE)
withoutGString <- function(..., envir=parent.frame()) {
# Temporarily disable 'asGString' for Arguments$getCharacters()
oopts <- options("Arguments$getCharacters/args/asGString"=FALSE)
on.exit(options(oopts))
eval(..., envir = envir, enclos = baseenv())
} # withoutGString()
R.utils/R/TextStatusBar.R 0000644 0001762 0000144 00000017774 14372747611 014747 0 ustar ligges users ###########################################################################/**
# @RdocClass TextStatusBar
#
# @title "A status bar at the R prompt that can be updated"
#
# \description{
# @classhierarchy
#
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{fmt}{A @character format string to be used by @see "base::sprintf".
# Default is a left-aligned string of full width.}
# \item{...}{Named arguments to be passed to @see "base::sprintf" together
# with the format string.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \details{
# A label with name \code{hfill} can be used for automatic horizontal
# filling. It must be @numeric and be immediate before a string
# label such that a \code{hfill} label and the following string label
# together specifies an sprintf format such as \code{"\%*-s"}.
# The value of \code{hfill} will be set such that the resulting status
# bar has width equal to \code{getOption("width")-1} (the reason for the
# -1 is to prevent the text status bar from writing into the next line).
# If more than one \code{hfill} label is used their widths will be
# uniformly distributed. Left over spaces will be distributed between
# \code{hfill} labels with initial values of one.
# }
#
# @examples "../incl/TextStatusBar.Rex"
#
# @author
#
# @keyword programming
# @keyword IO
#*/###########################################################################
setConstructorS3("TextStatusBar", function(fmt=paste("%-", getOption("width")-1, "s", sep=""), ...) {
extend(Object(core=TRUE), "TextStatusBar",
.lastStr = "",
.fmt = fmt,
.args = list(...)
)
})
###########################################################################/**
# @RdocMethod update
#
# @title "Updates the status bar (visually)"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("update", "TextStatusBar", function(object, ...) {
# To please R CMD check
this <- object
fmt <- this$.fmt
args <- this$.args
isHFill <- which(names(args) == "hfill")
nHFill <- length(isHFill)
if (nHFill > 0) {
# First, use zero width to figure out the total width without "hfillers".
argsT <- args
argsT[isHFill] <- 0
argsT[isHFill+1] <- ""
str <- do.call(sprintf, args=c(list(fmt=fmt), argsT))
nfill <- (getOption("width")-1) - nchar(str)
if (nfill > 0) {
# Distribute the horizontal fillers evenly.
spcs <- rep(nfill %/% nHFill, times=nHFill)
ndiff <- nfill - sum(spcs)
if (ndiff > 0) {
# For the left overs, distribute them evenly between the hfillers
# with values 1.
incr <- rep(FALSE, times=nHFill)
incr[args[isHFill] == 1] <- TRUE
spcs[incr] <- spcs[incr] + 1
}
args[isHFill] <- spcs
}
}
str <- do.call(sprintf, args=c(list(fmt=fmt), args))
lastStr <- this$.lastStr
this$.lastStr <- str
backspaces <- paste(rep("\b", nchar(lastStr)), collapse="")
cat(backspaces, str, sep="")
})
###########################################################################/**
# @RdocMethod setLabels
#
# @title "Sets new values of given labels"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{A set of named arguments.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seemethod "setLabel".
# @seemethod "updateLabels".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("setLabels", "TextStatusBar", function(this, ...) {
pars <- list(...)
args <- this$.args
for (label in names(pars)) {
args[[label]] <- pars[[label]]
}
this$.args <- args
})
###########################################################################/**
# @RdocMethod setLabel
#
# @title "Sets the value of a label"
#
# \description{
# @get "title" address either by its index or its names.
# }
#
# @synopsis
#
# \arguments{
# \item{label}{The index or the name of the label.}
# \item{value}{The value of the label.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seemethod "setLabels"
# @seemethod "getLabel"
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("setLabel", "TextStatusBar", function(this, label, value, ...) {
args <- this$.args
args[[label]] <- value
this$.args <- args
})
###########################################################################/**
# @RdocMethod getLabel
#
# @title "Gets the current value of a label"
#
# \description{
# @get "title" address either by its index or its names.
# }
#
# @synopsis
#
# \arguments{
# \item{label}{The index or the name of the label.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns the value.
# }
#
# @author
#
# \seealso{
# @seemethod "setLabel" and @seemethod "setLabels".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("getLabel", "TextStatusBar", function(this, label, ...) {
args <- this$.args
.subset2(args, label)
})
###########################################################################/**
# @RdocMethod newline
#
# @title "Writes a newline"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("newline", "TextStatusBar", function(this, ...) {
this$.lastStr <- ""
cat("\n")
})
###########################################################################/**
# @RdocMethod updateLabels
#
# @title "Sets the new values of given labels and updates the status bar"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{A set of named arguments.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seemethod "setLabels".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("updateLabels", "TextStatusBar", function(this, ...) {
setLabels(this, ...)
update(this)
})
###########################################################################/**
# @RdocMethod popMessage
#
# @title "Adds a message above the status bar"
#
# \description{
# @get "title" by scrolling up previous messages popped.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @see "base::cat".}
# \item{collapse, sep}{Default values to @see "base::cat".}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("popMessage", "TextStatusBar", function(this, ..., collapse="", sep="") {
lastStr <- this$.lastStr
# Erase current statusbar
backspaces <- rep("\b", nchar(lastStr))
erazor <- c(backspaces, rep(" ", nchar(lastStr)), backspaces)
cat(erazor, sep="")
this$.lastStr <- ""
cat(..., collapse=collapse, sep=sep)
cat("\n")
update(this)
})
###########################################################################/**
# @RdocMethod flush
#
# @title "Flushes the output"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @see "base::cat".}
# }
#
# \value{
# Returns nothing.
# }
#
# \details{
# All this methods does is to call @see "utils::flush.console", which
# flushes the output to the console.
# }
#
# @author
#
# \seealso{
# @see "utils::flush.console".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("flush", "TextStatusBar", function(con, ...) {
# To please R CMD check
this <- con
flush.console()
})
R.utils/R/pushTemporaryFile.R 0000644 0001762 0000144 00000006441 14372747611 015641 0 ustar ligges users ########################################################################/**
# @RdocDefault pushTemporaryFile
#
# @title "Appends a temporary suffix to the pathname"
#
# @synopsis
#
# \description{
# @get "title" and, optionally, renames an existing file accordingly.
#
# In combination with @see "popTemporaryFile", this method is useful
# for creating a file/writing data to file \emph{atomically}, by
# first writing to a temporary file which is the renamed. If for
# some reason the generation of the file was interrupted, for instance
# by a user interrupt or a power failure, then it is only the temporary
# file that is incomplete.
# }
#
# \arguments{
# \item{filename}{The filename of the file.}
# \item{path}{The path of the file.}
# \item{suffix}{The suffix to be appended.}
# \item{isFile}{If @TRUE, the file must exist and will be renamed
# on the file system. If @FALSE, it is only the pathname string
# that will be modified. For details, see below.}
# \item{...}{Not used.}
# \item{verbose}{A @logical or @see "Verbose".}
# }
#
# \value{
# Returns the pathname with the suffix appended.
# }
#
# \details{
# If \code{isFile} is @FALSE, the pathname where the suffix of the
# temporary pathname has been added is returned.
# If \code{isFile} is @TRUE, the file is also renamed.
# Then, if the file does not exists or it was not successfully
# renamed, an exception is thrown.
# }
#
# @examples "../incl/pushTemporaryFile.Rex"
#
# @author
#
# \seealso{
# @see "popTemporaryFile".
# }
#
# @keyword "utilities"
# @keyword "programming"
# @keyword "IO"
#*/#########################################################################
setMethodS3("pushTemporaryFile", "default", function(filename, path=NULL, suffix=".tmp", isFile=FALSE, ..., verbose=FALSE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'isFile':
isFile <- Arguments$getLogical(isFile)
# Argument 'filename' & 'path':
pathname <- Arguments$getWritablePathname(filename, path=path,
mustExist=isFile, mustNotExist=!isFile)
# Argument 'suffix':
suffix <- Arguments$getCharacter(suffix)
# Argument 'verbose':
verbose <- Arguments$getVerbose(verbose)
if (verbose) {
pushState(verbose)
on.exit(popState(verbose))
}
verbose && enter(verbose, "Adding temporary suffix from file")
verbose && cat(verbose, "Pathname: ", pathname)
verbose && cat(verbose, "Suffix: ", suffix)
verbose && cat(verbose, "Rename existing file?: ", isFile)
pathnameT <- sprintf("%s%s", pathname, suffix)
verbose && cat(verbose, "Temporary pathname: ", pathnameT)
pathnameT <- Arguments$getWritablePathname(pathnameT, mustNotExist=TRUE)
if (isFile) {
verbose && enter(verbose, "Renaming existing file")
res <- file.rename(pathname, pathnameT)
verbose && cat(verbose, "Result: ", res)
verbose && exit(verbose)
if (!isFile(pathnameT)) {
throw("Failed to rename file (final file does not exist): ", pathname, " -> ", pathnameT)
}
if (isFile(pathname)) {
throw("Failed to rename file (file still exists): ", pathname, " -> ", pathnameT)
}
} # if (isFile)
verbose && exit(verbose)
pathnameT
}) # pushTemporaryFile()
R.utils/R/copyDirectory.R 0000644 0001762 0000144 00000005577 14372747611 015027 0 ustar ligges users ###########################################################################/**
# @RdocDefault copyDirectory
#
# @title "Copies a directory"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{from}{The pathname of the source directory to be copied.}
# \item{to}{The pathname of the destination directory.}
# \item{...}{Additional arguments passed to
# \code{\link[base:files]{file.copy}}(), e.g. \code{overwrite}.}
# \item{private}{If @TRUE, files (and directories) starting with
# a period is also copied, otherwise not.}
# \item{recursive}{If @TRUE, subdirectories are copied too,
# otherwise not.}
# }
#
# \value{
# Returns (invisibly) a @character @vector of pathnames copied.
# }
#
# \details{
# Note that this method does \emph{not} use @see "copyFile" to
# copy the files, but @see "base::file.copy".
# }
#
# @author
#
# @keyword file
#*/###########################################################################
setMethodS3("copyDirectory", "default", function(from, to=".", ..., private=TRUE, recursive=TRUE) {
# BACKWARD COMPATIBILITY: file.copy() gained argument copy.mode=TRUE in
# R (>= 2.13.0) [April 2013]. Due to the default, this means that when
# previously copying a read-only file, the new file would have write
# permissions, whereas now it preserved the read-only permissions.
# This private function silently drop argument 'copy.mode' and 'copy.date'
# if passed older versions of R.
.file.copy <- function(...) {
args <- list(...)
names <- names(args)
if (!is.null(names)) {
known <- names(formals(base::file.copy))
keep <- (nchar(names) == 0L | is.element(names, known))
args <- args[keep]
}
do.call(base::file.copy, args=args, envir=parent.frame())
} # .file.copy()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'from':
if (!isDirectory(from))
throw("Argument 'from' is not a directory: ", from)
# Argument 'to':
to <- Arguments$getWritablePath(to, mkdirs=TRUE, absolute=FALSE)
# Argument 'private':
private <- Arguments$getLogical(private)
# Argument 'recursive':
recursive <- Arguments$getLogical(recursive)
# Use relative pathnames
files <- list.files(from, all.files=private, full.names=FALSE)
files <- files[!basename(files) %in% c(".", "..")]
files <- file.path(from, files)
copiedFiles <- c()
for (file in files) {
basename <- basename(file)
if (isFile(file)) {
if (.file.copy(from=file, to=filePath(to, basename), ...)) {
copiedFiles <- c(copiedFiles, file)
}
} else if (isDirectory(file)) {
if (recursive) {
copiedFiles <- c(copiedFiles,
copyDirectory(file, to=filePath(to, basename), ..., recursive=TRUE))
}
}
}
invisible(copiedFiles)
})
R.utils/R/detachPlain.R 0000644 0001762 0000144 00000001423 14372747611 014366 0 ustar ligges users .detachPlain <- function(pos, ...) {
env <- as.environment(pos)
# Temporarily remove all of the package's detach hooks
name <- attr(env, "name")
pkgName <- gsub("^package:", "", name)
hookName <- packageEvent(pkgName, "detach")
hooks <- getHook(hookName)
if (length(hooks) > 0) {
on.exit({
setHook(hookName, hooks, action="replace")
}, add=TRUE)
setHook(hookName, list(), action="replace")
}
# Temporarily remove the package's library path in order to
# prevent the package's .Last.lib() to be run.
libpath <- attr(env, "path")
if (!is.null(libpath)) {
on.exit({
attr(env, "path") <- libpath
}, add=TRUE)
attr(env, "path") <- NULL
}
# Detach the package
detach(pos=pos, unload=FALSE, force=TRUE)
} # .detachPlain()
R.utils/R/GString-class.R 0000644 0001762 0000144 00000042253 14526006463 014632 0 ustar ligges users ###########################################################################/**
# @RdocClass "GString"
# @set "name=GString-class"
#
# @title "Character string with advanced substitutions"
#
# \description{
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{...}{one or more objects, to be coerced to @character vectors.}
# \item{sep}{A @character string to separate the terms.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @examples "../incl/GString.Rex"
#
# @author
#
# \seealso{
# For convenience, see functions @see "gstring" and @see "gcat".
# }
#
# @visibility public
#*/###########################################################################
setConstructorS3("GString", function(..., sep="") {
s <- paste(..., sep=sep)
if (length(s) > 1L) {
throw("Trying to coerce more than one character string to a GString, which is not supported.")
}
extend(s, "GString")
})
###########################################################################/**
# @RdocMethod getRaw
#
# @title "Gets the unprocessed GString"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seemethod "as.character"
# @seeclass
# }
#*/###########################################################################
setMethodS3("getRaw", "GString", function(object, ...) {
unclass(object)
})
###########################################################################/**
# @RdocMethod print
#
# @title "Prints the processed GString"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @see "base::print".}
# }
#
# \value{
# Returns (invisibly) the process GString @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("print", "GString", function(x, ...) {
# To please R CMD check.
object <- x
print(as.character(object), ...)
})
###########################################################################/**
# @RdocMethod getBuiltinPid
#
# @title "Gets the process id of the current R session"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns an @integer.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinPid", "GString", function(static, ...) {
pid <- Sys.getpid()
pid
}, static=TRUE)
###########################################################################/**
# @RdocMethod getBuiltinHostname
#
# @title "Gets the hostname of the system running R"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinHostname", "GString", function(static, ...) {
# 1. Try Sys.getenv()
host <- Sys.getenv(c("HOST", "HOSTNAME", "COMPUTERNAME"))
host <- host[host != ""]
# 1. Try calling 'uname'
if (length(host) == 0L) {
tryCatch({
host <- readLines(pipe("/usr/bin/env uname -n"))
host <- host[host != ""]
}, error = function(ex) {})
}
if (length(host) == 0L)
host <- NA
host[1L]
}, static=TRUE)
###########################################################################/**
# @RdocMethod getBuiltinUsername
#
# @title "Gets the username of the user running R"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinUsername", "GString", function(static, ...) {
# 1. Try Sys.info(), which returns NULL if not implemented.
user <- Sys.info()["user"]
user <- user[user != "unknown"]
# 2. Try Sys.getenv()
if (length(user) == 0L) {
user <- Sys.getenv(c("USER", "USERNAME"))
user <- user[user != ""]
}
# 3. Try calling 'whoami'
if (length(user) == 0L) {
tryCatch({
user <- readLines(pipe("/usr/bin/env whoami"))
user <- user[user != ""]
}, error = function(ex) {})
}
if (length(user) == 0L)
user <- NA
user[1L]
}, static=TRUE)
###########################################################################/**
# @RdocMethod getBuiltinDate
#
# @title "Gets the current date"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{format}{A @character format string.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinDate", "GString", function(static, format="%Y-%m-%d", ...) {
args <- list(Sys.time(), format=format)
do.call(base::format, args)
}, static=TRUE)
###########################################################################/**
# @RdocMethod getBuiltinTime
#
# @title "Gets the current time"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{format}{A @character format string.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinTime", "GString", function(static, format="%H:%M:%S", ...) {
args <- list(Sys.time(), format=format)
do.call(base::format, args)
}, static=TRUE)
###########################################################################/**
# @RdocMethod getBuiltinDatetime
#
# @title "Gets the current date and time"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{format}{A @character format string.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinDatetime", "GString", function(static, format=NULL, ...) {
args <- list(Sys.time(), format=format)
do.call(base::format, args)
}, static=TRUE)
###########################################################################/**
# @RdocMethod getBuiltinRversion
#
# @title "Gets the current R version"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinRversion", "GString", function(static, ...) {
getRversion()
}, static=TRUE)
###########################################################################/**
# @RdocMethod getBuiltinRhome
#
# @title "Gets the path where R is installed"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinRhome", "GString", function(static, ...) {
R.home()
}, static=TRUE)
###########################################################################/**
# @RdocMethod getBuiltinOs
#
# @title "Gets the operating system of the running machine"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getBuiltinOs", "GString", function(static, ...) {
.Platform$OS.type
}, static=TRUE)
###########################################################################/**
# @RdocMethod getVariableValue
#
# @title "Gets a variable value given a name and attributes"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the variable or function to be queried.}
# \item{attributes}{A @character string of the attributes.}
# \item{where}{A @character @vector of where to search for the variable
# or function.}
# \item{envir}{An @environment.}
# \item{inherits}{A @logical.}
# \item{missingValue}{The value returned if not found.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a (@vector of) objects.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("getVariableValue", "GString", function(static, name, attributes="", where=c("builtin", "envir", "parent", "Sys.getenv", "getOption"), envir=parent.frame(), inherits=TRUE, missingValue=NA, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'name':
if (is.null(name)) {
throw("Argument 'name' is NULL.")
} else if (!is.character(name)) {
throw("Argument 'name' must be a character string: ", mode(name))
}
# Argument 'envir':
.stop_if_not(is.environment(envir))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Process attributes
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
attrs <- strsplit(attributes, split=", ")[[1L]]
if (length(attrs) > 0L) {
isSimpleAttr <- (regexpr("^[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0-9._]+=.*$", attrs) == -1L)
simpleAttrs <- attrs[isSimpleAttr]
if (length(simpleAttrs) == 0L)
simpleAttrs <- NULL
attrs <- paste(attrs[!isSimpleAttr], collapse=", ")
attrs <- eval(parse(text=paste("list(", attrs, ")")), enclos = baseenv())
} else {
attrs <- NULL
simpleAttrs <- NULL
}
value <- NULL
for (ww in where) {
if (ww == "builtin") {
capitalizedName <- paste(toupper(substr(name, start=1L, stop=1L)), substr(name, start=2L, stop=nchar(name)), sep="")
builtInMethodName <- paste("getBuiltin", capitalizedName, sep="")
tryCatch({
args <- list(static)
args <- c(args, attrs)
value <- do.call(builtInMethodName, args=args)
}, error = function(ex) { })
} else if (ww == "Sys.getenv") {
value <- Sys.getenv(name)
if (nchar(value) == 0L)
value <- NULL
} else if (ww == "getOption") {
value <- getOption(name)
} else if (ww == "envir") {
if (exists(name, envir=envir, inherits=inherits)) {
value <- get(name, envir=envir, inherits=inherits)
}
} else if (ww == "parent") {
envirL <- NULL
n <- 0L
while (TRUE) {
n <- n + 1L
envirP <- parent.frame(n=n)
if (identical(envirP, envirL))
break
envirL <- envirP
if (exists("...abcdef", envir=envirP, inherits=FALSE))
next
if (exists(name, envir=envirP, inherits=FALSE)) {
value <- get(name, envir=envirP, inherits=FALSE)
break
}
if (identical(envir, .GlobalEnv))
break
}
} else {
if (exists(ww, mode="function")) {
tryCatch({
args <- c(attrs, list(...))
value <- do.call(name, args=args)
}, error = function(ex) {})
} else {
throw("Unknown search location of variable '", name, "': ", ww)
}
}
if (!is.null(value)) {
tryCatch({
value <- as.character(value)
}, error = function(ex) {
value <<- NA
})
# Apply simple attributes
for (attr in simpleAttrs) {
if (attr == "capitalize") {
value <- paste(toupper(substring(value, first=1L, last=1L)),
substring(value, first=2L), sep="")
} else {
tryCatch({
fcn <- get(attr, mode="function")
value <- fcn(value)
}, error = function(ex) {})
}
}
if (any(nchar(value) > 0L))
break
}
} # for (ww in ...)
if (is.null(value)) {
value <- missingValue
}
value
}, static=TRUE, private=TRUE)
###########################################################################/**
# @RdocMethod parse
#
# @title "Parses a GString"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @list structure.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("parse", "GString", function(object, ...) {
s <- getRaw(object)
# If there is no markup, then there is nothing to parse
if (length(s) == 0L || !regexpr("${", s, fixed=TRUE) != -1L) {
return(list(text=s))
}
# Parse the GString into a list of 'strings' intermixed with 'gstrings'.
parts <- list()
# Formats:
# ${expression}
# $[attribute,attribute,...,attribute]{expression}
while(TRUE) {
pattern <- "^\\$(\\[.*\\]|)\\{([^\\}]*)\\}"
pos <- regexpr(pattern, s)
matchLen <- attr(pos, "match.length")
pos <- pos[1L]
if (pos != -1L) {
text <- ""
} else {
pattern <- "[^\\\\$]\\$(\\[.*\\]|)\\{([^\\}]*)\\}"
pos <- regexpr(pattern, s)
matchLen <- attr(pos, "match.length")
pos <- pos[1]
if (pos != -1) {
text <- substr(s, start=1L, stop=pos)
text <- gsub("\\\\\\$", "$", text)
} else {
text <- s
text <- gsub("\\\\\\$", "$", text)
parts <- c(parts, list(text=text))
break
}
}
prefix <- list(text=text)
parts <- c(parts, prefix)
last <- pos + matchLen - 1L
var <- substr(s, start=pos, stop=last)
attributes <- gsub(pattern, "\\1", var)
attributes <- gsub("^\\[", "", attributes)
attributes <- gsub("\\]$", "", attributes)
name <- gsub(pattern, "\\2", var)
searchReplace <- NULL
patterns <- c("^[']([^']*)[']$", '^["]([^"]*)["]$')
if (all(sapply(patterns, FUN=regexpr, name) == -1L)) {
pattern <- "^(.*)/(.*)/(.*)"
if (regexpr(pattern, name) != -1L) {
searchPattern <- gsub(pattern, "\\2", name)
replacePattern <- gsub(pattern, "\\3", name)
name <- gsub(pattern, "\\1", name)
searchReplace <- list(search=searchPattern, replace=replacePattern)
}
} else {
for (pattern in patterns) {
name <- gsub(pattern, "\\1", name)
}
}
pattern <- "^`(.*)`"
isExpression <- (regexpr(pattern, name) != -1L)
if (isExpression) {
call <- gsub(pattern, "\\1", name)
part <- list(expression=list(call=call))
} else {
part <- list(variable=list(name=name))
}
part[[1L]]$attributes <- attributes
part[[1L]]$searchReplace <- searchReplace
parts <- c(parts, part)
s <- substr(s, start=last+1L, stop=nchar(s))
if (nchar(s) == 0L)
break
} # while(TRUE)
parts
}, private=TRUE)
###########################################################################/**
# @RdocMethod evaluate
#
# @title "Parses and evaluates a GString"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{envir}{The @environment in which the @see "GString" is evaluated.}
# \item{...}{Additional arguments passed to @seemethod "parse".}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("evaluate", "GString", function(object, envir=parent.frame(), ...) {
# Argument 'envir':
.stop_if_not(is.environment(envir))
# If there is no markup, then return alrady here.
s <- unclass(object)
# If there is no markup, then there is nothing to parse
if (length(s) == 0L || !regexpr("${", s, fixed=TRUE) != -1L) {
return(s)
}
parts <- parse(object, ...)
keys <- names(parts)
...abcdef <- TRUE
isVariable <- (keys == "variable")
for (kk in which(isVariable)) {
part <- parts[[kk]]
value <- getVariableValue(object, name=part$name,
attributes=part$attributes, envir=envir, ...)
if (!is.null(part$searchReplace))
value <- gsub(part$searchReplace$search,
part$searchReplace$replace, value)
parts[[kk]] <- value
}
isExpression <- (keys == "expression")
for (kk in which(isExpression)) {
part <- parts[[kk]]
expr <- parse(text=part$call)
value <- eval(expr, enclos = baseenv())
if (!is.null(part$searchReplace))
value <- gsub(part$searchReplace$search,
part$searchReplace$replace, value)
parts[[kk]] <- value
}
s <- ""
for (kk in seq_along(parts)) {
part <- parts[[kk]]
s <- paste(s, part, sep="")
}
s
}, protected=TRUE) # evaluate()
###########################################################################/**
# @RdocMethod as.character
#
# @title "Gets the processed character string"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("as.character", "GString", function(x, envir=parent.frame(), ...) {
evaluate(x, envir=envir, ...)
})
R.utils/R/compressFile.R 0000644 0001762 0000144 00000023321 14372747611 014606 0 ustar ligges users #########################################################################/**
# @RdocDefault compressFile
# @alias decompressFile
# @alias decompressFile.default
# @alias isCompressedFile
# @alias isCompressedFile.default
# @alias bzip2
# @alias bzip2.default
# @alias bunzip2
# @alias bunzip2.default
# @alias isBzipped
# @alias isBzipped.default
# @alias gzip
# @alias gzip.default
# @alias gunzip
# @alias gunzip.default
# @alias isGzipped
# @alias isGzipped.default
# %% @alias xz
# %% @alias xz.default
# %% @alias unxz
# %% @alias unxz.default
# %% @alias isXzipped
# %% @alias isXzipped.default
#
# @title "Compressing and decompressing files"
#
# \usage{
# @usage compressFile,default
# @usage decompressFile,default
# @usage isCompressedFile,default
# @usage bzip2,default
# @usage bunzip2,default
# @usage gzip,default
# @usage gunzip,default
# }
#
# \description{
# @get "title" such as gzip:ed and bzip2:ed files.
#
# \emph{
# NOTE: The default (\code{remove=TRUE}) behavior is that
# the input file is removed after that the output file
# is fully created and closed.
# }
# }
#
# \arguments{
# \item{filename}{Pathname of input file.}
# \item{destname}{Pathname of output file.}
# \item{temporary}{If @TRUE, the output file is created in a
# temporary directory.}
# \item{skip}{If @TRUE and the output file already exists,
# the output file is returned as is.}
# \item{overwrite}{If @TRUE and the output file already exists,
# the file is silently overwritten, otherwise an exception is
# thrown (unless \code{skip} is @TRUE).}
# \item{remove}{If @TRUE, the input file is removed afterward,
# otherwise not.}
# \item{BFR.SIZE}{The number of bytes read in each chunk.}
# \item{...}{Passed to the underlying function or alternatively not used.}
# \item{method}{A @character string specifying how to infer whether
# a file is compressed or not.}
# \item{ext, fileClass, FUN}{(internal) Filename extension, file class,
# and a connection @function used to read from/write to file.}
# }
#
# \value{
# Returns the pathname of the output file.
# The number of bytes processed is returned as an attribute.
#
# \code{isCompressedFile()}, \code{isGzipped()} and \code{isBzipped()}
# return a @logical.
# Note that with \code{method = "extension"} (default), only the filename
# extension is used to infer whether the file is compressed or not.
# Specifically, it does not matter whether the file actually exists or not.
# }
#
# \details{
# Internally \code{bzfile()} and \code{gzfile()}
# (see @see "base::connections") are used to read (write) files.
# If the process is interrupted before completed, the partially written
# output file is automatically removed.
# }
#
# \examples{
# ## bzip2
# cat(file="foo.txt", "Hello world!")
# print(isBzipped("foo.txt"))
# print(isBzipped("foo.txt.bz2"))
#
# bzip2("foo.txt")
# print(file.info("foo.txt.bz2"))
# print(isBzipped("foo.txt"))
# print(isBzipped("foo.txt.bz2"))
#
# bunzip2("foo.txt.bz2")
# print(file.info("foo.txt"))
#
# ## gzip
# cat(file="foo.txt", "Hello world!")
# print(isGzipped("foo.txt"))
# print(isGzipped("foo.txt.gz"))
#
# gzip("foo.txt")
# print(file.info("foo.txt.gz"))
# print(isGzipped("foo.txt"))
# print(isGzipped("foo.txt.gz"))
#
# gunzip("foo.txt.gz")
# print(file.info("foo.txt"))
#
# ## Cleanup
# file.remove("foo.txt")
# }
#
# @author
#
# @keyword "file"
# @keyword "programming"
#*/#########################################################################
setMethodS3("compressFile", "default", function(filename, destname=sprintf("%s.%s", filename, ext), ext, FUN, temporary=FALSE, skip=FALSE, overwrite=FALSE, remove=TRUE, BFR.SIZE=1e7, ...) {
# Argument 'filename':
if (!file.exists(filename)) {
stop("No such file: ", filename)
}
# Argument 'ext':
ext <- as.character(ext)
# Argument 'FUN':
if (!is.function(FUN)) {
stop(sprintf("Argument 'FUN' is not a function: %s", mode(FUN)))
}
# Argument 'temporary':
if (temporary) {
destname <- file.path(tempdir(), basename(destname))
}
attr(destname, "temporary") <- temporary
# Argument 'filename' & 'destname':
if (filename == destname) {
stop(sprintf("Argument 'filename' and 'destname' are identical: %s", filename))
}
# Already done?
if (file.exists(destname)) {
if (skip) {
return(destname)
} else if (overwrite) {
file.remove(destname)
} else {
stop(sprintf("File already exists: %s", destname))
}
}
## Compress to temporary file
destnameT <- pushTemporaryFile(destname)
# Create output directory, iff missing
destpath <- dirname(destnameT)
if (!isDirectory(destpath)) mkdirs(destpath, mustWork=TRUE)
# Setup input and output connections
inn <- file(filename, open="rb")
on.exit(if (!is.null(inn)) close(inn))
outComplete <- FALSE
out <- FUN(destnameT, open="wb", ...)
on.exit({
if (!is.null(out)) close(out)
# Remove incomplete file?
if (!outComplete) file.remove(destnameT)
}, add=TRUE)
# Process
nbytes <- 0
repeat {
bfr <- readBin(inn, what=raw(0L), size=1L, n=BFR.SIZE)
n <- length(bfr)
if (n == 0L) break
nbytes <- nbytes + n
writeBin(bfr, con=out, size=1L)
bfr <- NULL # Not needed anymore
}
outComplete <- TRUE
close(out)
out <- NULL
## Rename to final name
destname <- popTemporaryFile(destnameT)
# Return the output file
attr(destname, "nbrOfBytes") <- nbytes
# Cleanup
if (remove) {
close(inn)
inn <- NULL
file.remove(filename)
}
invisible(destname)
}) # compressFile()
setMethodS3("decompressFile", "default", function(filename, destname=gsub(sprintf("[.]%s$", ext), "", filename, ignore.case=TRUE), ext, FUN, temporary=FALSE, skip=FALSE, overwrite=FALSE, remove=TRUE, BFR.SIZE=1e7, ...) {
# Argument 'filename':
if (!file.exists(filename)) {
stop("No such file: ", filename)
}
# Argument 'ext':
ext <- as.character(ext)
# Argument 'FUN':
if (!is.function(FUN)) {
stop(sprintf("Argument 'FUN' is not a function: %s", mode(FUN)))
}
# Argument 'temporary':
if (temporary) {
destname <- file.path(tempdir(), basename(destname))
}
attr(destname, "temporary") <- temporary
# Argument 'filename' & 'destname':
if (filename == destname) {
stop(sprintf("Argument 'filename' and 'destname' are identical: %s", filename))
}
# Already done?
if (file.exists(destname)) {
if (skip) {
return(destname)
} else if (overwrite) {
file.remove(destname)
} else {
stop(sprintf("File already exists: %s", destname))
}
}
## Compress to temporary file
destnameT <- pushTemporaryFile(destname)
# Create output directory, iff missing
destpath <- dirname(destname)
if (!isDirectory(destpath)) mkdirs(destpath, mustWork=TRUE)
# Setup input and output connections
inn <- FUN(filename, open="rb")
on.exit(if (!is.null(inn)) close(inn))
outComplete <- FALSE
out <- file(destnameT, open="wb", ...)
on.exit({
if (!is.null(out)) close(out)
# Remove incomplete file?
if (!outComplete) file.remove(destnameT)
}, add=TRUE)
# Process
nbytes <- 0
repeat {
bfr <- readBin(inn, what=raw(0L), size=1L, n=BFR.SIZE)
n <- length(bfr)
if (n == 0L) break
nbytes <- nbytes + n
writeBin(bfr, con=out, size=1L)
bfr <- NULL # Not needed anymore
}
outComplete <- TRUE
close(out)
out <- NULL
## Rename to final name
destname <- popTemporaryFile(destnameT)
# Return the output file
attr(destname, "nbrOfBytes") <- nbytes
# Cleanup
if (remove) {
close(inn)
inn <- NULL
file.remove(filename)
}
invisible(destname)
}) # decompressFile()
setMethodS3("isCompressedFile", "default", function(filename, method=c("extension", "content"), ext, fileClass, ...) {
# Argument 'method':
method <- match.arg(method)
# Argument 'ext':
ext <- as.character(ext)
# Argument 'filename':
filename <- Arguments$getReadablePathname(filename, mustExist=(method == "content"))
if (method == "extension") {
res <- (regexpr(sprintf("[.]%s$", ext), filename, ignore.case=TRUE) != -1L)
} else if (method == "content") {
con <- file(filename)
on.exit(close(con))
# Argument 'fileClass':
fileClass <- as.character(fileClass)
res <- (summary(con)$class == fileClass)
}
res
}) # isCompressedFile()
setMethodS3("bzip2", "default", function(filename, ..., ext="bz2", FUN=bzfile) {
compressFile(filename=filename, ..., ext=ext, FUN=FUN)
})
setMethodS3("gzip", "default", function(filename, ..., ext="gz", FUN=gzfile) {
compressFile(filename=filename, ..., ext=ext, FUN=FUN)
})
## NOTE: Let's wait with and xz()/unxz(), because tests on Windows gives
## "Warning message: In readBin(inn, what = raw(0L), size = 1L, n = BFR.SIZE) :
## lzma decoder format error". /HB 2015-02-01
## setMethodS3("xz", "default", function(filename, ..., ext="xz", FUN=bzfile) {
## compressFile(filename=filename, ..., ext=ext, FUN=FUN)
## })
setMethodS3("bunzip2", "default", function(filename, ..., ext="bz2", FUN=bzfile) {
decompressFile(filename=filename, ..., ext=ext, FUN=FUN)
})
setMethodS3("gunzip", "default", function(filename, ..., ext="gz", FUN=gzfile) {
decompressFile(filename=filename, ..., ext=ext, FUN=FUN)
})
## setMethodS3("unxz", "default", function(filename, ..., ext="xz", FUN=xzfile) {
## decompressFile(filename=filename, ..., ext=ext, FUN=FUN)
## })
setMethodS3("isBzipped", "default", function(..., ext="bz2", fileClass="bzfile") {
isCompressedFile(..., ext=ext, fileClass=fileClass)
})
setMethodS3("isGzipped", "default", function(..., ext="gz", fileClass="gzfile") {
isCompressedFile(..., ext=ext, fileClass=fileClass)
})
## setMethodS3("isXzipped", "default", function(..., ext="xz", fileClass="xzfile") {
## isCompressedFile(..., ext=ext, fileClass=fileClass)
## })
R.utils/R/createWindowsShortcut.R 0000644 0001762 0000144 00000014374 14372747611 016535 0 ustar ligges users ###########################################################################/**
# @RdocDefault createWindowsShortcut
#
# @title "Creates a Microsoft Windows Shortcut (.lnk file)"
#
# @synopsis
#
# \description{
# @get "title".
# }
#
# \arguments{
# \item{pathname}{The pathname (with file extension *.lnk) of the link
# file to be created.}
# \item{target}{The target file or directory to which the shortcut should
# point to.}
# \item{overwrite}{If @TRUE, an existing link file is overwritten,
# otherwise not.}
# \item{mustWork}{If @TRUE, an error is produced if the Windows Shortcut
# link is not created, otherwise not.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) the pathname.
# }
#
# \section{Required privileges on Windows}{
# In order for this method, which utilizes Windows Script Host a VBScript,
# to succeed on Windows, the client/R session must run with sufficient
# privileges (it has been reported that Administrative rights are necessary).
# }
#
# @examples "../incl/createWindowsShortcut.Rex"
#
# @author
#
# \seealso{
# @see "readWindowsShortcut"
# }
#
# \references{
# [1] Create a windows shortcut (.LNK file), SS64.com,
# \url{https://ss64.com/nt/shortcut.html} \cr
# }
#
# @keyword file
# @keyword IO
#*/###########################################################################
setMethodS3("createWindowsShortcut", "default", function(pathname, target, overwrite=FALSE, mustWork=FALSE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Reference: [1]
makeVBScript <- function(target, link, description=basename(target)) {
# Arguments 'target':
target <- Arguments$getReadablePathname(target, mustExist=TRUE)
target <- getAbsolutePath(target)
# Arguments 'link':
link <- getAbsolutePath(link)
targetPath <- gsub("/", "\\\\", target)
linkFile <- gsub("/", "\\\\", link)
if (isDirectory(targetPath)) {
workingDir <- targetPath
} else {
workingDir <- dirname(targetPath)
}
s <- "Set oWS = WScript.CreateObject(\"WScript.Shell\")"
s <- c(s, sprintf("sLinkFile = \"%s.LNK\"", linkFile))
s <- c(s, "Set oLink = oWS.CreateShortcut(sLinkFile)")
s <- c(s, sprintf("oLink.TargetPath = \"%s\"", targetPath))
# s <- c(s, "oLink.Arguments = \"\"")
s <- c(s, sprintf("oLink.Description = \"%s\"", description))
# s <- c(s, "oLink.HotKey = \"\"")
# s <- c(s, sprintf("oLink.IconLocation = \"%s, 1\"", targetPath))
# s <- c(s, "oLink.WindowStyle = \"1\"")
# s <- c(s, sprintf("oLink.WorkingDirectory = \"%s\"", workingDir))
s <- c(s, "oLink.Save")
s <- paste(s, collapse="\n")
s
} # makeVBScript
createWindowsShortcutViaVBScript <- function(pathname, target, mustWork = FALSE) {
link <- gsub("[.](lnk|LNK)$", "", pathname)
# Generate VB code
pd <- packageDescription("R.utils")
pkgInfo <- sprintf("%s v%s", pd$Package, pd$Version)
description <- sprintf("Windows Shortcut link created by %s", pkgInfo)
code <- makeVBScript(target, link, description=description)
tmpFile <- tempfile()
pathnameT <- sprintf("%s.vbs", tmpFile)
on.exit(file.remove(pathnameT))
cat(file=pathnameT, code)
cmd <- sprintf("cscript \"%s\"", pathnameT)
res <- tryCatch({
res <- shell(cmd, intern=TRUE, mustWork=TRUE, shell=Sys.getenv("COMSPEC"))
status <- attr(res, "status")
if (!is.null(status)) {
msg <- sprintf("Shell command %s had status %d (using shell %s): %s", sQuote(cmd), status, sQuote(Sys.getenv("COMSPEC")), paste(res, collapse = "; "))
throw(msg)
}
res
}, error = identity)
if (inherits(res, "error")) {
msg <- sprintf("An error occurred when calling VBScript (%s) to create Windows Shortcut link %s. The reason was: %s", sQuote(cmd), sQuote(pathname), conditionMessage(res))
throw(msg)
}
# Sanity check
if (!isFile(pathname)) {
if (!mustWork) return(NULL)
msg <- sprintf("Failed to create Windows Shortcut link %s via VBScript (%s)", sQuote(pathname), sQuote(cmd))
if (inherits(res, "error")) {
msg <- sprintf("%s. The reason was: %s", msg, conditionMessage(res))
} else if (inherits(res, "character")) {
msg <- sprintf("%s. The reason was: %s", msg, paste(res, collapse="; "))
}
throw(msg)
}
pathname
} # createWindowsShortcutViaVBScript()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'overwrite':
overwrite <- Arguments$getLogical(overwrite)
# Argument 'mustWork':
mustWork <- Arguments$getLogical(mustWork)
# Argument 'pathname':
if (!overwrite && isFile(pathname)) {
throw("Cannot create Windows Shortcut link. File already exists: ",
pathname)
}
# Argument 'target':
target <- Arguments$getReadablePathname(target, mustExist=TRUE)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Create Windows Shortcut link
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
createWindowsShortcutViaVBScript(pathname, target=target, mustWork=mustWork)
link <- gsub("[.](lnk|LNK)$", "", pathname)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate correctness
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Try to read Windows shortcut (throws a parsing error if so)
lnk <- tryCatch({
# (i) Try using new reader...
readWindowsShellLink(pathname)
}, error = function(ex) {
# (ii) ...using old reverse-enginered reader
readWindowsShortcut(pathname)
})
target0 <- getAbsolutePath(target)
target1 <- Arguments$getReadablePathname(link, mustWork=mustWork)
target1 <- getAbsolutePath(target1)
# AD HOC: It may happen that the case of the drive letters differ.
if (tolower(target1) != tolower(target0)) {
throw("Failed to create a valid Windows Shortcut link. The link does not point the expected file: ", target1, " != ", target0)
}
# Return the LNK file
invisible(pathname)
}) # createWindowsShortcut()
R.utils/R/Verbose.R 0000644 0001762 0000144 00000111250 14526006463 013551 0 ustar ligges users ###########################################################################/**
# @RdocClass Verbose
#
# @title "Class to writing verbose messages to a connection or file"
#
# \description{
# @classhierarchy
#
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{con}{A @connection or a @character string filename.}
# \item{on}{A @logical indicating if the writer is on or off.}
# \item{threshold}{A @numeric threshold that the \code{level} argument
# of any write method has to be equal to or larger than in order to the
# message being written. Thus, the lower the threshold is the more and
# more details will be outputted.}
# \item{timestamp}{If @TRUE, each output is preceded with a timestamp.}
# \item{removeFile}{If @TRUE and \code{con} is a filename, the file is
# first deleted, if it exists.}
# \item{asGString}{If @TRUE, all messages are interpreted as
# @see "GString" before being output, otherwise not.}
# \item{core}{Internal use only.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \section{Output levels}{
# As a guideline, use the following levels when outputting verbose/debug
# message using the Verbose class. For a message to be shown, the output
# level must be greater than (not equal to) current threshold.
# Thus, the lower the threshold is set, the more messages will be seen.
#
# \describe{
# \item{<= -100}{Only for debug messages, i.e. messages containing all
# necessary information for debugging purposes and to find bugs in
# the code. Normally these messages are so detailed so they will be
# a pain for the regular user, but very useful for bug reporting and
# bug tracking by the developer.}
# \item{-99 -- -11}{Detailed verbose messages. These will typically be
# useful for the user to understand what is going on and do some simple
# debugging fixing problems typically due to themselves and not due to
# bugs in the code.}
# \item{-10 -- -1}{Verbose messages. For example, these will typically
# report the name of the file to be read, the current step in a sequence
# of analysis steps and so on. These message are not very useful for
# debugging.}
# \item{0}{Default level in all output methods and default threshold.
# Thus, by default, messages at level 0 are not shown.}
# \item{>= +1}{Message that are always outputted (if threshold is
# kept at 0). We recommend not to output message at this level, because
# methods should be quiet by default (at the default threshold 0).}
# }
# }
#
# \section{A compatibility trick and a speed-up trick}{
# If you want to include calls to Verbose in a package of yours in order
# to debug code, but not use it otherwise, you might not want to load
# R.utils all the time, but only for debugging.
# To achieve this, the value of a reference variable to a Verbose class
# is always set to @TRUE, cf. typically an Object reference has value @NA.
# This makes it possible to use the reference variable as a first test
# before calling Verbose methods. Example:
# \preformatted{
# foo <- function(..., verbose=FALSE) {
# # enter() will never be called if verbose==FALSE, thus no error.
# verbose && enter(verbose, "Loading")
# }
# }
#
# Thus, R.utils is not required for \code{foo()}, but for
# \code{foo(verbose==Verbose(level=-1))} it is.
#
# Moreover, if using the @see "NullVerbose" class for ignoring all verbose
# messages, the above trick will indeed speed up the code, because
# the value of a NullVerbose reference variable is always @FALSE.
# }
#
# \section{Extending the Verbose class}{
# If extending this class, make sure to output messages via
# @seemethod "writeRaw" or one of the other output methods (which in
# turn all call the former).
# This guarantees that @seemethod "writeRaw" has full control of the
# output, e.g. this makes it possible to split output to standard
# output and to file.
# }
#
# @examples "../incl/Verbose.Rex"
#
# @author
#
# \seealso{
# @see "NullVerbose".
# }
#
# @keyword programming
# @keyword IO
#*/###########################################################################
setConstructorS3("Verbose", function(con=stderr(), on=TRUE, threshold=0, asGString=TRUE, timestamp=FALSE, removeFile=TRUE, core=TRUE, ...) {
if (is.character(con)) {
if (removeFile && isFile(con))
file.remove(con)
} else if (inherits(con, "connection")) {
} else if (!is.null(con)) {
stop("Unknown type on argument 'con': ", class(con))
}
if (!is.numeric(threshold) || length(threshold) != 1)
throw("Argument 'threshold' must be a single numeric value.")
# Argument 'threshold':
threshold <- as.numeric(threshold)
# Argument 'asGString':
asGString <- as.logical(asGString)
# Argument 'timestamp':
timestamp <- as.logical(timestamp)
# Argument 'core':
if (!is.logical(core))
throw("Argument 'core' is not logical: ", mode(core))
# Argument 'on':
on <- as.logical(on)
extend(Object(core), "Verbose",
.timestamp = timestamp,
.timestampFormat = "%Y%m%d %H:%M:%S|",
indentPos = 0,
indentStep = 1,
rightMargin = 75,
threshold = threshold,
defaultLevel = 0,
asGString = asGString,
.ignore = !on,
.con = con,
.stack = c(),
.stackLevel = c()
)
})
###########################################################################/**
# @RdocMethod "as.character"
#
# @title "Returns a character string version of this object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("as.character", "Verbose", function(x, ...) {
# To please R CMD check
this <- x
s <- paste(class(this)[1], ": isOn()=", isOn(this), ",
threshold=", this$threshold, sep="")
s <- paste(s, ", timestamp=", this$.timestamp, sep="")
s <- paste(s, ", timestampFormat=", this$.timestampFormat, sep="")
s
})
#########################################################################/**
# @RdocMethod equals
#
# @title "Checks if this object is equal to another"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{other}{Another Object.}
# \item{...}{Not used.}
# }
#
# \value{Returns @TRUE if they are equal, otherwise @FALSE.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("equals", "Verbose", function(this, other, ...) {
res <- FALSE
if (!inherits(other, "Verbose")) {
attr(res, "reason") <- "Not same class"
return(res)
}
fields <- getFields(this, private=TRUE)
for (field in fields) {
if (!equals(this[[field]], other[[field]])) {
attr(res, "reason") <- field
return(res)
}
}
TRUE
}, protected=TRUE)
###########################################################################/**
# @RdocMethod setThreshold
#
# @title "Sets verbose threshold"
#
# \description{
# @get "title". Output requests below this threshold will be ignored.
# }
#
# @synopsis
#
# \arguments{
# \item{threshold}{A @numeric threshold.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns old threshold.
# }
#
# @author
#
# \seealso{
# @seemethod "getThreshold" and @seemethod "isVisible".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("setThreshold", "Verbose", function(this, threshold, ...) {
## Argument 'threshold':
if (length(threshold) != 1) {
throw("Argument 'threshold' must be a scalar.")
} else if (is.na(threshold)) {
throw("Argument 'threshold' must not be a missing value: ", threshold)
}
if (is.logical(threshold)) {
threshold <- -as.integer(threshold) ## => FALSE = 0, TRUE = -1
} else if (!is.numeric(threshold)) {
throw("Argument 'threshold' must be a logical or a numeric: ", mode(threshold))
}
old <- this$threshold
this$threshold <- threshold
invisible(old)
})
###########################################################################/**
# @RdocMethod setDefaultLevel
#
# @title "Sets the current default verbose level"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{level}{A @numeric value.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns old default level.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("setDefaultLevel", "Verbose", function(this, level, ...) {
if (is.na(as.numeric(level)))
throw("Invalid value on argument 'level': ", level)
oldLevel <- this$defaultLevel
this$defaultLevel <- as.numeric(level)
invisible(oldLevel)
})
###########################################################################/**
# @RdocMethod getThreshold
#
# @title "Gets current verbose threshold"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @numeric value.
# }
#
# @author
#
# \seealso{
# @seemethod "setThreshold" and @seemethod "isVisible".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("getThreshold", "Verbose", function(this, ...) {
threshold <- this$threshold
# Assert that threshold is within the valid range. This is part of the
# transition of move from negative to positive verbose levels:
# 1. Disallow all positive value for a long time.
# 2. Yet later, ignore the sign, i.e. abs(threshold).
# 3. Much later, disallow all negative values for a long time.
# 4. Possibly, allow negative values after all this.
# /HB 2011-09-18
validRange <- getOption("R.utils::Verbose/validThresholdRanges", c(-Inf,Inf))
if (!is.null(validRange)) {
validRange <- Arguments$getDoubles(validRange, length=c(2,2))
if (threshold < validRange[1] || threshold > validRange[2]) {
throw(sprintf("The threshold is out of the valid range [%s,%s]: %s",
validRange[1], validRange[2], threshold))
}
}
threshold
})
###########################################################################/**
# @RdocMethod isVisible
#
# @title "Checks if a certain verbose level will be shown or not"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{level}{A @numeric value to be compared to the threshold.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns @TRUE, if given level is greater than (not equal to) the current
# threshold, otherwise @FALSE is returned.
# }
#
# @author
#
# \seealso{
# @seemethod "getThreshold" and @seemethod "setThreshold".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("isVisible", "Verbose", function(this, level=this$defaultLevel, ...) {
isOn(this) && (is.null(level) || level > this$threshold)
})
###########################################################################/**
# @RdocMethod as.logical
#
# @title "Gets a logical value of this object"
#
# \description{
# @get "title". Returns \code{isVisible(this, level=this$defaultLevel)}.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @logical value.
# }
#
# @author
#
# \seealso{
# @seemethod "isVisible".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("as.logical", "Verbose", function(x, ...) {
# To please R CMD check
this <- x
isVisible(this, level=this$defaultLevel)
})
###########################################################################/**
# @RdocMethod as.double
#
# @title "Gets a numeric value of this object"
#
# \description{
# @get "title". Returns what @seemethod "getThreshold" returns.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @numeric value.
# }
#
# @author
#
# \seealso{
# @seemethod "getThreshold" and @seemethod "getThreshold".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("as.double", "Verbose", function(x, ...) {
# To please R CMD check
this <- x
getThreshold(this, ...)
})
###########################################################################/**
# @RdocMethod on
#
# @title "Turn on the output"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) @TRUE.
# }
#
# @author
#
# \seealso{
# @seemethod "off" and @seemethod "isOn".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("on", "Verbose", function(this, ...) {
this$.ignore <- FALSE
invisible(TRUE)
})
###########################################################################/**
# @RdocMethod off
#
# @title "Turn off the output"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) @FALSE.
# }
#
# @author
#
# \seealso{
# @seemethod "on" and @seemethod "isOn".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("off", "Verbose", function(this, ...) {
this$.ignore <- TRUE
invisible(FALSE)
})
###########################################################################/**
# @RdocMethod isOn
#
# @title "Checks if the output is on"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns @TRUE if output is on, otherwise @FALSE.
# }
#
# @author
#
# \seealso{
# @seemethod "on" and @seemethod "off".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("isOn", "Verbose", function(this, ...) {
!as.logical(this$.ignore)
})
###########################################################################/**
# @RdocMethod writeRaw
#
# @title "Writes objects if above threshold"
#
# \description{
# @get "title".
# This method is used by all other methods of this class for output.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Objects to be passed to @see "base::paste".}
# \item{sep}{The default separator @character string.}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("writeRaw", "Verbose", function(this, ..., sep="", level=this$defaultLevel) {
if (!isVisible(this, level))
return(invisible(FALSE))
msg <- paste(..., sep="")
if (this$asGString) {
if (length(msg) > 1) {
msg <- sapply(msg, FUN=function(s) {
as.character(GString(s))
})
} else {
msg <- as.character(GString(msg))
}
}
cat(file=this$.con, append=TRUE, msg)
invisible(TRUE)
}, protected=TRUE)
###########################################################################/**
# @RdocMethod cat
#
# @title "Concatenates and prints objects if above threshold"
#
# \description{
# @get "title".
# The output is indented according to @seemethod "enter"/@seemethod "exit"
# calls.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Objects to be passed to @see "base::cat".}
# \item{sep}{The default separator @character string.}
# \item{newline}{If @TRUE, a newline is added at the end, otherwise not.}
# \item{level}{A @numeric value to be compared to the threshold.}
# \item{timestamp}{A @logical indicating if output should start with a
# timestamp, or not.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seemethod "timestampOn" and \code{timestampOff}().
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("cat", "Verbose", function(this, ..., sep="", newline=TRUE, level=this$defaultLevel, timestamp=this$.timestamp) {
if (!isVisible(this, level))
return(invisible(FALSE))
indent <- paste(rep(" ", length.out=this$indentPos), collapse="")
msg <- paste(..., sep=sep)
msg <- paste(indent, msg, sep="")
if (timestamp) {
fmt <- this$.timestampFormat
if (is.function(fmt)) {
stamp <- fmt()
} else {
stamp <- format(Sys.time(), fmt)
}
msg <- paste(stamp, msg, sep="")
}
if (newline)
msg <- paste(msg, "\n", sep="")
# Write output
writeRaw(this, msg)
})
###########################################################################/**
# @RdocMethod printf
#
# @title "Formats and prints object if above threshold"
#
# \description{
# @get "title".
# The output is indented according to @seemethod "enter"/@seemethod "exit"
# calls.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Objects to be passed to @see "base::sprintf".}
# \item{fmtstr}{A @character string specify the printf format string.}
# \item{level}{A @numeric value to be compared to the threshold.}
# \item{timestamp}{A @logical indicating if output should start with a
# timestamp, or not.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("printf", "Verbose", function(this, fmtstr, ..., level=this$defaultLevel, timestamp=this$.timestamp) {
if (!isVisible(this, level))
return(invisible(FALSE))
cat(this, sprintf(fmtstr, ...), newline=FALSE, timestamp=timestamp)
})
###########################################################################/**
# @RdocMethod enter
# @aliasmethod enterf
#
# @title "Writes a message and indents the following output"
#
# \description{
# @get "title".
# The output is indented according to @seemethod "enter"/@seemethod "exit"
# calls.
# }
#
# \usage{
# @usage "enter,Verbose"
# @usage "enterf,Verbose"
# }
#
# \arguments{
# \item{fmtstr}{An @see "base::sprintf" format string, which together with
# \code{...} constructs the message.}
# \item{...}{Objects to be passed to @seemethod "cat"
# (or @see "base::sprintf").}
# \item{indent}{The number of characters to add to the indentation.}
# \item{sep}{The default separator @character string.}
# \item{suffix}{A @character string to be appended to the end of the message.}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("enter", "Verbose", function(this, ..., indent=this$indentStep, sep="", suffix="...", level=this$defaultLevel) {
msg <- paste(..., sep=sep)
msg <- as.character(GString(msg))
cat(this, msg, suffix, sep=sep, level=level)
this$.stack <- c(this$.stack, msg)
this$.stackLevel <- c(this$.stackLevel, level)
this$indentPos <- this$indentPos + indent
invisible(TRUE)
})
setMethodS3("enterf", "Verbose", function(this, fmtstr, ..., indent=this$indentStep, sep="", suffix="...", level=this$defaultLevel) {
enter(this, sprintf(fmtstr, ...), indent=indent, sep=sep, suffix=suffix, level=level)
})
###########################################################################/**
# @RdocMethod exit
#
# @title "Writes a message and unindents the following output"
#
# \description{
# @get "title".
# The output is indented according to @seemethod "enter"/@seemethod "exit"
# calls.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Objects to be passed to @seemethod "cat". If not specified
# the message used in the corresponding @seemethod "enter" call is used.}
# \item{indent}{The number of characters to be removed from the indentation.}
# \item{sep}{The default separator @character string.}
# \item{suffix}{A @character string to be appended to the end of the message.}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("exit", "Verbose", function(this, ..., indent=-this$indentStep, sep="", suffix="...done", level=NULL) {
args <- list(...)
# Argument 'indent'
if (this$indentPos + indent < 0) {
throw("Cannot exit(): Argument 'indent' makes 'indentPos' negative: ",
this$indentPos + indent)
}
len <- length(this$.stack)
# Balance check
if (length(len) == 0) {
throw("Internal error: Cannot exit(). Unbalanced enter()/exit() stack - it is already empty.")
}
lastMsg <- this$.stack[len]
this$.stack <- this$.stack[-len]
lastLevel <- this$.stackLevel[len]
this$.stackLevel <- this$.stackLevel[-len]
this$indentPos <- this$indentPos + indent
if (length(args) == 0) {
msg <- lastMsg
} else {
msg <- paste(..., sep=sep)
}
if (is.null(level))
level <- lastLevel
cat(this, msg, suffix, sep="", level=level)
invisible(TRUE)
})
###########################################################################/**
# @RdocMethod more
#
# @title "Creates a cloned instance with a lower threshold"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{dThreshold}{The amount the threshold should be lowered.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a cloned @see "Verbose" object.
# }
#
# @author
#
# \seealso{
# @seemethod "less"
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("more", "Verbose", function(this, dThreshold=1, ...) {
# Clone first!
res <- clone(this)
# Decrease the threshold
res$threshold <- res$threshold - dThreshold
# Return the clone
res
})
###########################################################################/**
# @RdocMethod less
#
# @title "Creates a cloned instance with a higher threshold"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{dThreshold}{The amount the threshold should be raised.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a cloned @see "Verbose" object.
# }
#
# @author
#
# \seealso{
# @seemethod "more"
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("less", "Verbose", function(this, dThreshold=1, ...) {
# Clone first!
res <- clone(this)
# Increase the threshold
res$threshold <- res$threshold + dThreshold
# Return the clone
res
})
###########################################################################/**
# @RdocMethod print
#
# @title "Prints objects if above threshold"
#
# \description{
# @get "title".
# The output is \emph{not} indented.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Objects to be passed to @see "base::print".}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("print", "Verbose", function(x, ..., level=this$defaultLevel) {
# To please R CMD check
this <- x
# So that print(this), which often called when 'this' is typed, works.
args <- list(...)
if (length(args) == 0) {
return(NextMethod())
}
# ...otherwise...
capture(this, print(...), level=level)
})
###########################################################################/**
# @RdocMethod str
#
# @title "Prints the structure of an object if above threshold"
#
# \description{
# @get "title".
# The output is \emph{not} indented.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Objects to be passed to @see "utils::str".}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("str", "Verbose", function(object, ..., level=this$defaultLevel) {
# To please R CMD check
this <- object
if (!isVisible(this, level))
return(invisible(FALSE))
capture(this, str(...))
})
###########################################################################/**
# @RdocMethod summary
#
# @title "Generates a summary of an object if above threshold"
#
# \description{
# @get "title".
# The output is \emph{not} indented.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Objects to be passed to @see "base::summary".}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("summary", "Verbose", function(object, ..., level=this$defaultLevel) {
# To please R CMD check
this <- object
if (!isVisible(this, level))
return(invisible(FALSE))
capture(this, print(summary(...)))
})
###########################################################################/**
# @RdocMethod evaluate
#
# @title "Evaluates a function and prints its results if above threshold"
#
# \description{
# @get "title".
# The output is \emph{not} indented.
# }
#
# @synopsis
#
# \arguments{
# \item{fun}{A @function to be evaluated (only if above threshold).}
# \item{...}{Additional arguments passed to the function.}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("evaluate", "Verbose", function(this, fun, ..., level=this$defaultLevel) {
if (!isVisible(this, level))
return(invisible(FALSE))
print(this, fun(...))
})
###########################################################################/**
# @RdocMethod capture
#
# @title "Captures output of a function"
#
# \description{
# @get "title".
# Evaluates its arguments with the output being verbosed.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments to be captured.}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns a @vector of @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/###########################################################################
setMethodS3("capture", "Verbose", function(this, ..., level=this$defaultLevel) {
if (!isVisible(this, level))
return(invisible(FALSE))
args <- substitute(list(...))[-1]
bfr <- NULL; # To please R CMD check R v2.6.0.
file <- textConnection("bfr", "w", local=TRUE)
sink(file)
on.exit({
sink()
close(file)
})
pf <- parent.frame()
evalVis <- function(expr) {
withVisible(eval(expr, envir = pf, enclos = baseenv()))
}
for (kk in seq_along(args)) {
expr <- args[[kk]]
if (mode(expr) == "expression") {
tmp <- lapply(expr, FUN=evalVis)
} else if (mode(expr) == "call") {
tmp <- list(evalVis(expr))
} else if (mode(expr) == "name") {
tmp <- list(evalVis(expr))
} else {
stop("Bad argument")
}
for (item in tmp) {
if (item$visible)
print(item$value)
}
}
indent <- paste(rep(" ", length.out=this$indentPos), collapse="")
bfr2 <- paste(indent, bfr, sep="")
bfr2 <- paste(bfr2, collapse="\n")
bfr2 <- paste(bfr2, "\n", sep="")
writeRaw(this, bfr2)
})
###########################################################################/**
# @RdocMethod newline
#
# @title "Writes one or several empty lines"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{n}{The number of empty lines to write.}
# \item{...}{Not used.}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("newline", "Verbose", function(this, n=1, ..., level=this$defaultLevel) {
if (!isVisible(this, level))
return(invisible(FALSE))
if (n < 0)
stop("Argument 'n' must be zero or greater: ", n)
if (n > 0)
writeRaw(this, paste(rep("\n", n), collapse=""))
invisible(TRUE)
})
###########################################################################/**
# @RdocMethod ruler
#
# @title "Writes a ruler"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{char}{A @character string to make up the ruler.}
# \item{toColumn}{The column number where the ruler should finish.}
# \item{length}{The length of the ruler.}
# \item{...}{Not used.}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("ruler", "Verbose", function(this, char="-", toColumn=this$rightMargin, length=toColumn-this$indentPos, level=this$defaultLevel, ...) {
if (!isVisible(this, level))
return(invisible(FALSE))
char <- as.character(char)
char <- strsplit(char, split="")[[1]]
ruler <- rep(char, length.out=length)
ruler <- paste(ruler, collapse="")
cat(this, ruler)
})
###########################################################################/**
# @RdocMethod header
#
# @title "Writes a header"
#
# \description{
# @get "title" surrounded by a frame.
# The output is indented according to @seemethod "enter"/@seemethod "exit"
# calls.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{The title.}
# \item{char}{The @character string to make up the frame.}
# \item{padding}{The number of rows and character to pad the title above,
# below, and to the left.}
# \item{prefix}{The prefix of all padded lines and the title line.}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("header", "Verbose", function(this, ..., char="-", padding=0, prefix=paste(char, paste(rep(" ", max(padding, 1)), collapse=""), sep=""), level=this$defaultLevel) {
if (!isVisible(this, level))
return(invisible(FALSE))
ruler(this, char=char)
for (kk in seq_len(padding))
writeRaw(this, prefix, "\n")
cat(this, prefix, ..., sep="", collapse="\n")
for (kk in seq_len(padding))
writeRaw(this, prefix, "\n")
ruler(this, char=char)
})
###########################################################################/**
# @RdocMethod timestamp
#
# @title "Writes a timestamp"
#
# \description{
# @get "title" with default format [2005-06-23 21:20:03].
# }
#
# @synopsis
#
# \arguments{
# \item{format}{A @function or a @character specifying the format of the timestamp.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("timestamp", "Verbose", function(this, format=getTimestampFormat(this), ...) {
if (is.function(format)) {
stamp <- format()
} else {
stamp <- format(Sys.time(), format)
}
cat(this, stamp, ...)
})
###########################################################################/**
# @RdocMethod getTimestampFormat
#
# @title "Gets the default timestamp format"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string or a @function.
# }
#
# @author
#
# \seealso{
# @seemethod "setTimestampFormat".
# @seemethod "timestampOn".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("getTimestampFormat", "Verbose", function(this, ...) {
this$.timestampFormat
})
###########################################################################/**
# @RdocMethod setTimestampFormat
#
# @title "Sets the default timestamp format"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{format}{If a @function, this function is called (without arguments)
# whenever a timestamp is generated. If a @character string, it used as
# the format string in \code{format(Sys.date(), fmt)}.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) the old timestamp format.
# }
#
# @author
#
# \seealso{
# @seemethod "getTimestampFormat".
# @seemethod "timestampOn".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("setTimestampFormat", "Verbose", function(this, format="%Y%m%d %H:%M:%S|", ...) {
if (!is.function(format))
format <- as.character(format)
oldValue <- this$.timestampFormat
this$.timestampFormat <- format
invisible(oldValue)
})
###########################################################################/**
# @RdocMethod timestampOn
# @aliasmethod timestampOff
#
# @title "Turns automatic timestamping on and off"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) the old timestamp status.
# }
#
# @author
#
# \seealso{
# @seemethod "setTimestampFormat".
# @seemethod "timestampOn".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("timestampOn", "Verbose", function(this, ...) {
oldStatus <- this$.timestamp
this$.timestamp <- TRUE
invisible(oldStatus)
})
setMethodS3("timestampOff", "Verbose", function(this, ...) {
oldStatus <- this$.timestamp
this$.timestamp <- FALSE
invisible(oldStatus)
})
###########################################################################/**
# @RdocMethod printWarnings
#
# @title "Outputs any warnings recorded"
#
# \description{
# @get "title".
# The output is indented according to @seemethod "enter"/@seemethod "exit"
# calls.
# }
#
# @synopsis
#
# \arguments{
# \item{title}{A @character string to be outputted before the warnings, if
# they exists.}
# \item{...}{Arguments passed to @seemethod "cat".}
# \item{level}{A @numeric value to be compared to the threshold.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @alias printWarnings
# @alias warnings.Verbose
# @keyword programming
#*/###########################################################################
setMethodS3("printWarnings", "Verbose", function(this, title="Warnings detected:", ..., level=this$defaultLevel) {
if (!isVisible(this, level))
return(invisible(FALSE))
if (exists("last.warning", envir=.GlobalEnv)) {
if (!is.null(title))
cat(this, title)
txt <- paste(capture.output(base::warnings()), collapse="\n")
cat(this, txt, ..., level=level)
}
invisible(TRUE)
})
setMethodS3("warnings", "Verbose", function(this, ...) {
.Deprecated(new = "printWarnings()", package = .packageName)
printWarnings(this, ...)
}, deprecated = TRUE)
###########################################################################/**
# @RdocMethod pushState
# @aliasmethod popState
#
# @title "Pushes the current indentation state of the Verbose object"
#
# \description{
# @get "title", which is controlled by @seemethod "enter" and
# @seemethod "exit". By pushing the state when entering a function and
# using @see "base::on.exit" to pop the state, the correct state will
# set regardless of if the functions returned naturally or via an error.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) @TRUE.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("pushState", "Verbose", function(this, ...) {
if (is.null(this$.stackState))
this$.stackState <- list()
stack <- list(
stack = this$.stack,
stackLevel = this$.stackLevel
)
this$.stackState <- c(this$.stackState, list(stack))
invisible(TRUE)
})
setMethodS3("popState", "Verbose", function(this, ...) {
if (length(this$.stackState) == 0)
throw("Stack empty!")
n <- length(this$.stackState)
stack <- this$.stackState[[n]]
this$.stackState <- this$.stackState[-n]
fromN <- length(this$.stack)
toN <- length(stack$stack)
if (fromN > toN) {
for (kk in seq(from=fromN, to=toN+1, by=-1))
exit(this)
} else {
this$.stack <- stack$stack
this$.stackLevel <- stack$stackLevel
}
invisible(TRUE)
})
R.utils/R/readRdHelp.R 0000644 0001762 0000144 00000005623 14372747611 014172 0 ustar ligges users ###########################################################################/**
# @RdocDefault readRdHelp
#
# @title "Reads one or more Rd help files in a certain format"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @see "utils::help".}
# \item{format}{A @character string specifying the return type.}
# \item{drop}{If @FALSE or more than one help entry is found, the result
# is returned as a @list.}
# }
#
# \value{
# Returns a @list of @character strings or a single @character string.
# }
#
# @author
#
# @keyword programming
#*/###########################################################################
setMethodS3("readRdHelp", "default", function(..., format=c("text", "html", "latex", "rd"), drop=TRUE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
readRdHelpTextPreR210 <- function(...) {
stdoutPager <- function(con, ...) {
cat(readLines(con), sep="\n")
}
capture.output({
do.call(help, args=list(..., pager=stdoutPager))
})
} # readRdHelpTextPreR210()
getHelpFile <- get(".getHelpFile", mode="function",
envir=getNamespace("utils"))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'format':
format <- match.arg(format)
# Argument 'drop':
drop <- Arguments$getLogical(drop)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# For R versions before v2.10.0 only
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
rVer <- as.character(getRversion())
if (compareVersion(rVer, "2.10.0") < 0) {
if (format == "text") {
res <- readRdHelpTextPreR210(...)
if (!drop) {
res <- list(res)
}
return(res)
} else {
throw("Unsupported format for R v", rVer, ": ", format)
}
}
# Find the help
x <- help(..., help_type="text")
# Read the Rd file(s)
paths <- as.character(x)
rdList <- lapply(paths, FUN=getHelpFile)
if (format == "rd") {
res <- rdList
} else {
if (format == "text") {
fcn <- tools::Rd2txt
} else if (format == "html") {
fcn <- tools::Rd2HTML
} else if (format == "latex") {
fcn <- tools::Rd2latex
} else {
throw("Unsupported format: ", format)
}
# Translate
# To please R CMD check
bfr <- NULL; rm(list="bfr")
res <- lapply(rdList, FUN=function(rd) {
con <- textConnection("bfr", open="w", local=TRUE)
on.exit(close(con))
fcn(rd, out=con)
bfr
})
}
# If only one item was found, should we return that and not a list?
if (drop && length(res) == 1) {
res <- res[[1]]
}
res
}) # readRdHelp()
R.utils/R/insert.R 0000644 0001762 0000144 00000012521 14372747611 013457 0 ustar ligges users #########################################################################/**
# @RdocDefault insert
#
# @title "Insert values to a vector at certain positions"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{The @vector of data values.}
# \item{ats}{The indices of \code{x} where the values should be inserted.}
# \item{values}{A @list or a @vector of the values to be inserted.
# Should be of same length as \code{ats}, unless if a single value
# when it is automatically extended without a warning.}
# \item{useNames}{If @FALSE, the names attribute is dropped/ignored,
# otherwise not. Only applied if argument \code{x} is named.}
# \item{...}{Not used.}
# }
#
# @examples "../incl/insert.Rex"
#
# \seealso{
# @see "base::append" takes argument \code{after} (a scalar). For example,
# \code{append(x, y, after=after) == insert(x, values=y, ats=after+1)}.
# Contrary to \code{append()}, \code{insert()} accepts a vector of insert indices.
# }
#
# @author
#
# @keyword "manip"
#*/#########################################################################t
setMethodS3("insert", "default", function(x, ats, values=NA, useNames=TRUE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# For debug only!
## printFromTo <- function(from, to, x) {
## fromto <- matrix(c(from, to), ncol=2)
## colnames(fromto) <- c("from", "to")
## idx <- apply(fromto, MARGIN=1, FUN=function(i) seqToHumanReadable(i[1]:i[2]))
## xidx <- apply(fromto, MARGIN=1, FUN=function(i) paste(x[i[1]:i[2]], collapse=","))
## print(data.frame(from=from, to=to, idx=idx, x.=xidx))
## }
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (!is.vector(x))
throw("Argument 'x' is not a vector: ", class(x))
len <- length(x)
if (any(ats < 1 | ats > len+1))
throw("Argument 'ats' contains indices out of range: ", paste(ats, collapse=", "))
if (!is.vector(values) && !is.list(values))
throw("Argument 'values' is not a vector or a list: ", class(values))
alen <- length(ats)
vlen <- length(values)
if (vlen != alen && alen > 1L && vlen > 1L) {
throw("Argument 'ats' and argument 'values' are of different lengths: ",
alen, " != ", vlen)
}
# Argument 'useNames':
useNames <- as.logical(useNames)
# Deal with the names attribute too?
if (useNames) {
names <- names(x)
useNames <- (!is.null(names))
}
# Group 'ats'?
dups <- duplicated(ats)
if (any(dups)) {
uats <- ats[!dups]
alen <- length(uats)
t <- vector("list", length = alen)
for (kk in seq_len(alen)) {
at <- uats[[kk]]
t[[kk]] <- values[which(at == ats)]
}
ats <- uats
values <- t
at <- t <- uats <- NULL
vlen <- length(values)
if (vlen != alen) {
throw("Argument 'ats' and argument 'values' are of different lengths: ",
alen, " != ", vlen)
}
}
dups <- NULL
if (!is.list(values)) {
if (alen == 1L) {
values <- list(values)
vlen <- 1L
} else {
values <- as.list(values)
}
}
if (alen != vlen) {
if (vlen == 1L) {
values <- rep(values, length.out=alen)
vlen <- alen
} else {
throw("Argument 'ats' and argument 'values' are of different lengths: ",
alen, " != ", vlen)
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Setup
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Sort the 'ats' indicies
o <- order(ats)
ats <- ats[o]
values <- values[o]
nvalues <- unlist(lapply(values, FUN=length))
# Allocate the result vector
n2 <- length(x) + sum(nvalues)
x2 <- vector(mode=mode(x), length=n2)
storage.mode(x2) <- storage.mode(x)
if (useNames)
names2 <- character(n2)
# 'ats' positions in the result vector
n <- length(ats)
ats2 <- ats + c(0, cumsum(nvalues[-n]))
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Assign inserted values
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
for (kk in 1:length(ats2)) {
idx2 <- ats2[kk] + 0:(nvalues[kk]-1)
valuesKK <- values[[kk]]
x2[idx2] <- valuesKK
if (useNames) {
valueNames <- names(valuesKK)
if (is.null(valueNames))
valueNames <- character(length(valuesKK))
names2[idx2] <- valueNames
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Assign original values
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
froms <- c(1, ats)
tos <- c(ats-1, length(x))
froms2 <- c(1, ats2+nvalues)
if (ats[1] == 1) {
froms <- froms[-1]
tos <- tos[-1]
froms2 <- froms2[-1]
}
if (ats[n] > length(x)) {
froms <- froms[-length(froms)]
tos <- tos[-length(tos)]
froms2 <- froms2[-length(froms2)]
}
ns <- tos-froms+1
tos2 <- froms2 + ns - 1
for (kk in seq_along(froms2)) {
from <- froms[kk]
to <- tos[kk]
from2 <- froms2[kk]
to2 <- tos2[kk]
idx <- from:to
idx2 <- from2:to2
x2[idx2] <- x[idx]
if (useNames)
names2[idx2] <- names[idx]
}
if (useNames)
names(x2) <- names2
x2
})
R.utils/R/GenericSummary.R 0000644 0001762 0000144 00000001776 14372747611 015117 0 ustar ligges users setConstructorS3("GenericSummary", function(s="", ...) {
class(s) <- "GenericSummary"
s
}, protected=TRUE)
setMethodS3("print", "GenericSummary", function(x, ..., collapse="\n") {
# To please R CMD check
this <- x
s <- as.character(this)
s <- paste(s, collapse=collapse)
cat(s, collapse, sep="")
}, protected=TRUE)
setMethodS3("c", "GenericSummary", function(x, ...) {
s <- NextMethod()
class(s) <- class(x)
s
}, protected=TRUE)
setMethodS3("[", "GenericSummary", function(x, i, ...) {
s <- NextMethod()
class(s) <- class(x)
s
}, protected=TRUE)
# setMethodS3("as.character", "GenericSummary", function(this, ..., indent=" ") {
# toString <- function(s, currIndent="") {
# if (is.list(s)) {
# s <- sapply(s, FUN=function(x) {
# paste(currIndent,
# toString(x, currIndent=paste(currIndent, indent, sep="")),
# sep="")
# })
# unlist(s, use.names=FALSE)
# } else {
# s
# }
# }
#
# toString(this)
# })
R.utils/R/intervalsToSeq.R 0000644 0001762 0000144 00000003010 14372747611 015127 0 ustar ligges users #########################################################################/**
# @set "class=matrix"
# @RdocMethod intervalsToSeq
#
# @title "Generates a vector of indices from a matrix of intervals"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{fromTo}{An Nx2 @integer @matrix.}
# \item{sort}{If @TRUE, the returned indices are ordered.}
# \item{unique}{If @TRUE, the returned indices are unique.}
# \item{...}{Not used.}
# }
#
# @author
#
# \examples{\dontrun{See example(seqToIntervals)}}
#
# \seealso{
# @see "seqToIntervals".
# }
#
# @keyword "attribute"
#*/#########################################################################t
setMethodS3("intervalsToSeq", "matrix", function(fromTo, sort=FALSE, unique=FALSE, ...) {
# Argument 'fromTo':
if (ncol(fromTo) != 2) {
throw("Argument 'fromTo' is not a two-column matrix: ", ncol(fromTo))
}
if (!is.numeric(fromTo)) {
throw("Argument 'fromTo' is not a numeric matrix: ", mode(fromTo))
}
# Pre-allocate result vector
ns <- fromTo[,2] - fromTo[,1] + as.integer(1)
n <- sum(ns)
res <- vector("integer", n)
offset <- as.integer(0)
for (rr in seq_len(nrow(fromTo))) {
# Sequence for current interval
idxs <- offset + 1:ns[rr]
res[idxs] <- fromTo[rr,1]:fromTo[rr,2]
# Not needed anymore
idxs <- NULL
# Next interval
offset <- offset + ns[rr]
}
# Return unique indices?
if (unique) {
res <- unique(res)
}
# Return sorted indices?
if (sort) {
res <- sort(res)
}
res
})
R.utils/R/isFile.R 0000644 0001762 0000144 00000003630 14372747611 013367 0 ustar ligges users ###########################################################################/**
# @RdocDefault isFile
#
# @title "Checks if the file specification is a file"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{A @character string of the pathname to be checked.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns @TRUE if the file specification is a file, otherwise
# @FALSE is returned.
# }
#
# \section{Symbolic links}{
# This function follows symbolic links (also on Windows) and returns a
# value based on the link target (rather than the link itself).
# }
#
# @author
#
# \seealso{
# To check if it is a directory see @see "isDirectory".
# Internally @see "base::file.info" is used.
# See also @see "utils::file_test".
# }
#
# @keyword IO
# @keyword programming
#*/###########################################################################
setMethodS3("isFile", "default", function(pathname, ...) {
# Argument 'pathname':
pathname <- as.character(pathname)
# BACKWARD COMPATIBILITY: Treat empty path specially?
pathname <- .getPathIfEmpty(pathname, where="isFile")
nPathnames <- length(pathname)
# Nothing to do?
if (nPathnames == 0L) return(logical(0L))
# Multiple pathnames to be checked?
if (nPathnames > 1L) {
res <- sapply(pathname, FUN=isFile, ...)
return(res)
}
# A missing pathname?
if (is.na(pathname)) return(FALSE)
isdir <- file.info(pathname)$isdir
if (identical(isdir, FALSE))
return(TRUE)
if (is.na(isdir)) {
if (!isAbsolutePath(pathname))
return(FALSE)
# Try the relative pathname
relPathname <- getRelativePath(pathname)
# Avoid infinite recursive loops; check if succeeded in getting a
# relative pathname?
if (!identical(relPathname, pathname)) {
return(isFile(relPathname))
} else {
# At this point, we can only return FALSE.
return(FALSE)
}
}
return(FALSE)
})
R.utils/R/systemR.R 0000644 0001762 0000144 00000004246 14372747611 013626 0 ustar ligges users ###########################################################################/**
# @RdocDefault systemR
# @alias systemR
#
# @title "Launches another R process from within R"
#
# @synopsis
#
# \description{
# @get "title" via @see "base::system" by automatically locating the
# R executable, cf [1].
# }
#
# \arguments{
# \item{command}{A @character string be appended to the @see "base::system"
# call. If a @vector, then the strings are concatenated separated
# with a space.}
# \item{...}{Additional arguments passed to @see "base::system".}
# \item{Rcommand}{A @character string specifying the basename of
# the R executable.}
# \item{verbose}{A @logical or a @see "Verbose" object.}
# }
#
# \value{
# Returns what @see "base::system" returns.
# }
#
# @examples "../incl/systemR.Rex"
#
# @author
#
# \references{
# [1] R-devel thread 'Best way to locate R executable from within R?',
# May 22, 2012.
# }
#
# \seealso{
# The R executable is located using @see "base::R.home", which
# is then launched using @see "base::system".
# }
#
# @keyword programming
# @keyword IO
#*/###########################################################################
setMethodS3("systemR", "default", function(command="", ..., Rcommand="R", verbose=FALSE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'command':
command <- Arguments$getCharacters(command)
# Locate the R executable, cf. help("R.home") and [1].
# NB: R.home() is guaranteed to return a path without spaces.
Rpath <- R.home("bin")
Rpath <- Arguments$getReadablePath(Rpath, mustExist=TRUE)
# Argument 'Rcommand':
Rcommand <- Arguments$getCharacter(Rcommand)
verbose <- Arguments$getVerbose(verbose)
if (verbose) {
pushState(verbose)
on.exit(popState(verbose), add=TRUE)
}
# Setup the full system command
Rbin <- file.path(Rpath, Rcommand)
command <- paste(command, collapse=" ")
command <- paste(command, sep=" ")
cmd <- sprintf('%s %s', shQuote(Rbin), command)
verbose && cat(verbose, "System command: ", cmd)
system(cmd, ...)
})
R.utils/R/removeDirectory.R 0000644 0001762 0000144 00000005435 14372747611 015343 0 ustar ligges users ###########################################################################/**
# @RdocDefault removeDirectory
#
# @title "Removes a directory"
#
# \description{
# @get "title", and if requested, also its contents.
# }
#
# @synopsis
#
# \arguments{
# \item{path}{A @character string specifying the directory to be removed.}
# \item{recursive}{If @TRUE, subdirectories and files are also removed.
# If @FALSE, and directory is non-empty, an exception is thrown.}
# \item{mustExist}{If @TRUE, and the directory does not exist,
# an exception is thrown.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns (invisibly) @TRUE, the directory was successfully removed,
# otherwise @FALSE, unless an exception is thrown.
# }
#
# \section{Symbolic links}{
# This function can also be used to remove symbolic links to directories
# without removing the target.
# Note that neither @see "base::file.remove" nor @see "base::unlink"
# is capable of remove symbolic \emph{directory} links on Windows.
# }
#
# @author
#
# \seealso{
# Internally @see "base::unlink" is used.
# }
#
# @keyword IO
# @keyword programming
#*/###########################################################################
setMethodS3("removeDirectory", "default", function(path, recursive=FALSE, mustExist=TRUE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'path':
path <- Arguments$getReadablePath(path, mustExist=mustExist)
# WORKAROUND: base::unlink() does not support paths with leading tilde,
# cf. https://stat.ethz.ch/pipermail/r-help/2010-October/254998.html
# /HB 2010-11-17
path <- path.expand(path)
path <- Arguments$getReadablePath(path, mustExist=mustExist)
# Argument 'recursive':
recursive <- Arguments$getLogical(recursive)
# Check if a symbolic link
pathT <- Sys.readlink2(path, what="corrected")
isSymlink <- (!is.na(pathT) && nchar(pathT, type="chars") > 0L)
if (isSymlink) {
# Special case: Windows
if (.Platform$OS.type == "windows") {
cmd <- sprintf("rmdir %s", dQuote(normalizePath(path)))
shell(cmd, shell=Sys.getenv("COMSPEC"), intern=TRUE, mustWork=TRUE)
} else {
file.remove(path)
}
return(invisible(!isDirectory(path)))
}
# Check if directory is empty
pathnames <- list.files(path=path, all.files=TRUE, full.names=FALSE)
pathnames <- setdiff(pathnames, c(".", ".."))
isEmpty <- (length(pathnames) == 0)
if (!isEmpty && !recursive) {
throw("Cannot remove directory. Directory is not empty: ", path)
}
# Remove directory (if 'recursive' is FALSE, the actual directory
# will not be removed).
res <- unlink(path, recursive=TRUE)
return(invisible(!isDirectory(path)))
}) # removeDirectory()
R.utils/R/readWindowsShellLink.R 0000644 0001762 0000144 00000075351 14372747611 016261 0 ustar ligges users ###########################################################################/**
# @RdocDefault readWindowsShellLink
#
# @title "Reads a Microsoft Windows Shortcut (.lnk file)"
#
# @synopsis
#
# \description{
# @get "title".
# }
#
# \arguments{
# \item{con}{A @connection or a @character string (filename).}
# \item{clean}{If @TRUE, low-level file specific fields are dropped,
# e.g. offsets on file locations.}
# \item{verbose}{If @TRUE, extra information is written while reading.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @list structure.
# }
#
# @examples "../incl/readWindowsShellLink.Rex"
#
# \details{
# This function is implemented based on the official file format
# specification [1].
# It is intended to replace @see "readWindowsShortcut", which was
# written based on reverse engineering (before [1] was made available).
# }
#
# @author
#
# \seealso{
# @see "readWindowsShortcut"
# \code{\link{filePath}}
# }
#
# \references{
# [1] [MS-SHLLINK]: Shell Link (.LNK) Binary File Format, Microsoft Inc.,
# September 25, 2009. \cr
# }
#
# @keyword file
# @keyword IO
# @keyword internal
#*/###########################################################################
setMethodS3("readWindowsShellLink", "default", function(con, clean=TRUE, verbose=FALSE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
intToBits <- function(x, n=NULL, names=NULL, rev=TRUE, ...) {
# Argument 'x':
.stop_if_not(is.integer(x))
.stop_if_not(length(x) == 1L)
# Argument 'n':
if (!is.null(n)) {
.stop_if_not(n > 0L)
}
# Argument 'names':
if (!is.null(names)) {
.stop_if_not(is.character(names))
if (!is.null(n)) {
.stop_if_not(length(names) == n)
}
n <- length(names)
}
# Get binary represenation
x <- intToBin(x)
x <- unlist(strsplit(x, split=""), use.names=FALSE)
.stop_if_not(length(x) <= n)
x <- as.integer(x)
x <- as.logical(x)
x <- c(rep(FALSE, times=n-length(x)), x)
.stop_if_not(length(x) == n)
if (!is.null(names)) {
x <- rev(x)
names(x) <- names
x <- rev(x)
}
if (rev) {
x <- rev(x)
}
x
} # intToBits()
readBits <- function(con, n=32L, ...) {
.stop_if_not(n %% 8 == 0)
nbrOfBytes <- n %/% 8L
if (nbrOfBytes <= 2L) {
x <- readBin(con=con, what=integer(), size=nbrOfBytes, n=1L, signed=FALSE, endian="little")
} else {
x <- readBin(con=con, what=integer(), size=nbrOfBytes, n=1L, endian="little")
}
intToBits(x, n=n)
} # readBits()
# raw - An 1-byte unsigned integer
readRaw <- function(con, n=1) {
readBin(con=con, what=raw(), n=n)
}
# byte - An 1-byte unsigned integer
readByte <- function(con, n=1) {
readBin(con=con, what=integer(), size=1L, n=n,
signed=FALSE, endian="little")
}
# word - A 2-byte unsigned integer
readWord <- function(con, n=1) {
readBin(con=con, what=integer(), size=2L, n=n,
signed=FALSE, endian="little")
}
# qword - A 4-byte unsigned integer (actually as signed integer)
readDWord <- function(con, n=1) {
readBin(con=con, what=integer(), size=4L, n=n,
signed=TRUE, endian="little")
}
# qword - An 8-byte unsigned integer (actually as signed integer)
readQWord <- function(con, n=1) {
readBin(con=con, what=integer(), size=4L, n=2*n,
signed=TRUE, endian="little")
}
readString <- function(con, nchars=-1L, unicoded=FALSE) {
if (nchars == -1) {
bfr <- c()
while ((byte <- readByte(con)) != 0L) {
bfr <- c(bfr, byte)
}
} else {
if (unicoded)
nchars <- 2L*nchars
bfr <- readByte(con, n=nchars)
}
# Since R does not support Unicoded strings, we (incorrectly) assume
# (=hope) that it is only the unicode characters 0:255 that are used.
if (unicoded)
bfr <- bfr[bfr != 0]
paste(intToChar(bfr), collapse="")
} # readString()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# From [7]:
# The Shell Link Binary File Format consists of a sequence of structures
# that conform to the following ABNF rules [RFC5234]:
#
# SHELL_LINK = SHELL_LINK_HEADER [LINKTARGET_IDLIST] [LINKINFO]
# [STRING_DATA] *EXTRA_DATA
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# The ShellLinkHeader structure contains identification information,
# timestamps, and flags that specify the presence of optional structures,
# including LinkTargetIdList (section 2.2), LinkInfo (section 2.3),
# and StringData (section 2.4).
#
# [SHELL_LINK_HEADER] =
# HeaderSize (4 bytes):
# The size, in bytes, of this structure. MUST be 0x0000004C.
# LinkCLSID (16 bytes):
# A class identifier (CLSID). MUST be 00021401-0000-0000-C000-000000000046.
# LinkFlags (4 bytes):
# A LinkFlags structure (section 2.1.1) that specifies information about
# the shell link and the presence of optional portions of the structure.
# FileAttributes (4 bytes):
# A FileAttributesFlags structure (section 2.1.2) that specifies
# information about the link target.
# CreationTime (8 bytes):
# A FILETIME structure ([MS-DTYP] section 2.3.1) that specifies the
# creation time of the link target in UTC (Coordinated Universal Time).
# If the value is zero, there is no creation time set on the link target.
# AccessTime (8 bytes):
# A FILETIME structure ([MS-DTYP] section 2.3.1) that specifies the
# access time of the link target in UTC (Coordinated Universal Time).
# If the value is zero, there is no access time set on the link target.
# WriteTime (8 bytes):
# A FILETIME structure ([MS-DTYP] section 2.3.1) that specifies the
# write time of the link target in UTC (Coordinated Universal Time).
# If the value is zero, there is no write time set on the link target.
# FileSize (4 bytes):
# A 32-bit unsigned integer that specifies the size, in bytes,
# of the link target. If the link target file is larger than
# 0xFFFFFFFF, this value specifies the least significant 32 bits
# of the link target file size.
# IconIndex (4 bytes)
# A 32-bit signed integer that specifies the index of an icon
# within a given icon location.
# ShowCommand (4 bytes):
# A 32-bit unsigned integer that specifies the expected window state
# of an application launched by the link. This value SHOULD be one
# of the following.
# SW_SHOWNORMAL = 0x00000001
# The application is open and its window is open in a normal fashion.
# SW_SHOWMAXIMIZED = 0x00000003
# The application is open, and keyboard focus is given to the
# application, but its window is not shown.
# SW_SHOWMINNOACTIVE = 0x00000007
# The application is open, but its window is not shown. It is not
# given the keyboard focus.
# HotKey (2 bytes):
# A HotKeyFlags structure (section 2.1.3) that specifies the keystrokes
# used to launch the application referenced by the shortcut key. This
# value is assigned to the application after it is launched, so that
# pressing the key activates that application.
# Reserved1 (2 bytes): A value that MUST be zero.
# Reserved2 (4 bytes): A value that MUST be zero.
# Reserved3 (4 bytes): A value that MUST be zero.
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
parseLinkFlags <- function(flags, ...) {
keys <- character(length=27L)
keys[ 1] <- "HasLinkTargetIdList"
keys[ 2] <- "HasLinkInfo"
keys[ 3] <- "HasName"
keys[ 4] <- "HasRelativePath"
keys[ 5] <- "HasWorkingDir"
keys[ 6] <- "HasArguments"
keys[ 7] <- "HasIconLocation"
keys[ 8] <- "IsUnicode"
keys[ 9] <- "ForceNoLinkInfo"
keys[10] <- "HasExpString"
keys[11] <- "RunInSeparateProcess"
keys[12] <- "Unused1"
keys[13] <- "HasDarwinId"
keys[14] <- "RunAsUser"
keys[15] <- "HasExpIcon"
keys[16] <- "NoPidlAlias"
keys[17] <- "Unused2"
keys[18] <- "RunWithShimLayer"
keys[19] <- "ForceNoLinkTrack"
keys[20] <- "EnableTargetMetadata"
keys[21] <- "DisableLinkPathTracking"
keys[22] <- "DisableKnownFolderTracking"
keys[23] <- "DisableKnownFolderAlias"
keys[24] <- "AllowLinkToLink"
keys[25] <- "UnaliasOnSave"
keys[26] <- "PreferEnvironmentPath"
keys[27] <- "KeepLocalIdListForUNCTarget"
flags <- intToBits(flags, names=keys)
# Validation
.stop_if_not(flags["IsUnicode"])
flags
} # parseLinkFlags()
parseFileAttributes <- function(attrs, ...) {
keys <- character(length=15L)
keys[ 1] <- "readOnly"
keys[ 2] <- "hidden"
keys[ 3] <- "system"
keys[ 4] <- "reserved1"
keys[ 5] <- "directory"
keys[ 6] <- "archive"
keys[ 7] <- "reserved2"
keys[ 8] <- "normal"
keys[ 9] <- "temporary"
keys[10] <- "sparseFile"
keys[11] <- "reparsePoint"
keys[12] <- "compressed"
keys[13] <- "offline"
keys[14] <- "notContentIndexed"
keys[15] <- "encrypted"
attrs <- intToBits(attrs, names=keys)
# Validate
keys <- c("reserved1", "reserved2")
for (key in keys) {
if (attrs[key] != 0L) {
stop(sprintf("File format error: File header field 'fileAttributes' flag '%s' must be FALSE: %d", key, attrs[key]))
}
}
if (attrs["normal"] && sum(attrs) != 1L) {
stop(sprintf("File format error: File header field 'fileAttributes' flag 'normal' is set, but still detected %d other flags also being set.", sum(attrs)-1L))
}
attrs
} # parseFileAttributes()
parseShowCommand <- function(showCommand, ...) {
# Argument 'showCommand':
.stop_if_not(is.integer(showCommand))
.stop_if_not(length(showCommand) == 1L)
showCommand
} # parseShowCommand()
parseHotKey <- function(hotKey, ...) {
# Argument 'hotKey':
.stop_if_not(is.integer(hotKey))
.stop_if_not(length(hotKey) == 1L)
# Get binary represenation
lowByte <- hotKey %% 256L
highByte <- hotKey %/% 256L
if (highByte < 0L || highByte > 7L) {
stop(sprintf("File format error: File header field 'hotKey' has a 'highByte' out of range [0x00,0x07]: %d", highByte))
}
hotKey <- c(lowByte=lowByte, highByte=highByte)
hotKey
} # parseHotKey()
readShellLinkHeader <- function(con, ...) {
hdr <- list(
headerSize = readDWord(con), # 4 bytes
linkCLSID = readRaw(con, n=16), # 16 bytes
linkFlags = readDWord(con), # 4 bytes = 32 bits
fileAttributes = readDWord(con), # 4 bytes = 32 bits
creationTime = readQWord(con), # 8 bytes
accessTime = readQWord(con), # 8 bytes
writeTime = readQWord(con), # 8 bytes
fileSize = readDWord(con), # 4 bytes
iconIndex = readDWord(con), # 4 bytes
showCommand = readDWord(con), # 4 bytes
hotKey = readWord(con), # 2 bytes
reserved1 = readWord(con), # 2 bytes
reserved2 = readDWord(con), # 4 bytes
reserved3 = readDWord(con) # 4 bytes
); # =76 bytes total
# Validate
if (hdr$headerSize != 76L) {
stop("File format error: Shell link header size is not 76 bytes (0x0000004C): ", hdr$headerSize)
}
# Validate
knownCLSID <- as.raw(c(0x01, 0x14, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46))
if (!all.equal(hdr$linkCLSID, knownCLSID)) {
knownCLSID <- paste(sprintf("%02x", as.integer(knownCLSID)), collapse=",")
linkCLSID <- paste(sprintf("%02x", as.integer(hdr$linkCLSID)), collapse=",")
stop("File format error: Shell link header has an unknown CLSID: ", knownCLSID, " != ", linkCLSID)
}
# Parse (and validate)
hdr$linkFlags <- parseLinkFlags(hdr$linkFlags)
# Parse (and validate)
hdr$fileAttributes <- parseFileAttributes(hdr$fileAttributes)
parseFileTime <- function(time, ...) {
offset <- as.POSIXlt("1601-01-01")
timeD <- as.double(time)
timeD <- c(1, 2^32)*timeD
timeD <- sum(timeD)
secs <- 1.0e-7*timeD
time <- offset + secs
time
} # parseFileTime()
hdr$creationTime <- parseFileTime(hdr$creationTime)
hdr$accessTime <- parseFileTime(hdr$accessTime)
hdr$writeTime <- parseFileTime(hdr$writeTime)
if (hdr$linkFlags["HasLinkInfo"]) {
attrs <- hdr$fileAttributes
# attrs <- names(attrs[attrs])
# if (length(attrs) > 0L) {
# stop("File format error: When shortcut is not pointing to a file or a directory no other file attributes should be set: ", paste(attrs, collapse=", "))
# }
}
# Validate
if (hdr$fileSize < 0L) {
stop("File format error: File length is negative: ", header$fileLength)
}
# Parse (and validate)
hdr$showCommand <- parseShowCommand(hdr$showCommand)
# Parse (and validate)
hdr$hotKey <- parseHotKey(hdr$hotKey)
# Validate
keys <- c("reserved1", "reserved2", "reserved3")
for (key in keys) {
if (hdr[[key]] != 0L) {
stop(sprintf("File format error: File header field '%s' must be 0: %d", key, hdr[[key]]))
}
}
if (clean) {
hdr$headerSize <- NULL
}
hdr
} # readShellLinkHeader()
readLinkTargetIdList <- function(con, ...) {
readIdList <- function(con, n) {
.stop_if_not(n >= 2L)
raw <- readRaw(con, n=n)
terminalId <- raw[(n-1L):n]
.stop_if_not(all(terminalId == 0L))
raw <- raw[1:(n-2L)]
# Parse 'itemIdList' into list of 'ItemId':s
itemIdList <- list()
idx <- 1L
while(length(raw) > 0L) {
.stop_if_not(length(raw) >= 2L)
itemIdSize <- readWord(raw)
raw <- raw[-(1:2)]
nbrOfBytesToRead <- itemIdSize - 2L
if (nbrOfBytesToRead > 0L) {
.stop_if_not(length(raw) >= nbrOfBytesToRead)
Data <- readRaw(raw, n=nbrOfBytesToRead)
itemIdList[[idx]] <- Data
raw <- raw[-(1:nbrOfBytesToRead)]
} else {
Data <- raw(length=0L)
}
itemIdList[[idx]] <- Data
idx <- idx + 1L
} # while()
# Sanity check
.stop_if_not(length(raw) == 0L)
## itemIdList <- lapply(itemIdList, FUN=rawToChar)
idList <- list(itemIdList=itemIdList, terminalId=terminalId)
if (clean) {
idList$terminalId <- NULL
}
idList
} # readIdList()
idListSize <- readWord(con)
idList <- readIdList(con, n=idListSize)
} # readLinkTargetIdList()
readLinkInfo <- function(con, ...) {
parseLinkInfoFlags <- function(flags, ...) {
keys <- character(length=2L)
keys[1] <- "VolumeIdAndLocalBasePath"
keys[2] <- "CommonNetworkRelativeLinkAndPathSuffix"
flags <- intToBits(flags, names=keys)
flags
} # parseLinkInfoFlags()
readVolumeId <- function(con, ...) {
id <- list(
volumeIdSize = readDWord(con), # 4 bytes
driveType = readDWord(con), # 4 bytes
driveSerialNumber = readDWord(con), # 4 bytes
volumeLabelOffset = readDWord(con) # 4 bytes
)
nbrOfBytesRead <- 4*4L
.stop_if_not(id$volumeIdSize > 0x00000010)
.stop_if_not(id$volumeLabelOffset >= 0L)
.stop_if_not(id$volumeLabelOffset < id$volumeIdSize)
.stop_if_not(id$driveType >= 0L)
.stop_if_not(id$driveType <= 6L)
if (id$volumeLabelOffset == 0x00000014) {
id$volumeLabelOffsetUnicode <- readDWord(con)
nbrOfBytesRead <- nbrOfBytesRead + 4L
offset <- id$volumeLabelOffsetUnicode
} else {
offset <- id$volumeLabelOffset
}
id$data <- readRaw(con, n=id$volumeIdSize-nbrOfBytesRead)
offset <- offset - nbrOfBytesRead
nbrOfBytesRead <- nbrOfBytesRead + length(id$data)
# Parse the volume label
data <- id$data
if (offset > 0L) {
data <- data[-c(1:offset)]
}
n <- which(data == as.raw(0x0))-1L
if (n < length(data)) {
data <- data[1:n]
}
id$volumeLabel <- rawToChar(data)
# Sanity check
.stop_if_not(nbrOfBytesRead == id$volumeIdSize)
id
} # readVolumeId()
info <- list(
size = readDWord(con), # 4 bytes
headerSize = readDWord(con), # 4 bytes
flags = readDWord(con), # 4 bytes = 32 bits
volumeIdOffset = readDWord(con), # 4 bytes
localBasePathOffset = readDWord(con), # 4 bytes
commonNetworkRelativeLinkOffset = readDWord(con), # 4 bytes
commonPathSuffixOffset = readDWord(con) # 4 bytes
)
nbrOfBytesRead <- 7*4L
.stop_if_not(info$size >= 0L)
.stop_if_not(info$headerSize >= 0L)
.stop_if_not(info$headerSize < info$size)
.stop_if_not(info$volumeIdOffset < info$size)
.stop_if_not(info$localBasePathOffset < info$size)
.stop_if_not(info$commonNetworkRelativeLinkOffset < info$size)
.stop_if_not(info$commonPathSuffixOffset < info$size)
info$flags <- parseLinkInfoFlags(info$flags)
# Validate
if (info$flags["VolumeIdAndLocalBasePath"]) {
} else {
# Sanity checks
.stop_if_not(info$volumeIdOffset == 0L)
.stop_if_not(info$localBasePathOffset == 0L)
if (info$headerSize >= 0x00000024) {
.stop_if_not(info$localBasePathOffsetUnicode == 0L)
}
}
# Validate
if (info$flags["CommonNetworkRelativeLinkAndPathSuffix"]) {
} else {
# Sanity checks
.stop_if_not(info$commonNetworkRelativeLinkOffset == 0L)
}
# LocalBasePathOffsetUnicode (optional)
if (info$headerSize >= 0x00000024) {
info$localBasePathOffsetUnicode <- readDWord(con)
nbrOfBytesRead <- nbrOfBytesRead + 4L
# Sanity check
if (info$flags["VolumeIdAndLocalBasePath"]) {
.stop_if_not(info$localBasePathOffsetUnicode >= 0L)
} else {
.stop_if_not(info$localBasePathOffsetUnicode == 0L)
}
}
.stop_if_not(nbrOfBytesRead <= info$size)
# CommonPathSuffixOffsetUnicode (optional)
if (info$headerSize >= 0x00000024) {
info$commonPathSuffixOffsetUnicode <- readDWord(con)
nbrOfBytesRead <- nbrOfBytesRead + 4L
# Sanity check
if (info$flags["VolumeIdAndLocalBasePath"]) {
.stop_if_not(info$commonPathSuffixOffsetUnicode >= 0L)
} else {
.stop_if_not(info$commonPathSuffixOffsetUnicode == 0L)
}
}
.stop_if_not(nbrOfBytesRead <= info$size)
# VolumeId (variable)
if (info$flags["VolumeIdAndLocalBasePath"]) {
offset <- info$volumeIdOffset - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
id <- readVolumeId(con)
nbrOfBytesRead <- nbrOfBytesRead + id$volumeIdSize
if (clean) {
id$volumeIdSize <- NULL
id$volumeLabelOffset <- NULL
}
info$volumeId <- id
}
.stop_if_not(nbrOfBytesRead <= info$size)
# LocalBasePath (variable)
if (info$flags["VolumeIdAndLocalBasePath"]) {
offset <- info$localBasePathOffset
.stop_if_not(offset >= 0L)
if (offset > 0L) {
offset <- offset - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
nextOffset <- info$commonNetworkRelativeLinkOffset
if (nextOffset == 0L || is.null(nextOffset)) {
nextOffset <- info$commonPathSuffixOffset
if (nextOffset == 0L || is.null(nextOffset)) {
stop("XXX")
}
}
n <- nextOffset - nbrOfBytesRead
localBasePath <- readRaw(con, n=n)
nbrOfBytesRead <- nbrOfBytesRead + n
info$localBasePath <- rawToChar(localBasePath)
}
}
.stop_if_not(nbrOfBytesRead <= info$size)
# CommonNetworkRelativeLink (variable)
if (info$flags["CommonNetworkRelativeLinkAndPathSuffix"]) {
readCommonNetworkRelativeLink <- function(con, ...) {
parseCommonNetworkRelativeLinkFlags <- function(x, ...) {
keys <- c("ValidDevice", "ValidNetType")
x <- intToBits(x, names=keys)
x
} # parseCommonNetworkRelativeLinkFlags()
link <- list(
size = readDWord(con), # 4 bytes
flags = readDWord(con), # 4 bytes
netNameOffset = readDWord(con), # 4 bytes
deviceNameOffset = readDWord(con), # 4 bytes
networkProviderType = readDWord(con) # 4 bytes
)
# Validate
.stop_if_not(link$size >= 0x00000014)
.stop_if_not(link$netNameOffset >= 0L)
.stop_if_not(link$deviceNameOffset >= 0L)
nbrOfBytesRead <- 5*4L
link$flags <- parseCommonNetworkRelativeLinkFlags(link$flags)
if (!link$flags["ValidDevice"]) {
.stop_if_not(link$deviceNameOffset == 0L)
}
if (!link$flags["ValidNetType"]) {
.stop_if_not(link$netProviderType == 0L)
}
if (link$netNameOffset > 0x00000014) {
link$netNameOffsetUnicode <- readDWord(con)
nbrOfBytesRead <- nbrOfBytesRead + 4L
.stop_if_not(link$netNameOffsetUnicode >= 0L)
link$deviceNameOffsetUnicode <- readDWord(con)
nbrOfBytesRead <- nbrOfBytesRead + 4L
.stop_if_not(link$deviceNameOffsetUnicode >= 0L)
}
# NetName (variable)
nextOffset <- link$deviceNameOffset
if (nextOffset == 0L) {
nextOffset <- link$netNameOffsetUnicode
if (is.null(nextOffset)) {
nextOffset <- link$deviceNameOffsetUnicode
if (is.null(nextOffset)) {
nextOffset <- link$size + 1L
}
}
}
.stop_if_not(!is.null(nextOffset))
offset <- link$netNameOffset - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
n <- nextOffset - nbrOfBytesRead - 1L
netName <- readRaw(con, n=n)
nbrOfBytesRead <- nbrOfBytesRead + n
link$netName <- rawToChar(netName)
# DeviceName (variable)
if (link$flags["ValidDevice"]) {
nextOffset <- link$netNameOffsetUnicode
if (is.null(nextOffset)) {
nextOffset <- link$deviceNameOffsetUnicode
if (is.null(nextOffset)) {
nextOffset <- link$size + 1L
}
}
.stop_if_not(!is.null(nextOffset))
offset <- link$deviceNameOffset - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
n <- nextOffset - nbrOfBytesRead - 1L
netName <- readRaw(con, n=n)
nbrOfBytesRead <- nbrOfBytesRead + n
link$deviceName <- rawToChar(netName)
}
# NetNameOffsetUnicode (variable)
if (!is.null(link$netNameOffsetUnicode)) {
nextOffset <- link$deviceNameOffsetUnicode
if (is.null(nextOffset)) {
nextOffset <- link$size + 1L
}
.stop_if_not(!is.null(nextOffset))
offset <- link$netNameOffsetUnicode - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
n <- nextOffset - nbrOfBytesRead - 1L
netName <- readRaw(con, n=n)
nbrOfBytesRead <- nbrOfBytesRead + n
link$netNameOffsetUnicode <- rawToChar(netName)
}
# DeviceNameOffsetUnicode (variable)
if (!is.null(link$deviceNameOffsetUnicode)) {
nextOffset <- link$size + 1L
.stop_if_not(!is.null(nextOffset))
offset <- link$deviceNameOffsetUnicode - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
n <- nextOffset - nbrOfBytesRead - 1L
value <- readRaw(con, n=n)
nbrOfBytesRead <- nbrOfBytesRead + n
link$deviceNameOffsetUnicode <- rawToChar(value)
}
link
} # readCommonNetworkRelativeLink()
offset <- info$commonNetworkRelativeLinkOffset - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
info$commonNetworkRelativeLink <- readCommonNetworkRelativeLink(con)
n <- info$commonNetworkRelativeLink$size
nbrOfBytesRead <- nbrOfBytesRead + n
if (clean) {
info$commonNetworkRelativeLink$flags <- NULL
info$commonNetworkRelativeLink$size <- NULL
info$commonNetworkRelativeLink$netNameOffset <- NULL
info$commonNetworkRelativeLink$deviceNameOffset <- NULL
}
}
.stop_if_not(nbrOfBytesRead <= info$size)
# CommonPathSuffix (variable)
offset <- info$commonPathSuffixOffset
if (!is.null(offset) && (offset < info$size)) {
offset <- offset - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
nextOffset <- info$localBasePathUnicode
if (is.null(nextOffset)) {
nextOffset <- info$commonPathSuffixUnicode
if (is.null(nextOffset)) {
nextOffset <- info$size + 1L
}
}
.stop_if_not(!is.null(nextOffset))
n <- nextOffset - nbrOfBytesRead - 1L
value <- readRaw(con, n=n)
nbrOfBytesRead <- nbrOfBytesRead + n
info$commonPathSuffix <- rawToChar(value)
}
.stop_if_not(nbrOfBytesRead <= info$size)
# LocalBasePathUnicode (variable)
offset <- info$localBasePathOffsetUnicode
if (!is.null(offset) && (offset < info$size)) {
offset <- offset - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
nextOffset <- info$commonPathSuffixUnicode
if (is.null(nextOffset)) {
nextOffset <- info$size + 1L
}
.stop_if_not(!is.null(nextOffset))
n <- nextOffset - nbrOfBytesRead - 1L
value <- readRaw(con, n=n)
nbrOfBytesRead <- nbrOfBytesRead + n
info$localBasePathUnicode <- rawToChar(value)
}
.stop_if_not(nbrOfBytesRead <= info$size)
# CommonPathSuffixUnicode (variable)
offset <- info$commonPathOffsetUnicode
if (!is.null(offset) && (offset < info$size)) {
offset <- offset - nbrOfBytesRead
.stop_if_not(offset >= 0L)
if (offset > 0L) {
readRaw(con, n=offset)
nbrOfBytesRead <- nbrOfBytesRead + offset
}
nextOffset <- info$size + 1L
n <- nextOffset - nbrOfBytesRead - 1L
value <- readRaw(con, n=n)
nbrOfBytesRead <- nbrOfBytesRead + n
info$commonPathSuffixUnicode <- rawToChar(value)
}
.stop_if_not(nbrOfBytesRead <= info$size)
.stop_if_not(nbrOfBytesRead == info$size)
if (clean) {
info$size <- NULL
info$flags <- NULL
info$headerSize <- NULL
info$volumeIdOffset <- NULL
info$localBasePathOffset <- NULL
info$commonNetworkRelativeLinkOffset <- NULL
info$commonPathSuffixOffset <- NULL
}
info
} # readLinkInfo()
readStringData <- function(con, ...) {
data <- list(
countCharacters = readWord(con) # 2 bytes
)
value <- readRaw(con, n=2*data$countCharacters)
value <- matrix(value, nrow=2L)
value <- value[1L,]
value <- rawToChar(value)
data$string <- value
.stop_if_not(nchar(data$string) == data$countCharacters)
if (clean) {
data <- data$string
}
data
} # readStringData()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'con':
if (is.character(con)) {
con <- file(con, open="")
}
if (inherits(con, "connection")) {
if (!isOpen(con)) {
open(con, open="rb")
on.exit({
if (inherits(con, "connection") && isOpen(con))
close(con)
})
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# File header
# Shell item ID list
# Item 1
# Item 2
# etc..
# File locator info
# Local path
# Network path
# Description string
# Relative path string
# Working directory string
# Command line string
# Icon filename string
# Extra stuff
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
lnk <- list()
lnk$header <- readShellLinkHeader(con)
if (verbose) {
message("File header read:")
message(paste(capture.output(lnk$header), collapse="\n"))
}
if (lnk$header$linkFlags["HasLinkTargetIdList"]) {
lnk$idList <- readLinkTargetIdList(con)
}
if (lnk$header$linkFlags["HasLinkInfo"]) {
lnk$linkInfo <- readLinkInfo(con)
}
keys <- c("HasName", "HasRelativePath", "HasWorkingDir", "HasArguments", "HasIconLocation")
if (any(lnk$header$linkFlags[keys])) {
lnk$stringData <- list()
stringData <- list()
if (lnk$header$linkFlags["HasName"]) {
stringData$name <- readStringData(con)
}
if (lnk$header$linkFlags["HasRelativePath"]) {
stringData$relativePath <- readStringData(con)
}
if (lnk$header$linkFlags["HasWorkingDir"]) {
stringData$workingDir <- readStringData(con)
}
if (lnk$header$linkFlags["HasArguments"]) {
stringData$commandLineArguments <- readStringData(con)
}
if (lnk$header$linkFlags["HasIconLocation"]) {
stringData$iconLocation <- readStringData(con)
}
lnk$stringData <- stringData
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# For convenience
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
key <- "relativePath"
if (is.element(key, names(lnk$stringData))) {
value <- lnk$stringData[[key]]
if (!clean) {
value <- value$data
}
lnk$relativePathname <- value
}
key <- "localBasePath"
if (is.element(key, names(lnk$linkInfo))) {
path <- lnk$linkInfo[[key]]
lnk$pathname <- file.path(path, lnk$linkInfo$commonPathSuffix, fsep="")
}
key <- "commonNetworkRelativeLink"
if (is.element(key, names(lnk$linkInfo))) {
path <- lnk$linkInfo[[key]]$netName
lnk$networkPathname <- file.path(path, lnk$linkInfo$commonPathSuffix, fsep="\\")
}
lnk
}) # readWindowsShellLink()
R.utils/R/renameFile.R 0000644 0001762 0000144 00000006526 14372747611 014232 0 ustar ligges users ###########################################################################/**
# @RdocDefault renameFile
#
# @title "Renames a file (or a directory) atomically/safely"
#
# \description{
# @get "title",
# by also asserting that it was successfully renamed without side effects.
# If failing to rename and overwrite an existing file, the original file
# is kept.
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{The pathname of the file to be renamed.}
# \item{newPathname}{The new pathname.
# If an \emph{existing directory} and the source is a file, then the
# destination becomes \code{file.path(newPathname, basename(pathname))}.}
# \item{overwrite}{If @TRUE and there exists a file with new pathname,
# then it is overwritten.}
# \item{...}{Not used.}
# \item{verbose}{See @see "R.utils::Verbose".}
# }
#
# \value{
# Returns @TRUE if the file was successfully renamed.
# If it failed, an exception is thrown.
# }
#
# @author
#
# \seealso{
# \code{\link[base:files]{file.rename}()}.
# }
#
# @keyword internal
#*/###########################################################################
setMethodS3("renameFile", "default", function(pathname, newPathname, overwrite=FALSE, ..., verbose=FALSE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'pathname':
pathname <- Arguments$getCharacter(pathname, nchar=c(1,512))
pathname <- Arguments$getWritablePathname(pathname, mustExist=TRUE)
# Argument 'newPathname':
newPathname <- Arguments$getCharacter(newPathname, nchar=c(1,512))
# Special case: Source is a file and destination is an existing directory?
if (isFile(pathname) && isDirectory(newPathname)) {
newPathname <- file.path(newPathname, basename(pathname))
}
newPathname <- Arguments$getWritablePathname(newPathname,
mustNotExist=!overwrite)
if (newPathname == pathname) {
throw("Cannot rename file. Source and target are identical: ", pathname)
}
# Argument 'verbose':
verbose <- Arguments$getVerbose(verbose)
if (verbose) {
pushState(verbose)
on.exit(popState(verbose))
}
isDir <- isDirectory(pathname)
pType <- if (isDir) "directory" else "file"
pExists <- if (isDir) isDirectory else isFile
verbose && enterf(verbose, "Renaming %s safely", pType)
verbose && cat(verbose, "Pathname: ", pathname)
verbose && cat(verbose, "New pathname: ", newPathname)
if (overwrite && pExists(newPathname)) {
newPathnameB <- pushBackupFile(newPathname, verbose=verbose)
on.exit({
popBackupFile(newPathnameB, verbose=verbose)
})
}
verbose && enter(verbose, "Renaming file using file.rename()")
res <- file.rename(pathname, newPathname)
verbose && cat(verbose, "Result: ", res)
if (!res) {
throw(sprintf("Failed to rename %s: %s -> %s", pType, pathname, newPathname))
}
verbose && exit(verbose)
verbose && enter(verbose, "Validating")
if (!pExists(newPathname)) {
throw(sprintf("Failed to rename %s (target does not exist): %s -> %s", pType, pathname, newPathname))
}
if (pExists(pathname)) {
throw(sprintf("Failed to rename %s (source still exists): %s -> %s", pType, pathname, newPathname))
}
verbose && exit(verbose)
verbose && exit(verbose)
TRUE
}) # renameFile()
R.utils/R/countLines.R 0000644 0001762 0000144 00000004773 14372747611 014310 0 ustar ligges users ###########################################################################/**
# @RdocDefault countLines
#
# @title "Counts the number of lines in a text file"
#
# \description{
# @get "title" by counting the number of occurrences of platform-independent
# newlines (CR, LF, and CR+LF [1]), including a last line with neither.
# An empty file has zero lines.
# }
#
# @synopsis
#
# \arguments{
# \item{file}{A @connection or a pathname.}
# \item{chunkSize}{The number of bytes read in each chunk.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns an non-negative @integer.
# }
#
# \details{
# Both compressed and non-compressed files are supported.
# }
#
# @author
#
# @examples "../incl/countLines.Rex"
#
# \references{
# [1] Page \emph{Newline}, Wikipedia, July 2008.
# \url{https://en.wikipedia.org/wiki/Newline}
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("countLines", "default", function(file, chunkSize=50e6, ...) {
# Argument 'file':
if (inherits(file, "connection")) {
con <- file
} else {
file <- as.character(file)
con <- gzfile(file, open="rb")
on.exit(close(con))
}
LF <- as.raw(0x0a)
CR <- as.raw(0x0d)
SPC <- as.raw(32L)
isLastCR <- isLastLF <- FALSE
isEmpty <- TRUE
nbrOfLines <- 0L
while(TRUE) {
bfr <- readBin(con=con, what=raw(), n=chunkSize)
if (isLastCR) {
# Don't count LF following a CR in previous chunk.
if (bfr[1L] == LF)
bfr[1L] <- SPC
}
n <- length(bfr)
if (n == 0L)
break
isEmpty <- FALSE
# Replace all CRLF:s to become LF:s
idxsCR <- which(bfr == CR)
nCR <- length(idxsCR)
if (nCR > 0L) {
idxsCRLF <- idxsCR[(bfr[idxsCR + 1L] == LF)]
if (length(idxsCRLF) > 0L) {
bfr <- bfr[-idxsCRLF]
n <- length(bfr)
idxsCRLF <- NULL; # Not needed anymore
nCR <- length(which(bfr == CR))
}
}
# Count all CR:s and LF:s
nLF <- length(which(bfr == LF))
nbrOfLines <- nbrOfLines + (nCR + nLF)
if (n == 0L) {
isLastCR <- isLastLF <- FALSE
} else {
# If last symbol is CR it might be followed by a LF in
# the next chunk. If so, don't count that next LF.
bfrN <- bfr[n]
isLastCR <- (bfrN == CR)
isLastLF <- (bfrN == LF)
}
} # while()
# Count any last line without newline too
if (!isEmpty) {
if (!isLastLF) nbrOfLines <- nbrOfLines + 1L
attr(nbrOfLines, "lastLineHasNewline") <- isLastLF
}
nbrOfLines
})
R.utils/R/readBinFragments.R 0000644 0001762 0000144 00000013256 14372747611 015374 0 ustar ligges users ########################################################################/**
# @RdocDefault readBinFragments
#
# @title "Reads binary data from disjoint sections of a connection or a file"
#
# @synopsis
#
# \description{
# @get "title".
# }
#
# \arguments{
# \item{con}{A @connection or the pathname of an existing file.}
# \item{what}{A @character string or an object specifying the the
# data type (@see "base::mode") to be read.}
# \item{idxs}{A @vector of (non-duplicated) indices or a Nx2 @matrix
# of N from-to index intervals specifying the elements to be read.
# Positions are either relative to the start or the current location
# of the file/connection as given by argument \code{origin}.}
# \item{origin}{A @character string specify whether the indices
# in argument \code{idxs} are relative to the \code{"start"} or
# the \code{"current"} position of the file/connection.}
# \item{size}{The size of the data type to be read. If @NA, the natural
# size of the data type is used.}
# \item{...}{Additional arguments passed to @see "base::readBin".}
# \item{verbose}{A @logical or a @see "Verbose" object.}
# }
#
# \value{
# Returns a @vector of the requested @see "base::mode".
# }
#
# @examples "../incl/readBinFragments.Rex"
#
# @author
#
# \seealso{
# @see "writeBinFragments".
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("readBinFragments", "default", function(con, what, idxs=1, origin=c("current", "start"), size=NA, ..., verbose=FALSE) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'con':
if (is.character(con)) {
pathname <- con
pathname <- Arguments$getReadablePathname(pathname)
con <- file(pathname, open="rb")
on.exit({
if (!is.null(con)) {
close(con)
con <- NULL
}
})
} else if (inherits(con, "connection")) {
if (!isSeekable(con)) {
t <- summary(con)
t <- paste(sprintf("%s: %s", names(t), t), collapse=", ")
msg <- sprintf("Argument 'con' is not a seekable connection: %s", t)
action <- getOption("R.utils::onNonSeekable", "error")
if (action == "warning") {
warning(msg)
} else {
throw(msg)
}
}
}
# Argument 'what':
if (!is.character(what) || length(what) != 1 || !(what %in% c("numeric", "double", "integer", "int", "logical", "complex", "character", "raw"))) {
what <- typeof(what)
}
# Argument 'idxs':
if (is.matrix(idxs) || is.data.frame(idxs)) {
if (ncol(idxs) != 2) {
throw("When argument 'idxs' is a data frame, it must have exactly two columns: ", ncol(idxs))
}
idxs <- as.matrix(idxs)
}
if (!is.numeric(idxs)) {
throw("Argument 'idxs' must be numeric: ", class(idxs)[1])
}
if (any(idxs < 0)) {
throw("Argument 'idxs' contains negative indices: ", paste(head(idxs[idxs < 0]), collapse=", "))
}
# Argument 'origin':
origin <- match.arg(origin)
# Argument 'size':
if (length(size) != 1) {
throw("Argument 'size' must be a single value: ", length(size))
}
if (is.na(size)) {
# Calculating the natural size
size <- as.integer(object.size(vector(mode=what, length=1e4))/1e4)
} else if (!is.numeric(size)) {
throw("Argument 'size' must be numeric or NA: ", class(size)[1])
}
# Argument 'verbose':
verbose <- Arguments$getVerbose(verbose)
if (verbose) {
pushState(verbose)
on.exit(popState(verbose), add=TRUE)
}
# Intervals to index sequence?
if (is.matrix(idxs)) {
idxs <- intervalsToSeq(idxs)
}
idxs <- as.double(idxs)
# Allocate return vector
nAll <- length(idxs)
# Order the indices
o <- order(idxs)
idxs <- idxs[o]
# Read from the start of the connect?
if (origin == "start") {
seek(con=con, where=0, origin="start", rw="read")
}
## The below is not working (at least on Windows), because it may induce
## negative 'where':s in seek() which doesn't seem to work. /HB 2010-11-07
## # Starting positions (double in order to address larger vectors!)
## offset <- seek(con=con, origin="start", rw="read"); # Get current file offset
## if (offset > 0) {
## idxs <- idxs - offset
## }
# Allocate return vector
res <- vector(mode=what, length=nAll)
CHUNK.SIZE <- floor(1024e3/size)
destOffset <- srcOffset <- as.integer(0)
while(length(idxs) > 0) {
# Skip to first element to be read
if (idxs[1] != 0) {
skip <- idxs[1]-1
verbose && cat(verbose, "Number of elements skipped: ", skip)
seek(con=con, where=skip*size, origin="current", rw="read")
idxs <- idxs - skip
}
verbose && cat(verbose, "Remaining indices (relative to current position):")
verbose && str(verbose, idxs)
# Read data
bfr <- readBin(con=con, what=what, n=CHUNK.SIZE, size=size, ...)
n <- length(bfr)
if (n == 0)
break
# The file offset of the next element to be read
srcOffset <- n
verbose && cat(verbose, "Data read:")
verbose && str(verbose, bfr)
# Keep only the indices requested
keep <- match(idxs, 1:n)
keep <- keep[is.finite(keep)]
bfr <- bfr[keep]
# Not needed anymore
keep <- NULL
# Store the results
n <- length(bfr)
idx <- 1:n
res[destOffset+idx] <- bfr
destOffset <- destOffset + n
# Not needed anymore
bfr <- NULL
# Next chunk of elements
idxs <- idxs[-idx]
idxs <- idxs - srcOffset
# Not needed anymore
idx <- NULL
} # while (length(idxs) > 0)
if (!is.null(o)) {
# order(o) can be optimized, cf. affxparser::invertMap(). /HB 2007-08-22
res <- res[order(o)]
}
res
}) # readBinFragments()
R.utils/R/useRepos.R 0000644 0001762 0000144 00000021465 14372747611 013767 0 ustar ligges users ###########################################################################/**
# @RdocFunction useRepos
# @alias parseRepos
#
# @title "Sets package repositories"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{repos}{A @character @vector of repositories to use.
# If @NULL, nothing is replaced.}
# \item{where}{A @character string specifying how to add them to the
# current set of repositories.}
# \item{unique}{If @TRUE, only unique repositories are set.}
# \item{fallback}{If @TRUE, any remaining non-specified repository value
# of format '@...@' (e.g. '@CRAN@') than could not be recovered by
# other means, will be assigned to a pre-defined known value, if possible.
# If so, then an informative warning is given.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @list with element 'repos' reflecting \code{options("repos")}
# as the options where prior to calling this function.
# }
#
# @author
#
# \seealso{
# @see "withRepos".
# }
#
# @keyword IO
# @keyword programming
#*/###########################################################################
useRepos <- function(repos=NULL, where=c("before", "after", "replace"), unique=TRUE, fallback=TRUE, ...) {
# Nothing to do?
if (is.null(repos)) {
return(options("repos"))
}
# Reset to previous options?
# (Example: old <- useRepos(), later useRepos(old).)
if (is.list(repos)) {
old <- options(repos)
return(old)
}
repos <- parseRepos(sets=repos, where=where, fallback=fallback, ...)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Keep only unique ones?
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (unique) {
names <- names(repos)
if (length(names) > 0L) {
dups <- (nzchar(names) & duplicated(names))
repos <- repos[!dups]
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Repositories, except '@...@' ones, should all be specified as URLs,
# cf. help("install.packages").
reposT <- grep("^@[^@]+@$", repos, value=TRUE, invert=TRUE)
isUrl <- isUrl(reposT)
bad <- repos[!isUrl]
if (length(bad) > 0L) {
stop("Detected reposities that are not specified as URLs: ", bad)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Apply
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
old <- options(repos=repos)
invisible(old)
} # useRepos()
parseRepos <- function(sets=NULL, where=c("before", "after", "replace"), fallback=TRUE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
reposKnownToR <- function() {
p <- file.path(Sys.getenv("HOME"), ".R", "repositories")
if (!file.exists(p)) p <- file.path(R.home("etc"), "repositories")
## Find .read_repositories() in 'utils' or 'tools' [R (< 4.3.0)]
.read_repositories <- NULL
for (pkg in c("utils", "tools")) {
ns <- getNamespace(pkg)
if (exists(".read_repositories", envir = ns)) {
.read_repositories <- get(".read_repositories", envir = ns)
break
}
}
if (is.null(.read_repositories)) {
stop("[INTERNAL ERROR] Failed to locate base-R function .read_repositories()")
}
a <- .read_repositories(p)
repos <- a$URL
names <- rownames(a)
names(repos) <- names
repos
} # reposKnownToR()
reposCustom <- function() {
c("braju.com"="https://braju.com/R")
} # reposCustom()
reposFallback <- function() {
c("CRAN"="https://cran.r-project.org")
} # reposCustom()
reposAll <- function() {
c(reposKnownToR(), reposCustom())
} # reposAll()
superPattern <- function(name="all") {
known <- list(
CRAN = "^(CRAN.*)$",
BioC = "^(BioC.*)$",
all = "",
current = ""
)
known$`mainstream` <- c(known$CRAN, known$BioC)
known$`braju.com` <- c("^braju[.]com$", known$mainstream)
known$`R-Forge` <- c("^R-Forge$", known$mainstream)
known$`rforge.net` <- c("^rforge[.]net$", known$mainstream)
# Unknown?
if (!is.element(name, names(known)))
return(NULL)
known[[name]]
} # superPattern()
reposSubst <- function(repos, known=repos) {
pattern <- "^@[^@]+@$"
subs <- grep(pattern, repos)
if (length(subs) > 0L) {
# Borrow from repositories that does not require substitution
known <- grep(pattern, known, value=TRUE, invert=TRUE)
# Names of repositories that requires substitution
names <- names(repos)[subs]
# Look them up in among the known ones?
reposT <- known[names]
.stop_if_not(length(reposT) == length(subs))
# Which can use?
ok <- !is.na(reposT)
reposT <- reposT[ok]
# Patch
if (length(reposT) > 0L) {
idxs <- match(names(reposT), names)
subs <- subs[idxs]
repos[subs] <- reposT
}
}
repos
} # reposSubst()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'sets':
# Nothing to do?
if (is.null(sets)) return(getOption("repos"))
.stop_if_not(is.character(sets))
# Argument 'where':
where <- match.arg(where)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# How the order relative to the existing set of repositories?
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# All available/known repositories
repos00 <- c(getOption("repos"), reposAll())
if (where == "after") {
repos0 <- repos00
} else if (where == "before") {
repos0 <- c(reposAll(), getOption("repos"))
} else {
# Don't the use the existing ones
repos0 <- reposAll()
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Preprocess sets
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sets <- unlist(strsplit(sets, split=",", fixed=TRUE), use.names=FALSE)
names <- names(sets)
sets <- sapply(sets, FUN=trim)
names(sets) <- names
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Indentify new set of repositories
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Subset by name?
if (is.character(sets)) {
repos <- c()
patternS <- "^\\[(.*)\\]$"
for (kk in seq_along(sets)) {
# Subsetting here will keep the names attribute
set <- sets[kk]
# Subset by regular expression?
if (regexpr(patternS, set) != -1L) {
# Identify the repository pattern used for scanning
pattern <- gsub(patternS, "\\1", set)
# A super set?
if (regexpr(patternS, pattern) != -1L) {
name <- gsub(patternS, "\\1", pattern)
pattern <- superPattern(name)
if (length(pattern) == 0L) {
stop("Unknown repository super set: ", name)
}
}
# Current set or pattern?
if (identical(pattern, "")) {
repos <- getOption("repos")
} else {
# All known repositories with names matching the pattern(s)
keep <- lapply(pattern, FUN=grep, names(repos0))
keep <- unique(unlist(keep))
repos <- c(repos, repos0[keep])
}
} else if (isUrl(set)) {
repos <- c(repos, set)
} else {
repos <- c(repos, repos0[set])
}
} # for (set ...)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Try to substitute any @CRAN@ etc.
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# First among the selected set
repos <- reposSubst(repos)
# Then among the all known repositories
repos <- reposSubst(repos, known=repos00)
# And finally among the fallback repositories?
if (fallback) {
repos0 <- repos
repos <- reposSubst(repos, known=reposFallback())
if (!identical(repos, repos0)) {
# Report on what was done
idxs <- which(repos0 != repos)
diff <- sprintf("%s -> %s", sQuote(repos0[idxs]), sQuote(repos[idxs]))
keys <- names(repos[idxs])
if (!is.null(keys)) diff <- sprintf("%s: %s", keys, diff)
diff <- paste(diff, collapse=", ")
warning("Had to fall back to a set of predefined repositories (please make sure to set your package repositories properly, cf. ?setRepositories): ", diff)
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Drop (name,value) duplicates
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
keys <- paste(names(repos), repos, sep=":")
repos <- repos[!duplicated(keys)]
# Sanity check
.stop_if_not(is.character(repos))
# Return
repos
} # parseRepos()
R.utils/R/CmdArgsFunction.R 0000644 0001762 0000144 00000001722 14372747611 015202 0 ustar ligges users ##############################################################################
# This code has to come first in a library. To do this make sure this file
# is named "000.R" (zeros).
##############################################################################
setConstructorS3("CmdArgsFunction", function(fcn=function() {}, output=print, ...) {
# Argument 'fcn':
.stop_if_not(is.function(fcn))
# Argument 'output':
.stop_if_not(is.function(output))
attr(fcn, "output") <- output
extend(fcn, "CmdArgsFunction")
})
setMethodS3("print", "CmdArgsFunction", function(x, ..., call=!interactive(), envir=parent.frame()) {
# Nothing todo?
if (!call) return(NextMethod())
# Call function...
res <- withVisible(cmdArgsCall(x, ..., envir=envir))
# Should the result be printed?
if (res$visible) {
output <- attr(x, "output")
if (is.null(output)) output <- print
output(res$value)
}
# Return nothing
invisible(return())
}, protected=TRUE)
R.utils/R/env.R 0000644 0001762 0000144 00000002312 14372747611 012740 0 ustar ligges users ###########################################################################/**
# @RdocFunction env
#
# @title "Creates a new environment, evaluates an expression therein, and returns the environment"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @see "base::evalq", particularly a
# @expression to be evaluated inside the newly created @environment.}
# \item{hash, parent, size}{Arguments passed to @see "base::new.env".}
# }
#
# \value{
# Returns an @environment.
# }
#
# @examples "../incl/env.Rex"
#
# @author
#
# \seealso{
# Internally @see "base::new.env" and @see "base::evalq" are used.
# }
#
# \references{
# [1] R-devel thread 'Create an environment and assign objects to it in
# one go?' on March 9-10, 2011.\cr
# }
#
# @keyword device
# @keyword utilities
#*/###########################################################################
# NOTE: This must not be an S3 method, because we must *not* dispatch
# on '...'; if done, then any expression therein is evaluated.
env <- function(..., hash=FALSE, parent=parent.frame(), size=29L) {
envir <- new.env(hash=hash, parent=parent, size=size)
evalq(..., envir=envir)
envir
} # env()
R.utils/R/listDirectory.R 0000644 0001762 0000144 00000006157 14372747611 015023 0 ustar ligges users ###########################################################################/**
# @RdocDefault listDirectory
#
# @title "Gets the file names in the directory"
#
# \description{
# @get "title".
#
# Contrary to \code{list.files()}, this method guarantees to work
# recursively. Moreover, when subdirectories are processed recursively,
# directory names are also returned.
# }
#
# @synopsis
#
# \arguments{
# \item{path}{A path to be listed.}
# \item{pattern}{A @character string of the filename pattern passed. See
# @see "base::list.files" for more details.}
# \item{recursive}{If @TRUE, subdirectories are recursively processed,
# and not if @FALSE. Alternatively, the maximum recursive depth can
# be specified as a non-negative @numeric, where @FALSE corresponds to
# \code{0L} depth and @TRUE corresponds \code{+Inf} depth.}
# \item{allNames}{If @TRUE, also files starting with a period are returned.}
# \item{fullNames}{If @TRUE, the full path names are returned.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @vector of file names.
# }
#
#
# \section{Recursive searching}{
# Recursive searching of directory structure is done breath-first
# in a lexicographic order.
# }
#
# @author
#
# \seealso{
# Internally @see "base::list.files" is used.
# }
#
# @keyword IO
# @keyword programming
#*/###########################################################################
setMethodS3("listDirectory", "default", function(path=".", pattern=NULL, recursive=FALSE, allNames=FALSE, fullNames=FALSE, ...) {
# Argument 'path':
path <- as.character(path)
if (path == "")
path <- "."; # As in Java.
# Argument 'recursive':
depth <- Arguments$getNumeric(recursive, range=c(0,+Inf))
if (is.logical(recursive) && recursive) depth <- +Inf; ## TRUE => +Inf
# Nothing to do?
if (!isDirectory(path))
return(NULL)
path <- getAbsolutePath(path)
# relPath <- getRelativePath(path)
relPath <- path
# Get the directories (and files) in the current directory
dirs <- list.files(relPath, all.files=allNames, full.names=FALSE)
dirs <- setdiff(dirs, c(".", ".."))
if (length(dirs) == 0L)
return(NULL)
if (fullNames) {
dirs <- file.path(path, dirs)
}
# Get the files in the current directory
if (is.null(pattern)) {
files <- dirs
} else {
files <- list.files(relPath, pattern=pattern, all.files=allNames,
full.names=fullNames, ...)
}
if (depth > 0) {
for (dir in dirs) {
if (fullNames) {
pathT <- dir
} else {
pathT <- filePath(relPath, dir)
}
if (isDirectory(pathT)) {
# Protect against inifinite loops/depth
if (identical(pathT, path) && is.infinite(depth)) {
throw("Internal error: Detected infinite recursive call in listDirectory(): ", path)
}
subfiles <- listDirectory(pathT, pattern=pattern, recursive=depth-1,
allNames=allNames, fullNames=fullNames, ...)
if (!fullNames) {
subfiles <- file.path(dir, subfiles)
}
files <- c(files, subfiles)
}
} # for (dir ...)
}
files
})
R.utils/R/intToHex.R 0000644 0001762 0000144 00000005721 14372747611 013721 0 ustar ligges users ########################################################################/**
# @RdocFunction format.binmode
# @alias as.character.binmode
#
# @title "Converts a binary/octal/hexadecimal number into a string"
#
# \description{
# @get "title".
# }
#
# \usage{
# @usage format,binmode
# }
#
# \arguments{
# \item{x}{Object to be converted.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character.
# }
#
# @author
#
# \seealso{
# \code{format.octmode()}, cf. @see "base::octmode".
# @see "intToBin" (incl. \code{intToOct()} and \code{intToHex()}).
# }
#
# @keyword manip
# @keyword character
# @keyword programming
#*/########################################################################
setMethodS3("format", "binmode", function(x, ...) {
isna <- is.na(x)
y <- x[!isna]
ans0 <- character(length = length(y))
## Handle negative values specially; emulates octmode and hexmode
neg <- which(y < 0)
if (length(neg) > 0) {
y[neg] <- y[neg] + 1L + .Machine$integer.max
}
z <- NULL
while (any(y > 0) || is.null(z)) {
z <- y %% 2
y <- floor(y / 2)
ans0 <- paste(z, ans0, sep = "")
}
ans <- rep(NA_character_, times = length(x))
ans[!isna] <- ans0
ans
})
setMethodS3("as.character", "binmode", function(x, ...) format(x, ...))
########################################################################/**
# @RdocFunction intToBin
# @alias intToOct
# @alias intToHex
#
# @title "Converts an integer to a binary/octal/hexadecimal number"
#
# \description{
# @get "title".
# }
#
# \usage{
# intToBin(x)
# intToOct(x)
# intToHex(x)
# }
#
# \arguments{
# \item{x}{A @numeric vector of integers to be converted.}
# }
#
# \value{
# Returns a @character string of length \code{length(x)}.
# For coercions out of range, \code{NA_character_} is returned for
# such elements.
# }
#
# \details{
# For \code{length(x)} > 1, the number of characters in each of returned
# elements is the same and driven by the \code{x} element that requires
# the highest number of character - all other elements are padded with
# zeros (or ones for negative values). This is why we for instance get
# \code{intToHex(15) == "f"} but \code{intToHex(15:16) == c("0f", "10")}.
#
# The supported range for \code{intToHex()}, \code{intToOct()}, and
# \code{intToBin()} is that of \R integers, i.e.
# \code{[-.Machine$integer.max, +.Machine$integer.max]} where.
# \code{.Machine$integer.max} is \eqn{2^31-1}.
# This limitation is there such that negative values can be converted too.
# }
#
# @author
#
# @keyword manip
# @keyword character
# @keyword programming
#*/########################################################################
intToBin <- function(x) {
y <- as.integer(x)
class(y) <- "binmode"
y <- as.character(y)
dim(y) <- dim(x)
y
}
intToHex <- function(x) {
y <- as.integer(x)
class(y) <- "hexmode"
y <- format(y)
dim(y) <- dim(x)
y
}
intToOct <- function(x) {
y <- as.integer(x)
class(y) <- "octmode"
y <- format(y)
dim(y) <- dim(x)
y
}
R.utils/R/fileAccess.R 0000644 0001762 0000144 00000017250 14570447742 014222 0 ustar ligges users ###########################################################################/**
# @RdocDefault fileAccess
#
# @title "Checks the permission of a file or a directory"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{A @character string of the file or the directory
# to be checked.}
# \item{mode}{An @integer (0,1,2,4), cf. @see "base::file.access".}
# \item{safe}{If @TRUE, the permissions are tested more carefully,
# otherwise @see "base::file.access" is used.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns an @integer; 0 if the permission exists, -1 if not.
# }
#
# \details{
# In \R there is @see "base::file.access" for checking whether the
# permission of a file.
# Unfortunately, that function cannot be 100\% trusted depending on
# platform used and file system queried, cf. [1].
# }
#
# \section{Symbolic links}{
# This function follows symbolic links (also on Windows) and returns a
# value based on the link target (rather than the link itself).
# }
#
# @examples "../incl/fileAccess.Rex"
#
# \seealso{
# @see "base::file.access"
# }
#
# \references{
# [1] R-devel thread
# \emph{file.access() on network (mounted) drive on Windows Vista?}
# on Nov 26, 2008.
# \url{https://stat.ethz.ch/pipermail/r-devel/2008-December/051461.html}\cr
# [2] Filesystem permissions, Wikipedia, 2010.
# \url{https://en.wikipedia.org/wiki/Filesystem_permissions}\cr
# }
#
# @author
#
# @keyword IO
# @keyword programming
#*/###########################################################################
setMethodS3("fileAccess", "default", function(pathname, mode=0, safe=TRUE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'pathname':
pathname <- Arguments$getCharacter(pathname)
# Argument 'mode':
if (!is.element(mode, c(0, 1, 2, 4))) {
throw("Value of argument 'mode' is unknown: ", mode)
}
# Follow symbol file links
pathname0 <- pathname
pathnameT <- Sys.readlink2(pathname, what="corrected")
if (!is.na(pathnameT) && nchar(pathnameT, type="chars") > 0L) {
pathname <- pathnameT
}
# base::file.access()
fa <- file.access(pathname, mode=mode)
names(fa) <- NULL
if (!safe)
return(fa)
# If file doesn't exists, then we have none of the permission either.
fe <- file.exists(pathname)
if (!fe)
return(-1L)
# This is a workaround to make sure any connection opened inside a
# tryCatch() statement is closed again.
con <- NULL
on.exit({
if (!is.null(con))
close(con)
})
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# mode = 0: Test for existence of file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (mode == 0) {
faSafe <- -as.integer(!fe)
if (fa != faSafe) {
warning("file.access(..., mode=0) and file.exists() gives different results (", fa, " != ", faSafe, "). Will use the file.exists() results: ", pathname0)
}
return(faSafe)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# mode = 1: Test for executable permission of file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (mode == 1) {
faSafe <- fa
if (isDirectory(pathname)) {
# No particular test exists for this case, rely on file.access().
} else if (isFile(pathname)) {
fi <- file.info(pathname)
# Specific test, if on Windows
if (!is.null(fi$exe)) {
isExecutable <- (fi$exe != "no")
faSafe <- -as.integer(!isExecutable)
if (fa != faSafe) {
warning("file.access(..., mode=1) and file.info()$exe gives different results (", fa, " != ", faSafe, "). Will use the file.info() results: ", pathname0)
}
}
}
return(faSafe)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# mode = 2: Test for write permission of file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (mode == 2) {
# In case a symbolic link was followed
pathname <- pathname0
if (isDirectory(pathname)) {
# "The write permission, [...] for a directory, this permission
# grants the ability to modify entries in the directory. This
# includes creating files, deleting files, and renaming files." [2]
# (a) Generate a random filename that does not already exist
path <- pathname
pathname <- NULL
## Produce random filename *without* changing the global RNG state
withSeed({
for (n in 1:16) {
for (k in 1:50) {
chars <- sample(c(base::letters, base::LETTERS), size=n)
filename <- paste(chars, collapse="")
pathname <- file.path(path, filename)
if (!file.exists(pathname)) break
pathname <- NULL
}
if (!is.null(pathname)) break
} # for (n ...)
}, seed = NULL)
if (is.null(pathname)) {
stop("Failed to produce a non-existing random filename in folder ",
sQuote(path))
}
# (b) Try to open the random filename for writing
faSafe <- -1L
tryCatch({
suppressWarnings({
con <- file(pathname, open="ab")
})
# If we get here, we have permission
faSafe <- 0L
}, error = function(ex) {
# If we end up here, we do not have permissions
})
# Close connection and remove temporary file
if (!is.null(con) && file.exists(pathname)) {
close(con)
con <- NULL
file.remove(pathname)
}
if (fa != faSafe) {
warning("file.access(..., mode=2) and file(..., open=\"ab\") gives different results (", fa, " != ", faSafe, "). Will use the file() results: ", pathname)
}
return(faSafe)
} # if (isDirectory(pathname))
# This is actually redundant, because of the above file.exists() test,
# but we keep it here to make it explicit what we are doing.
if (!isFile(pathname)) {
# If the file does not exist, we have no permissions.
return(fa)
}
faSafe <- -1L
tryCatch({
# (a) Try to open the file for writing
suppressWarnings({
con <- file(pathname, open="ab")
})
# If we get here, we have permission
faSafe <- 0L
}, error = function(ex) {
# If we end up here, we do not have permissions
})
if (fa != faSafe) {
warning("file.access(..., mode=2) and file(..., open=\"ab\") gives different results (", fa, " != ", faSafe, "). Will use the file() results: ", pathname)
}
return(faSafe)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# mode = 4: Test for read permission of file
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (mode == 4) {
# In case a symbolic link was followed
pathname <- pathname0
faSafe <- -1L
tryCatch({
if (isFile(pathname)) {
# (a) Try to open the file for reading
con <- file(pathname, open="rb")
# (b) Try even to read one byte
bfr <- readBin(con, what=raw(), n=1L)
} else {
# (a) Try to list directory [Will this take a lot of time?!?]
dummy <- list.files(path=pathname)
}
# If we get here, we have permission
faSafe <- 0L
}, error = function(ex) {
# If we end up here, we do not have permissions
})
if (fa != faSafe) {
warning("file.access(..., mode=4) and file(..., open=\"rb\")+readBin() gives different results (", fa, " != ", faSafe, "). Will use the file()+readBin() results: ", pathname)
}
return(faSafe)
}
return(-1L)
})
R.utils/R/VComments.R 0000644 0001762 0000144 00000017626 14526006463 014073 0 ustar ligges users ###########################################################################/**
# @RdocClass VComments
#
# @title "The VComments class"
#
# \description{
# @classhierarchy
#
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{letter}{The smart letter.}
# \item{verboseName}{The name of the verbose object.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \details{
# The 'v' in VComments stands for 'verbose', because of its relationship
# to the @see "Verbose" class.
#
# Here is a list of VComments and the \R code that replaces each of them
# by the compiler:
#
# \bold{Constructors}\cr
# \describe{
# \item{#V0#}{[] - NullVerbose()}
# \item{#V1#}{[] - Verbose()}
# }
#
# \bold{Controls}\cr
# \describe{
# \item{#V=#}{[] - Sets the name of the object.
# Default is 'verbose'.}
# \item{#V^#}{ - setThreshold(, )}
# \item{#V?#}{ - if (isVisible()) \{ \}}
# \item{#V@#}{ - setDefaultLevel(, )}
# \item{#Vm#}{ - (, )}
# }
#
# \bold{Enters and exits}\cr
# \describe{
# \item{#V+#}{[] - enter(, )}
# \item{#V-#}{[] - exit(, )}
# \item{#V!#}{[] - pushState()\cr
# on.exit(popState())\cr
# If , enter(, )}
# }
#
# \bold{Simple output}\cr
# \describe{
# \item{#Vn#}{ - newline()}
# \item{#Vr#}{ - ruler()}
# \item{#Vt#}{ - timestamp()}
# \item{#Vw#}{[] - warnings(, )}
# }
#
# \bold{Output messages}\cr
# \describe{
# \item{#Vc#}{[] - cat(, )}
# \item{#Ve#}{ - eval(, )}
# \item{#Vh#}{ - header(, )}
# \item{#Vp#}{