Nothing
#!/usr/local/bin/Rscript --vanilla
################################################################################
#
# docu.R -- Rscript script to non-interactively create documentation for an R
# package with Roxygen2, to improve this documentation, to update the
# DESCRIPTION file, to check the package and to install the package. Can also
# check some aspects of the R coding style and conduct some preprocessing of
# the code files. Part of the pkgutils package. See the manual for details.
#
# Package directory names can be provided at the command line. If none are
# given, the working directory is checked for subdirectories that contain a
# DESCRIPTION file, and it is then attempted to document those, if any.
#
# (C) 2012-2014 by Markus Goeker (markus [DOT] goeker [AT] dsmz [DOT] de)
#
# This program is distributed under the terms of the Gnu Public License V2.
# For further information, see http://www.gnu.org/licenses/gpl.html
#
################################################################################
local(for (pkg in c("utils", "methods", "pkgutils", "roxygen2"))
library(package = pkg, quietly = TRUE, warn.conflicts = FALSE,
character.only = TRUE))
################################################################################
copy_dir <- function(from, to, delete) {
LL(from, to, delete)
files <- list.files(path = from, recursive = TRUE, full.names = TRUE)
files <- c(files, list.files(pattern = "\\.Rbuildignore", full.names = TRUE,
all.files = TRUE, recursive = TRUE))
if (nzchar(delete))
files <- files[!grepl(delete, files, TRUE, TRUE)]
dirs <- sub(from, to, unique.default(dirname(files)), FALSE, FALSE, TRUE)
unlink(to, TRUE)
vapply(dirs[order(nchar(dirs))], dir.create, NA, TRUE, TRUE)
file.copy(files, sub(from, to, files, FALSE, FALSE, TRUE))
}
vignette_subdirs <- function() {
c(subdirs <- c("vignettes", "doc"), file.path("inst", subdirs))
}
do_style_check <- function(dirs, opt) {
check_style <- function(dirs, subdirs, ...) check_R_code(x = dirs,
what = subdirs, lwd = opt$width, ops = !opt$opsoff, comma = !opt$commaoff,
indention = opt$blank, roxygen.space = opt$jspaces, modify = opt$modify,
parens = !opt$parensoff, assign = !opt$assignoff, accept.tabs = opt$tabs,
three.dots = !opt$dotsok, encoding = opt$encoding, ...)
subdirs <- c("tests", "scripts")
subdirs <- c("R", "demo", subdirs, file.path("inst", subdirs))
y <- check_style(dirs, subdirs, ignore = opt$good, filter = "none")
y <- c(y, check_style(dirs, subdirs, ignore = opt$good, filter = "roxygen"))
y <- c(y, check_style(dirs, vignette_subdirs(), filter = "sweave",
ignore = I(list(pattern = "\\.[RS]?nw$", ignore.case = TRUE))))
isna <- is.na(y)
if (any(y & !isna))
message(paste(sprintf("file '%s' has been modified", names(y)[y & !isna]),
collapse = "\n"))
if (any(isna))
message(paste(sprintf("checking file '%s' resulted in an error",
names(y)[isna]), collapse = "\n"))
length(which(isna))
}
do_compact <- function(dirs, opt) {
pdf.files <- pkg_files(dirs, vignette_subdirs(), FALSE,
I(list(ignore.case = TRUE, pattern = "\\.pdf$")))
message("GS command is ", Sys.getenv("R_GSCMD", "<empty>"))
print(tools::compactPDF(pdf.files, gs_quality = opt$quality))
0
}
check_S4_methods <- function(pkg) {
methods_sealed <- function(f, pkg, where = sprintf("package:%s", pkg), ...) {
fm <- function(f, ...) tryCatch(expr = findMethodSignatures(f = f, ...),
condition = function(cond) NULL) # skip non-generic functions, if any
ism <- function(f, s, pkg, where) {
if (nrow(s) > 1L && sum(bad <- apply(s == "ANY", 1L, all)) == 1L)
s <- s[!bad, , drop = FALSE] # remove stuff generated by setGeneric()
for (i in seq_along(sealed <- logical(nrow(s))))
sealed[[i]] <- isSealedMethod(f, s[i, ], , where)
data.frame(Function = f, Signature = apply(s, 1L, paste0,
collapse = "/"), Package = pkg, Sealed = sealed)
}
x <- structure(lapply(X = f, FUN = fm, where = where, ...), names = f)
x <- x[lengths(x, FALSE) > 0L]
if (!length(x))
return(NULL)
do.call(rbind, mapply(FUN = ism, f = names(x), USE.NAMES = FALSE,
s = x, MoreArgs = list(pkg = pkg, where = where), SIMPLIFY = FALSE))
}
test_ambiguity <- function(name) tryCatch(expr = testInheritedMethods(name),
error = function(e) NULL) # otherwise errors from non-S4 methods
print_nonsealed <- function(x) {
if (length(x))
for (i in seq_len(nrow(x))[!x[, "Sealed"]])
cat(sprintf("Found 1 %s method with signature %s that is not sealed\n",
x[i, "Function"], x[i, "Signature"]))
}
pkg2 <- sprintf("package:%s", pkg)
if (!pkg2 %in% search()) {
library(pkg, character.only = TRUE)
on.exit(detach(pkg2, unload = TRUE, character.only = TRUE))
}
n <- getNamespaceExports(pkg)
n <- n[!grepl("^\\.__", n, FALSE, TRUE)]
ambig <- lapply(n, test_ambiguity)
ambig <- ambig[!vapply(ambig, is.null, NA)]
ms <- methods_sealed(n, pkg, pkg2)
cat(sprintf("--- PACKAGE %s ---\n", pkg))
if (length(ambig)) {
lapply(ambig, print)
print_nonsealed(ms)
}
cat("\n")
attr(ambig, "method.sealed") <- ms
invisible(ambig)
}
run_sweave <- function(files, opt) {
sum(vapply(files, function(file) {
tryCatch(expr = {
Sweave(file = file, encoding = opt$encoding)
0L
}, error = function(e) {
warning(e)
1L
})
}, 0L))
}
do_split <- function(x, sep = ",") {
x <- unlist(strsplit(x, sep, fixed = TRUE))
x[nzchar(x)]
}
remove_comments_and_reduce_empty_lines <- function(x) {
x <- grep("^#", x, FALSE, TRUE, TRUE, FALSE, FALSE, TRUE)
ne <- nzchar(x)
x[ne | c(FALSE, ne[-length(ne)])]
}
################################################################################
#
# Spellcheck functions
#
textfile2rds <- function(file, ...) {
if (!nzchar(file) || grepl("\\.rds$", file, TRUE, TRUE))
return(file)
x <- readLines(con = file, ...)
saveRDS(x[nzchar(x)], file <- tempfile(fileext = ".rds"))
file
}
show_spellcheck_result <- function(x) {
if (!nrow(x))
return(invisible(NULL))
x[, "File"] <- basename(x[, "File"])
x <- x[order(x[, "Original"]), c("Original", "File", "Line", "Column")]
names(x) <- sprintf(".%s.", names(x))
write.table(x = x, sep = "\t", quote = FALSE, row.names = FALSE)
invisible(x)
}
news_filter <- function(ifile, encoding) {
x <- readLines(con = ifile, encoding = encoding, warn = FALSE)
x <- gsub("(([A-Za-z]+:::?)?[A-Za-z.][\\w.]*|`[^`]+`)\\([^)]*\\)",
"FUNCTION", x, FALSE, TRUE)
x <- gsub("'[^']+'", "ARGUMENT", x, FALSE, TRUE)
x <- gsub("[*][^*]+[*]", "SURNAME", x, FALSE, TRUE)
x <- gsub("\\b[A-Z]{3,}(_[A-Z]+)*\\b", "ABBREVIATION", x, FALSE, TRUE)
x <- gsub("\\b(\\d+th|3rd|2nd|1st)\\b", "NUMBERING", x, FALSE, TRUE)
x
}
demo_filter <- function(ifile, encoding) {
x <- readLines(con = ifile, encoding = encoding, warn = FALSE)
x[!grepl("^\\s*#", x, FALSE, TRUE)] <- ""
x <- gsub("`[^`]+`", "CODE", x, FALSE, TRUE)
x <- gsub("\\*{2}(?!\\s)[^*]+\\*{2}", "STRONG", x, FALSE, TRUE)
x <- gsub("\\*(?!\\s)[^*]+\\*", "EMPHASIS", x, FALSE, TRUE)
x
}
################################################################################
option.parser <- optparse::OptionParser(option_list = list(
optparse::make_option(c("-a", "--ancient"), action = "store_true",
default = FALSE,
help = "Do not update the DESCRIPTION file [default: %default]"),
optparse::make_option(c("-A", "--assignoff"), action = "store_true",
default = FALSE,
help = "Ignore assignments when checking R style [default: %default]"),
optparse::make_option(c("-b", "--blanks"), type = "integer", default = 2L,
help = "Number of spaces per indention unit in R code [default: %default]",
metavar = "NUMBER"),
optparse::make_option(c("-B", "--buildopts"), type = "character",
default = "", metavar = "LIST",
help = "'R CMD build' options, comma-separated list [default: %default]"),
optparse::make_option(c("-c", "--check"), action = "store_true",
default = FALSE,
help = "Run 'R CMD check' after documenting [default: %default]"),
optparse::make_option(c("-C", "--commaoff"), action = "store_true",
default = FALSE,
help = "Ignore comma treatment when checking R style [default: %default]"),
optparse::make_option(c("-d", "--delete"), type = "character", default = "",
help = "Subdirectories to delete, colon-separated list [default: %default]",
metavar = "LIST"),
optparse::make_option(c("-D", "--dotsok"), action = "store_true",
default = FALSE,
help = "Ignore ::: when checking R style [default: %default]"),
optparse::make_option(c("-e", "--exec"), type = "character", default = "ruby",
help = "Ruby executable used if -p or -s is chosen [default: %default]",
metavar = "FILE"),
optparse::make_option(c("-E", "--encoding"), type = "character", default = "",
help = "Character encoding assumed in input files [default: %default]",
metavar = "ENC"),
optparse::make_option(c("-f", "--format"), type = "character",
default = "%Y-%m-%d", metavar = "STR",
help = "Format of the date in the DESCRIPTION file [default: %default]"),
optparse::make_option(c("-F", "--folder"), action = "store_true",
default = FALSE, help = paste("When using -y, check and install not the",
"archive but the folder [default: %default]")),
# A bug in Rscript causes '-g' to generate strange warning messages.
# See https://stat.ethz.ch/pipermail/r-devel/2008-January/047944.html
#
# g
optparse::make_option(c("-G", "--good"), type = "character", default = "",
help = paste("R code files to not check, comma-separated list",
"[default: %default]"), metavar = "LIST"),
# h is reserved for help!
optparse::make_option(c("-H", "--inheritance"), action = "store_true",
default = FALSE,
help = "Check ambiguity of S4 method selection [default: %default]"),
optparse::make_option(c("-i", "--install"), action = "store_true",
default = FALSE,
help = "Also run 'R CMD INSTALL' after documenting [default: %default]"),
optparse::make_option(c("-I", "--installopts"), type = "character",
default = "", metavar = "LIST",
help = "'R CMD INSTALL' options, comma-separated list [default: %default]"),
optparse::make_option(c("-j", "--jspaces"), type = "integer", default = 1L,
help = paste("Number of spaces starting Roxygen-style comments",
"[default: %default]"), metavar = "NUMBER"),
optparse::make_option(c("-J", "--junk"), type = "character", default = "",
help = "Pattern of files to not copy with directory [default: %default]",
metavar = "PATTERN"),
optparse::make_option(c("-k", "--keep"), action = "store_true",
default = FALSE,
help = "Keep the version number in DESCRIPTION files [default: %default]"),
# K
optparse::make_option(c("-l", "--logfile"), type = "character",
default = "docu_%s.log", metavar = "FILE",
help = "Logfile to use for problem messages [default: %default]"),
optparse::make_option(c("-L", "--lines-reduce"), action = "store_true",
default = FALSE,
help = "Reduce number of lines in R code [default: %default]"),
optparse::make_option(c("-m", "--modify"), action = "store_true",
default = FALSE, help = paste("Potentially modify R sources when",
"style checking [default: %default]")),
optparse::make_option(c("-M", "--mark-duplicates"), action = "store_true",
help = "Mark duplicate words in Rd text [default: %default]",
default = FALSE),
optparse::make_option(c("-n", "--nosudo"), action = "store_true",
default = FALSE,
help = "In conjunction with -i, do not use sudo [default: %default]"),
optparse::make_option(c("-N", "--no-internal"), action = "store_true",
default = FALSE,
help = "Remove Rd files with 'internal' as keyword [default: %default]"),
optparse::make_option(c("-o", "--options"), type = "character",
default = "timings", metavar = "LIST",
help = "'R CMD check' options, comma-separated list [default: %default]"),
optparse::make_option(c("-O", "--opsoff"), action = "store_true",
default = FALSE,
help = "Ignore operators when checking R style [default: %default]"),
optparse::make_option(c("-p", "--preprocess"), action = "store_true",
default = FALSE,
help = "Preprocess R files using code swapping [default: %default]"),
optparse::make_option(c("-P", "--parensoff"), action = "store_true",
default = FALSE,
help = "Ignore parentheses when checking R style [default: %default]"),
optparse::make_option(c("-q", "--quick"), action = "store_true",
default = FALSE,
help = "Do not remove duplicate 'seealso' links [default: %default]"),
optparse::make_option(c("-Q", "--quality"), type = "character", default = "",
help = "PDF quality for running in compression mode [default: %default]",
metavar = "STR"),
optparse::make_option(c("-r", "--remove"), action = "store_true",
default = FALSE,
help = "First remove output directories if distinct [default: %default]"),
optparse::make_option(c("-R", "--Rcheck"), action = "store_true",
default = FALSE,
help = "Check only format of R code, ignore packages [default: %default]"),
optparse::make_option(c("-s", "--S4methods"), action = "store_true",
default = FALSE,
help = "Repair S4 method descriptions [default: %default]"),
optparse::make_option(c("-S", "--Sweave"), action = "store_true",
default = FALSE,
help = "Run Sweave on input files, ignore packages [default: %default]"),
optparse::make_option(c("-t", "--target"), type = "character",
default = file.path(Sys.getenv("HOME"), "bin"), metavar = "DIR",
help = paste("For -i, script file target directory; ignored if",
"empty [default: %default]")),
optparse::make_option(c("-T", "--tabs"), action = "store_true",
default = FALSE,
help = "Accept tabs when checking R style [default: %default]"),
optparse::make_option(c("-u", "--unsafe"), action = "store_true",
default = FALSE,
help = "In conjunction with -i, omit checking [default: %default]"),
optparse::make_option(c("-U", "--untidy"), action = "store_true",
default = FALSE,
help = "Omit R style checking altogether [default: %default]"),
optparse::make_option(c("-v", "--verbatim"), action = "store_true",
default = FALSE, help = paste("No special processing of package names",
"ending in '*_in' [default: %default]")),
# V
optparse::make_option(c("-w", "--width"), type = "integer", default = 80L,
help = "Maximum allowed line width in R code [default: %default]",
metavar = "NUMBER"),
optparse::make_option(c("-W", "--whitelist"), type = "character",
default = "", metavar = "LIST",
help = paste("Spell check with this white list [default: %default]")),
optparse::make_option(c("-x", "--exclude"), type = "character", default = "",
help = paste("Files to ignore when using -t, comma-separated list",
"[default: %default]"), metavar = "LIST"),
# X
optparse::make_option(c("-y", "--yes"), action = "store_true",
default = FALSE, help = "Yes, also build the package [default: %default]"),
# Y
optparse::make_option(c("-z", "--zapoff"), action = "store_true",
default = FALSE,
help = "Do not zap object files in 'src', if any [default: %default]")
# Z
), usage = "%prog [options] [directories/files]")
opt <- optparse::parse_args(option.parser, positional_arguments = TRUE)
package.dirs <- opt$args
opt <- opt$options
if (opt$help || (opt$Rcheck && !length(package.dirs))) {
optparse::print_help(option.parser)
quit(status = 1L)
}
opt$options <- do_split(opt$options)
opt$installopts <- do_split(opt$installopts)
opt$buildopts <- do_split(opt$buildopts)
opt$delete <- do_split(opt$delete, ":")
opt$good <- basename(do_split(opt$good))
opt$exclude <- do_split(opt$exclude)
opt$whitelist <- textfile2rds(opt$whitelist)
################################################################################
if (opt$inheritance) {
package.dirs <- basename(package.dirs)
if (!opt$verbatim)
package.dirs <- sub("_in$", "", package.dirs, FALSE, TRUE)
invisible(lapply(package.dirs, check_S4_methods))
quit(status = 0L)
}
################################################################################
if (opt$Sweave) { # Sweave running mode
quit(status = run_sweave(package.dirs, opt))
}
################################################################################
if (opt$Rcheck) { # R style check only
quit(status = do_style_check(package.dirs, opt))
}
################################################################################
if (length(package.dirs)) {
if (length(bad <- package.dirs[!is_pkg_dir(package.dirs)]))
stop("not a package directory: ", bad[1L])
package.dirs <- dirname(sprintf("%s/.", package.dirs))
} else {
package.dirs <- list.files()
package.dirs <- package.dirs[is_pkg_dir(package.dirs)]
if (!length(package.dirs)) {
warning("no package directories provided, and none found in ", getwd(),
"\nuse command-line switches '--help' or '-h' for help")
quit(status = 1L)
}
}
if (opt$verbatim) {
out.dirs <- package.dirs
} else {
out.dirs <- sub("_in$", "", package.dirs, FALSE, TRUE)
ok <- package.dirs != out.dirs
ok[!ok][!package.dirs[!ok] %in% out.dirs[ok]] <- TRUE
package.dirs <- package.dirs[ok]
out.dirs <- out.dirs[ok]
rm(ok)
if (opt$remove) {
message("Removing distinct output directories (if any)...")
unlink(out.dirs[out.dirs != package.dirs], recursive = TRUE)
}
}
msgs <- sprintf(" package directory '%s'...", out.dirs)
msgs.1 <- sprintf(" input directory '%s'...", package.dirs)
logfiles <- if (nzchar(opt$logfile)) {
file.path(dirname(out.dirs), sprintf(opt$logfile, basename(out.dirs)))
} else {
rep("", length(out.dirs))
}
errs <- 0L
################################################################################
if (nzchar(opt$target) && !file_test("-d", opt$target)) {
warning(sprintf("'%s' is not a directory", opt$target))
opt$target <- ""
errs <- errs + 1L
}
for (i in seq_along(package.dirs)) {
out.dir <- out.dirs[i]
in.dir <- package.dirs[i]
msg <- msgs[i]
if (!opt$ancient) {
# This must be applied to the input directory if it is distinct from the
# output directory.
message("Updating DESCRIPTION of", msgs.1[i])
tmp <- pack_desc(in.dir, "update", version = !opt$keep,
date.format = opt$format)
message(paste(formatDL(tmp[1L, ], style = "list"), collapse = "\n"))
}
if (!identical(out.dir, in.dir)) {
# Copying the files is preferred to calling roxygenize() with two
# directory arguments because due to a Roxygen2 bug this would result in
# duplicated documentation for certain S4 methods.
message(sprintf("Copying '%s' to '%s'...", in.dir, out.dir))
copy_dir(in.dir, out.dir, opt$junk)
if (length(opt$delete)) {
message("Deleting specified subdirectories (if present) of", msg)
unlink(file.path(out.dir, opt$delete), recursive = TRUE)
}
}
message(sprintf("Logfile is now '%s'", logfile(logfiles[i])))
if (!opt$untidy) {
message("Checking R code of", msg)
errs <- errs + do_style_check(out.dir, opt)
message("Checking Sweave code-chunk headers of", msg)
check_Sweave_start(out.dir)
}
message("Creating documentation for", msg)
if (out.dir == "pkgutils") {
message(sprintf("(temporarily unloading '%s' package)", out.dir))
detach(name = sprintf("package:%s", out.dir), unload = TRUE,
character.only = TRUE) # necessary to allow sealed S4 methods
roxygenize(out.dir)
library(package = out.dir, character.only = TRUE)
} else {
roxygenize(out.dir)
}
message("Repairing documentation for", msg)
skip <- repair_docu(out.dir, remove.dups = !opt$quick,
drop.internal = opt$`no-internal`, text.dups = opt$`mark-duplicates`)
if (is.logical(skip) && any(skip))
skip <- paste0("--skip=", paste0(names(skip)[skip], collapse = ","))
else
skip <- ""
if (opt$S4methods) {
message("Repairing S4 method documentation for", msg)
errs <- errs + repair_S4_docu(out.dir, ruby = opt$exec, sargs = skip)
}
if (suppressWarnings(file.remove(file.path(out.dir, "inst"))))
message("Deleting empty 'inst' subdirectory of", msg)
if (opt$preprocess) {
message("Preprocessing R code of", msg)
errs <- errs + swap_code(out.dir, ruby = opt$exec)
}
if (opt$`lines-reduce` && !identical(in.dir, out.dir)) {
message("Removing comments and reducing empty lines of", msg)
map_files(list.files(file.path(out.dir, "R"), full.names = TRUE),
remove_comments_and_reduce_empty_lines)
}
if (!opt$zapoff) {
message("Deleting object files (if any) of", msg)
errs <- errs + !all(delete_o_files(out.dir))
}
if (nzchar(opt$quality)) {
message("Compacting PDF files (if any) of", msg)
do_compact(out.dir, opt)
}
pkg.file <- out.dir
if (opt$yes) {
message("Building", msg)
build.err <- run_R_CMD(out.dir, "build", opt$buildopts)
errs <- errs + build.err
if (!opt$folder) {
pkg.file <- sprintf("%s_%s.tar.gz", basename(out.dir),
pack_desc(out.dir)[[1L]]$Version)
msg <- sprintf(" archive file '%s'...", pkg.file)
}
}
if (opt$check || ((opt$install || opt$yes) && !opt$unsafe)) {
message("Checking", msg)
errs <- errs + (check.err <- run_R_CMD(pkg.file, "check", opt$options))
}
if (nzchar(opt$whitelist)) {
message("Checking spelling in Rd files of", msg)
show_spellcheck_result(aspell_package_Rd_files(out.dir,
control = "-d en_GB", dictionaries = opt$whitelist,
drop = c("\\author", "\\references", "\\seealso", "\\code",
"\\acronym", "\\pkg", "\\kbd", "\\command", "\\file")))
message("Checking spelling in DESCRIPTION file of", msg)
show_spellcheck_result(pack_desc(out.dir, "spell",
dictionaries = opt$whitelist, control = "-d en_GB"))
message("Checking spelling in NEWS/ChangeLog files (if any) of", msg)
ff <- file.path(out.dir, c("NEWS", "ChangeLog"))
for (f in ff[file.exists(ff)])
show_spellcheck_result(aspell(f, dictionaries = opt$whitelist,
control = "-d en_GB", filter = news_filter))
message("Checking spelling in demo R files (if any) of", msg)
ff <- list.files(file.path(out.dir, "demo"), full.names = TRUE)
for (f in grep("\\.R$", ff, TRUE, TRUE, TRUE))
show_spellcheck_result(aspell(f, dictionaries = opt$whitelist,
control = "-d en_GB", filter = demo_filter))
}
if (opt$install && (opt$unsafe || !check.err)) {
message("Installing", msg)
install.err <- run_R_CMD(out.dir, "INSTALL", opt$installopts,
sudo = !opt$nosudo)
errs <- errs + install.err
if (!install.err && nzchar(opt$target)) {
message("Copying script files (if any)...")
errs <- errs + !all(copy_pkg_files(x = basename(out.dir),
to = opt$target, ignore = opt$exclude))
}
}
}
quit(status = errs)
################################################################################
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.