Nothing
.Rscript <- function (options = NULL, trailing = character(), dry.run = FALSE,
show.command = TRUE, intern = TRUE, show.output.on.console = show.command,
...)
{
command <- path.join(
R.home("bin"),
if (.OS_windows) "Rscript.exe" else "Rscript"
)
args <- c(command, options)
args <- c(shQuote(args), trailing)
command <- paste(args, collapse = " ")
if (dry.run)
return(command)
if (show.command)
cat(command, "\n", sep = "")
value <- suppressWarnings(system(command = command, intern = intern, ...))
if (show.output.on.console)
writeLines(value)
invisible(value)
}
.build.this <- function (chdir = FALSE, file = here(), which = "tar")
{
## .build.this package:this.path R Documentation
##
## Building Packages
##
##
##
## Description:
##
## This provides a more general method of making packages, not specifically
## R packages, for distribution and version control.
##
##
##
## Usage:
##
## .build.this(chdir = FALSE, file = here(), which = "tar")
##
##
##
## Arguments:
##
## chdir
##
## TRUE or FALSE; change directory to directory of package source
## before building tar/zip archives? This will not affect the build
## process, only the location in which the archive is made.
##
## file
##
## name of a directory which is to be packaged
##
## which
##
## which type of archive do you want to make, "tar" or "zip"?
## Can be both i.e. 'which = c("tar", "zip")'
##
##
##
## Details:
##
## .build.this builds package archives similar to 'R CMD build', and takes
## the name of the package and its version from the 'DESCRIPTION' file.
## If you are unfamiliar with the 'DESCRIPTION' file, here is a outline:
##
## Package: example
## Version: 0.1.0
## Date: %Y-%m-%d
## License: What license is it under?
## Title: What the Package Does (Title Case)
## Description: More about what it does (maybe more than one line)
## Use four spaces when indenting paragraphs within the Description.
## Author: Who wrote it
## Maintainer: The package maintainer <yourself@somewhere.net>
##
## The package name should start with a letter, end with a letter or
## number, and contain any combination of letters, numbers, underscores,
## periods, and hyphens in the middle.
##
## The package version should be two or more numbers separated by hyphens
## and/or periods like '12.34.56-78'.
## determine which types of archive we want to make
choices <- c("tar", "zip")
nms <- c("tarball", "zip archive")
which <- unique(match.arg(which, choices, several.ok = TRUE))
nms <- nms[match(which, choices)]
## check that 'file' is valid, and 'chdir' if required
if (!.IS_SCALAR_STR(file)) {
stop(gettextf("'%s' must be a character string", "file", domain = "R"), domain = NA)
} else if (grepl("^(ftp|ftps|http|https)://", file)) {
stop("cannot '.build.this' on a URL")
} else if (chdir && (path <- file) != ".") {
file <- "."
owd <- getwd()
if (is.null(owd))
stop("cannot 'chdir' as current directory is unknown")
on.exit(setwd(owd))
setwd(path)
}
# op <- options(error = quote({
# quit(save = "no", status = 1, runLast = FALSE)
# }))
# on.exit(options(op), add = TRUE)
## look for the appropriate applications to create archives
## if all are unavailable, throw an error
## if some are unavailable, throw a warning and continue with the rest
val <- Sys.which(which)
i <- is.na(val) | val == ""
if (any(i)) {
msgs <- paste0(which, " unavailable; cannot create ", nms)
if (all(i)) {
stop(paste(msgs, collapse = "\n "))
} else warning(paste(msgs[i], collapse = "\n"))
which <- which[!i]
nms <- nms[!i]
}
## check for file "DESCRIPTION"
DESCRIPTION <- path.join(file, "DESCRIPTION")
cat("* checking for file '", DESCRIPTION, "' ... ", sep = "")
if (!file.exists(DESCRIPTION)) {
cat("NO\n\n")
stop("cannot create ", paste(nms, collapse = ", "),
" without file '", DESCRIPTION, "'")
}
cat("OK\n")
packageInfo <- read.dcf(DESCRIPTION,
fields = c("Package", "Version"))
pkgname <- packageInfo[[1L, "Package"]]
version <- packageInfo[[1L, "Version"]]
## check that the package name and version exist in "DESCRIPTION"
problems <- c(
if (is.na(pkgname))
"invalid 'Package' field\n\n",
if (is.na(version))
"invalid 'Version' field\n\n"
)
if (!is.null(problems)) {
cat(" ERROR\n", problems, sep = "")
stop("invalid package DESCRIPTION file")
}
## check that the package name and version are valid names and versions
cat("* checking DESCRIPTION meta-information ... ", sep = "")
valid_package_name <- "([[:alpha:]][[:alnum:]_.-]*[[:alnum:]])"
valid_package_version <- "(([[:digit:]]+[.-]){1,}[[:digit:]]+)"
problems <- c(
if (!grepl(paste0("^", valid_package_name , "$"), pkgname))
"Malformed package name\n\n",
if (!grepl(paste0("^", valid_package_version, "$"), version))
"Malformed package version.\n\n"
)
if (!is.null(problems)) {
cat("ERROR\n", problems, sep = "")
stop("invalid package DESCRIPTION file")
}
cat("OK\n")
## files to exclude, and all files
exclude <- NULL
files <- list.files(path = file, all.files = TRUE, recursive = TRUE, include.dirs = TRUE)
## directories to always exclude
i <- basename2(files) %in% c(
## directories from source control systems
"CSV", ".svn", ".arch-ids", ".bzr", ".git", ".hg",
## directories from eclipse
".metadata",
"check", "chm"
)
## more directories to exclude, ending with Old or old
i <- i | grepl("(Old|old)$", files)
## and, of course, are directories
i <- i & dir.exists(path.join(file, files))
if (any(i)) {
exclude <- c(exclude, files[i])
files <- files[!i]
}
## files to always exclude
i <- grepl(
pattern = paste0(
"(",
c(
"^GNUmakefile$",
"^Read-and-delete-me$",
## starts with .#
"^\\.#",
## starts and ends with #
"^#.*#$",
## ends with ~ or .bak or .swp
"~$", "\\.bak$", "\\.swp$"
),
")", collapse = "|"
),
basename2(files)
)
if (any(i)) {
exclude <- c(exclude, files[i])
files <- files[!i]
}
## do not put previous archives in the new archives
prev_build_patterns <- paste0(
"^",
gsub(".", "\\.", pkgname, fixed = TRUE),
"_",
valid_package_version,
c("\\.tar\\.gz", "\\.tgz", "\\.zip"),
"$"
)
for (exclude_pattern in prev_build_patterns) {
if (any(i <- grepl(exclude_pattern, files))) {
exclude <- c(exclude, files[i])
files <- files[!i]
}
}
## look for a ".buildignore" file containing
## a list of Perl patterns (case insensitive)
## specifying files to ignore when archiving
ignore_file <- path.join(file, ".buildignore")
if (file.exists(ignore_file)) {
for (exclude_pattern in readLines(ignore_file, warn = FALSE, encoding = "UTF-8")) {
if (any(i <- grepl(exclude_pattern, files, ignore.case = TRUE, perl = TRUE))) {
exclude <- c(exclude, files[i])
files <- files[!i]
}
}
}
## for directories in 'exclude', also
## exclude the files within said directories
exclude_dirs <- exclude[dir.exists(path.join(file, exclude))]
for (exclude_prefix in paste0(exclude_dirs, "/", recycle0 = TRUE)) {
if (any(i <- startsWith(files, exclude_prefix))) {
exclude <- c(exclude, files[i])
files <- files[!i]
}
}
## create a new directory to hold the temporary files and archives
dir.create(my_tmpdir <- tempfile("dir"))
on.exit(unlink(my_tmpdir, recursive = TRUE, force = TRUE, expand = FALSE), add = TRUE)
## create another directory to hold the temporary files
dir.create(pkgdir <- path.join(my_tmpdir, pkgname))
## within said directory, make the appropriate sub-directories
isdir <- dir.exists(path.join(file, files))
dirs <- files[isdir]
for (path in path.join(pkgdir, dirs))
dir.create(path, showWarnings = TRUE, recursive = TRUE)
## fill the directory and sub-directories with their files,
## while maintaining file modify time
if (any(i <- !file.copy(
path.join(file , files[!isdir]),
path.join(pkgdir, files[!isdir]),
copy.date = TRUE
)))
stop(ngettext(sum(i), "unable to copy file: ",
"unable to copy files:\n "),
paste(encodeString(files[!isdir][i], quote = "\""), collapse = "\n "))
## set the modify time of the sub-directories to their original values
Sys.setFileTime(
path.join(pkgdir, dirs),
file.mtime(path.join(file , dirs))
)
for (apk in which) {
switch(apk, tar = {
build_name <- paste0(pkgname, "_", version, ".tar.gz")
build_path <- path.join(my_tmpdir, build_name)
args <- c("tar", "-czf", shQuote(build_path), "-C", shQuote(my_tmpdir), shQuote(pkgname))
command <- paste(args, collapse = " ")
cat("* building '", build_name, "'\n", sep = "")
res <- system(command, ignore.stdout = TRUE)
if (res == -1L) {
stop("'", command, "' could not be run")
} else if (res) {
stop("'", command, "' execution failed with error code ", res)
} else if (i <- !file.copy(
build_path,
path.join(file, build_name),
overwrite = TRUE
)) {
stop("unable to move:\n ",
encodeString(build_path, quote = "\""),
"\nto:\n ",
encodeString(path.join(file, build_name), quote = "\""))
}
}, zip = {
build_name <- paste0(pkgname, "_", version, ".zip")
build_path <- path.join(my_tmpdir, build_name)
args <- c("zip", "-r", shQuote(build_path), shQuote(pkgname))
command <- paste(args, collapse = " ")
cat("* building '", build_name, "'\n", sep = "")
res <- .with_chdir(my_tmpdir, {
system(command, ignore.stdout = TRUE)
})
if (res == -1L) {
stop("'", command, "' could not be run")
} else if (res) {
stop("'", command, "' execution failed with error code ", res)
} else if (i <- !file.copy(
build_path,
path.join(file, build_name),
overwrite = TRUE
)) {
stop("unable to move:\n ",
encodeString(build_path, quote = "\""),
"\nto:\n ",
encodeString(path.join(file, build_name), quote = "\""))
}
}, stop("invalid 'which'; should not happen, please report!"))
}
}
.with_chdir <- function (wd, expr)
{
owd <- getwd()
if (is.null(owd))
stop("cannot 'chdir' as current directory is unknown", domain = "R-base")
on.exit(setwd(owd))
setwd(wd)
expr
}
.R_BraceSymbol <- as.symbol("{")
.maybeQuote <- function (expr, evaluated, simplify.brace = TRUE)
{
## possibly quote an expression
##
## when 'evaluated' is missing, 'expr' is quoted only if it is an
## (unevaluated) call to `{`
##
## when 'evaluated' is FALSE, 'expr' is always quoted
##
## when 'evaluated' is TRUE, 'expr' is evaluated as normal
##
## this is intended to be called inside another function, like match.fun()
if (missing(expr))
expr
if (missing(evaluated)) {
if (is.call(e <- eval(as.call(list(substitute, substitute(expr))), parent.frame())) &&
identical(e[[1L]], .R_BraceSymbol))
{
expr <- e
}
}
else if (!evaluated)
expr <- eval(as.call(list(substitute, substitute(expr))), parent.frame())
## force the evaluated of 'expr'
else expr
if (is.call(expr)) {
## always turn a call into an expression so that it
## cannot be misinterpreted later
if (simplify.brace) {
if (identical(expr[[1L]], .R_BraceSymbol))
as.expression(as.list(expr[-1L]))
else as.expression(list(expr))
}
else as.expression(list(expr))
}
else expr
}
.code2character <- function (x, width.cutoff = 60L,
deparseCtrl = c("keepInteger", "showAttributes", "useSource", "keepNA", "digits17"))
{
## if 'x' is an (unevaluated) call to `{`
## deparse each sub-expression
##
## if 'x' is an expression() vector
## make a list of deparsed expressions
##
## if 'x' is a language object
## deparse the expression
##
## if 'x' is a character vector
## leave as is
fun <- function(xx) {
deparse1(xx, collapse = "\n", width.cutoff = width.cutoff,
backtick = TRUE, control = deparseCtrl)
}
if (is.expression(x)) {
if ("useSource" %in% deparseCtrl) {
getLines <- function(srcref) {
srcfile <- attr(srcref, "srcfile", exact = TRUE)
getSrcLines(srcfile, srcref[7L], srcref[8L])
}
trimLines <- function(lines, srcref) {
if (length(lines)) {
enc <- Encoding(lines)
Encoding(lines) <- "bytes"
if (length(lines) > srcref[8L] - srcref[7L])
lines[length(lines)] <- substring(lines[length(lines)], 1L, srcref[4L])
lines[1L] <- substring(lines[1L], srcref[2L])
Encoding(lines) <- enc
}
lines
}
# x <- parse(text = " 5 +\n 6\t; 7 +8 ; ", keep.source = TRUE)
srcref <- attr(x, "wholeSrcref", exact = TRUE)
if (!is.null(srcref))
tryCatch2({
lines <- getLines(srcref)
}, error = function(e) {
}, else. = {
lines <- trimLines(lines, srcref)
return(paste(lines, collapse = "\n"))
})
srcrefs <- attr(x, "srcref", exact = TRUE)
if (!is.null(srcrefs)) {
y <- character(length(srcrefs))
for (i in seq_along(y)) {
srcref <- srcrefs[[i]]
y[[i]] <- if (!is.null(srcref))
tryCatch2({
lines <- getLines(srcref)
}, error = function(e) {
fun(x[[i]])
}, else. = {
lines <- trimLines(lines, srcref)
paste(lines, collapse = "\n")
})
else fun(x[[i]])
}
y
}
else vapply(x, fun, "")
}
else vapply(x, fun, "")
}
else if (is.language(x))
fun(x)
else if (is.character(x))
x
else stop("invalid 'x', expected a language object or character vector")
}
.writeCode <- function (x, file = stdout(), evaluated, simplify.brace = TRUE,
width.cutoff = 60L, deparseCtrl = c("keepInteger", "showAttributes", "useSource", "keepNA", "digits17"))
{
x <- .maybeQuote(x, evaluated, simplify.brace)
x <- .code2character(x, width.cutoff, deparseCtrl)
if (is.null(file))
x
else {
writeLines(x, file, useBytes = !.utf8locale)
invisible(x)
}
}
if (getRversion() < "3.2.0") {
tmp <- formals(.code2character)[["deparseCtrl"]]
formals(.code2character)[["deparseCtrl"]] <- tmp[!vapply(tmp, identical, "digits17", FUN.VALUE = NA)]
tmp <- formals(.writeCode)[["deparseCtrl"]]
formals(.writeCode)[["deparseCtrl"]] <- tmp[!vapply(tmp, identical, "digits17", FUN.VALUE = NA)]
rm(tmp)
}
.readFiles <- function (files)
vapply(files, function(file) paste0(readLines(file), "\n", collapse = ""), "")
.envvars <- function (...)
{
args <- list(...)
if (length(args) == 0L)
as.list(Sys.getenv())
else {
visible <- FALSE
if (length(args) == 1L &&
typeof(args[[1L]]) %in% c("NULL", "pairlist", "language",
"...", "list", "expression") &&
is.null(names(args)))
{
args <- args[[1L]]
if (typeof(args) == "...") {
# ... <- args
assign("...", args)
args <- list(...)
}
else if (!is.vector(args) || is.object(args))
args <- as.list(args)
}
if (!length(args))
value <- structure(list(), names = character())
else if (is.null(tags <- names(args)) ||
all(i <- !nzchar(tags)))
{
visible <- TRUE
tags <- vapply(args, .AS_SCALAR_STR, "", USE.NAMES = FALSE)
value <- as.list(Sys.getenv(tags, unset = NA, names = TRUE))
}
else {
args <- lapply(args, .AS_SCALAR_STR)
if (any(i)) {
visible <- TRUE
tags[i] <- names(args)[i] <- as.character(args[i])
# args[i] <- list(NULL)
}
tags[is.na(tags)] <- "NA"
if (.Platform$OS.type == "windows")
tags <- tolower(tags)
i <- !i
base_case <- function(args, i) {
# print(args)
# cat("\n\n\n\n\n")
value <- as.list(Sys.getenv(names(args), unset = NA, names = TRUE))
args <- args[i]
na <- is.na(args)
if (any(na)) {
Sys.unsetenv(names(args)[na])
args <- args[!na]
}
if (length(args))
do.call("Sys.setenv", args)
value
}
recurse <- function(args, tags, i) {
if (first_setter <- match(TRUE, i, 0L)) {
n <- length(args)
if (dup <- anyDuplicated(tags[first_setter:n])) {
dup <- dup - 1L + first_setter
indxs <- seq_len(dup - 1L)
value <- base_case(args[indxs], i[indxs])
indxs <- dup:n
c(value, recurse(args[indxs], tags[indxs], i[indxs]))
}
else base_case(args, i)
}
else as.list(Sys.getenv(names(args), unset = NA, names = TRUE))
}
value <- recurse(args, tags, i)
}
if (visible)
value
else invisible(value)
}
}
.istrue <- function (x)
.External2(.C_istrue, x)
.isfalse <- function (x)
.External2(.C_isfalse, x)
.asLogical <- function (x)
.External2(.C_asLogical, x)
.asInteger <- function (x)
.External2(.C_asInteger, x)
.asIntegerGE0 <- function (x)
.External2(.C_asIntegerGE0, x)
.IS_SCALAR_STR <- function (x)
.External2(.C_IS_SCALAR_STR, x)
.AS_SCALAR_STR <- function (x)
{
switch (typeof(x),
logical = ,
integer = ,
double = ,
complex = ,
character = ,
raw = {
if (is.object(x))
x <- unclass(x)
if (length(x))
as.character(x[[1L]])
else NA_character_
},
char = as.character(list(x)),
symbol = as.character(x),
NA_character_)
}
.AS_SCALAR_STR <- function (x)
.External2(.C_AS_SCALAR_STR, x)
.scalar_streql <- function (e1, e2)
.External2(.C_scalar_streql, e1, e2)
.identical <- if (getRversion() >= "4.2.0") {
function (x, y)
identical(x, y, num.eq = FALSE, single.NA = FALSE, attrib.as.set = FALSE,
ignore.bytecode = FALSE, ignore.environment = FALSE, ignore.srcref = FALSE,
extptr.as.ref = TRUE)
} else if (getRversion() >= "3.4.0") {
function (x, y)
identical(x, y, num.eq = FALSE, single.NA = FALSE, attrib.as.set = FALSE,
ignore.bytecode = FALSE, ignore.environment = FALSE, ignore.srcref = FALSE)
} else if (getRversion() >= "3.0.0") {
function (x, y)
identical(x, y, num.eq = FALSE, single.NA = FALSE, attrib.as.set = FALSE,
ignore.bytecode = FALSE, ignore.environment = FALSE)
} else if (getRversion() >= "2.14.0") {
function (x, y)
identical(x, y, num.eq = FALSE, single.NA = FALSE, attrib.as.set = FALSE,
ignore.bytecode = FALSE)
} else if (getRversion() >= "2.10.0") {
function (x, y)
identical(x, y, num.eq = FALSE, single.NA = FALSE, attrib.as.set = FALSE)
} else {
function (x, y)
identical(x, y)
}
.source <- function (file, local = FALSE, echo = verbose, print.eval = echo,
exprs, spaced = use_file, verbose = getOption("verbose"),
prompt.echo = getOption("prompt"), max.deparse.length = 150,
width.cutoff = 60L, deparseCtrl = "showAttributes", chdir = FALSE,
encoding = getOption("encoding"), continue.echo = getOption("continue"),
skip.echo = 0, keep.source = getOption("keep.source"))
{
file <- set.sys.path(file)
envir <- if (isTRUE(local))
parent.frame()
else if (isFALSE(local))
.GlobalEnv
else if (is.environment(local))
local
else stop("'local' must be TRUE, FALSE or an environment")
if (!missing(echo)) {
if (!is.logical(echo))
stop("'echo' must be logical")
if (!echo && verbose) {
warning("'verbose' is TRUE, 'echo' not; ... coercing 'echo <- TRUE'")
echo <- TRUE
}
}
if (verbose) {
cat("'envir' chosen:")
print(envir)
}
if (use_file <- missing(exprs)) {
ofile <- file
from_file <- FALSE
srcfile <- NULL
if (is.character(file)) {
if (!length(file) || file == "")
stop("empty file/url name")
have_encoding <- !missing(encoding) && !identical(encoding, "unknown")
if (identical(encoding, "unknown")) {
enc <- utils::localeToCharset()
encoding <- enc[length(enc)]
}
else enc <- encoding
if (length(enc) > 1L) {
encoding <- NA
owarn <- options(warn = 2)
for (e in enc) {
if (is.na(e))
next
zz <- file(file, encoding = e)
res <- tryCatch(readLines(zz, warn = FALSE),
error = identity)
close(zz)
if (!inherits(res, "error")) {
encoding <- e
break
}
}
options(owarn)
}
if (is.na(encoding))
stop("unable to find a plausible encoding")
if (verbose)
cat(gettextf("encoding = \"%s\" chosen", encoding),
"\n", sep = "")
{
filename <- file
file <- file(filename, "r", encoding = encoding)
on.exit(close(file))
if (isTRUE(keep.source)) {
lines <- readLines(file, warn = FALSE)
on.exit()
close(file)
srcfile <- srcfilecopy(filename, lines, file.mtime(filename)[1],
isFile = .is_abs_path(filename))
}
else {
from_file <- TRUE
srcfile <- filename
}
loc <- utils::localeToCharset()[1L]
encoding <- if (have_encoding)
switch(loc, `UTF-8` = "UTF-8", `ISO8859-1` = "latin1",
"unknown")
else "unknown"
}
}
else {
lines <- readLines(file, warn = FALSE)
srcfile <- if (isTRUE(keep.source))
srcfilecopy(deparse1(substitute(file), ""), lines)
else deparse1(substitute(file), "")
}
if (verbose) {
cat(sprintf(" --> from_file='%s'\n lines:", from_file))
utils::str(lines)
}
exprs <- if (!from_file) {
if (length(lines) && is.character(lines))
parse(file = stdin(), n = -1, text = lines, keep.source = FALSE, srcfile = srcfile, encoding = encoding)
else expression()
}
else parse(file = file, n = -1, keep.source = FALSE, srcfile = srcfile, encoding = encoding)
on.exit()
if (from_file)
close(file)
if (verbose)
cat("--> parsed", length(exprs), "expressions; now eval(.)ing them:\n")
if (chdir) {
if (is.character(ofile)) {
if (grepl("^(ftp|ftps|http|https|file)://", ofile))
warning("'chdir = TRUE' makes no sense for a URL")
else if ((path <- dirname(ofile)) != ".") {
owd <- getwd()
if (is.null(owd))
stop("cannot 'chdir' as current directory is unknown")
on.exit(setwd(owd), add = TRUE)
setwd(path)
}
}
else {
warning("'chdir = TRUE' makes no sense for a connection")
}
}
}
else {
if (!missing(file))
stop("specify either 'file' or 'exprs' but not both")
if (!is.expression(exprs))
exprs <- as.expression(exprs)
}
Ne <- length(exprs)
if (echo) {
sd <- "\""
nos <- "[^\"]*"
oddsd <- paste0("^", nos, sd, "(", nos, sd, nos, sd,
")*", nos, "$")
trySrcLines <- function(srcfile, showfrom, showto) {
tryCatch(suppressWarnings(getSrcLines(srcfile, showfrom,
showto)), error = function(e) character())
}
}
yy <- NULL
lastshown <- 0
srcrefs <- attr(exprs, "srcref", exact = TRUE)
if (verbose && !is.null(srcrefs)) {
cat("has srcrefs:\n")
utils::str(srcrefs)
}
for (i in seq_len(Ne + echo)) {
tail <- i > Ne
if (!tail) {
if (verbose)
cat("\n>>>> eval(expression_nr.", i, ")\n\t\t =================\n")
ei <- exprs[i]
}
if (echo) {
nd <- 0
srcref <- if (tail)
attr(exprs, "wholeSrcref", exact = TRUE)
else if (i <= length(srcrefs))
srcrefs[[i]]
if (!is.null(srcref)) {
if (i == 1)
lastshown <- min(skip.echo, srcref[8L] - 1)
if (lastshown < srcref[8L]) {
srcfile <- attr(srcref, "srcfile", exact = TRUE)
dep <- trySrcLines(srcfile, lastshown + 1,
srcref[8L])
if (length(dep)) {
leading <- if (tail)
length(dep)
else srcref[7L] - lastshown
lastshown <- srcref[8L]
while (length(dep) && grepl("^[[:blank:]]*$",
dep[1L])) {
dep <- dep[-1L]
leading <- leading - 1L
}
dep <- paste0(rep.int(c(prompt.echo, continue.echo),
pmax(0L, c(leading, length(dep) - leading))),
dep, collapse = "\n")
nd <- nchar(dep, "c")
}
else srcref <- NULL
}
}
if (is.null(srcref)) {
if (!tail) {
dep <- substr(paste(deparse(ei, width.cutoff = width.cutoff,
control = deparseCtrl), collapse = "\n"),
12L, 1000000L)
dep <- paste0(prompt.echo, gsub("\n", paste0("\n",
continue.echo), dep, fixed = TRUE))
nd <- nchar(dep, "c") - 1L
}
}
if (nd) {
do.trunc <- nd > max.deparse.length
dep <- substr(dep, 1L, if (do.trunc)
max.deparse.length
else nd)
cat(if (spaced)
"\n", dep, if (do.trunc)
paste(if (grepl(sd, dep) && grepl(oddsd, dep))
" ...\" ..."
else " ....", "[TRUNCATED] "), "\n", sep = "")
}
}
if (!tail) {
yy <- withVisible(eval(ei, envir))
i.symbol <- mode(ei[[1L]]) == "name"
if (!i.symbol) {
curr.fun <- ei[[1L]][[1L]]
if (verbose) {
cat("curr.fun:")
utils::str(curr.fun)
}
}
if (verbose >= 2) {
cat(".... mode(ei[[1L]])=", mode(ei[[1L]]), "; paste(curr.fun)=")
utils::str(paste(curr.fun))
}
if (print.eval && yy$visible)
.PrintValueEnv(yy$value, envir)
if (verbose)
cat(" .. after ", sQuote(deparse(ei, control = unique(c(deparseCtrl,
"useSource")))), "\n", sep = "")
}
}
invisible(yy)
}
source.exprs <- function (exprs, evaluated = FALSE, envir = parent.frame(), echo = TRUE, print.eval = TRUE)
{
if (!evaluated) {
exprs <- substitute(exprs)
if (is.call(exprs)) {
if (identical(exprs[[1]], .R_BraceSymbol))
exprs <- as.list(exprs)[-1]
}
}
if (!is.expression(exprs))
exprs <- as.expression(exprs)
Ne <- length(exprs)
if (echo)
trySrcLines <- function(srcfile, from, to) {
tryCatch(suppressWarnings(getSrcLines(srcfile, from, to)),
error = function(e) character())
}
yy <- NULL
lastshown <- 0L
srcrefs <- attr(exprs, "srcref")
for (i in seq_len(Ne + echo)) {
tail <- i > Ne
if (!tail)
ei <- exprs[i]
if (echo) {
srcref <- if (tail)
attr(exprs, "wholeSrcref")
else if (i <= length(srcrefs))
srcrefs[[i]]
if (!is.null(srcref)) {
firstl <- srcref[7L]
lastl <- srcref[8L]
if (i == 1L)
lastshown <- firstl - 1L
if (lastshown < lastl) {
srcfile <- attr(srcref, "srcfile")
dep <- trySrcLines(srcfile, lastshown + 1L, lastl)
if (length(dep)) {
leading <- if (tail)
length(dep)
else firstl - lastshown
lastshown <- lastl
dep <- paste0(rep.int(c(getOption("prompt"), getOption("continue")),
pmax(0L, c( leading , length(dep) - leading))),
dep, collapse = "\n")
cat(dep, "\n", sep = "")
}
}
}
}
if (!tail) {
yy <- withVisible(eval(ei, envir))
if (print.eval && yy$visible)
.PrintValueEnv(yy$value, envir)
}
}
invisible(yy)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.