chk <- function(msg, check) {
if (check) TRUE else msg
}
chks <- function(..., x, warn) {
results <- list(...)
results <- unlist(setdiff(results, TRUE))
results <- if (length(results) == 0) TRUE else results
if (! identical(results, TRUE) && warn) {
warning(
call. = FALSE,
"'", x$key, "'",
paste0(
if (length(results) == 1) " " else "\n * ",
strwrap(results, indent = 0, exdent = 6)
)
)
}
results
}
#' Syntactical check of a DESCRIPTION field
#'
#' @param x The field.
#' @param warn Whether to generate a warning if the syntax check fails.
#' @param ... Additional arguments, they might be used in the future.
#' @return `TRUE` if the field is syntactically correct,
#' otherwise a character vector, containing one or multiple
#' error messages.
#'
#' @export
check_field <- function(x, warn = FALSE, ...)
UseMethod("check_field")
#' @export
#' @method check_field DescriptionField
check_field.DescriptionField <- function(x, warn = FALSE, ...) TRUE
##' @export
##' @method check_field DescriptionPackage
check_field.DescriptionPackage <- function(x, warn = FALSE, R = FALSE, ...) {
## In Depends, we can depend on certain 'R' versions
if (R && x$value == "R") return(TRUE)
chks(
x = x, warn = warn,
chk("must only contain ASCII letters, numbers, dots",
grepl("^[a-zA-Z0-9\\.]*$", x$value)),
chk("must be at least two characters long",
nchar(x$value) >= 2),
chk("must start with a letter",
grepl("^[a-zA-Z]", x$value)),
chk("must not end with a dot",
!grepl("\\.$", x$value))
)
}
valid_packagename_regexp <- "[[:alpha:]][[:alnum:].]*[[:alnum:]]"
valid_version_regexp <- "[0-9]+[-\\.][0-9]+([-\\.][0-9]+)*"
valid_package_archive_name <- paste0(
"^",
valid_packagename_regexp,
"_",
valid_version_regexp,
"(.*)?",
"(\\.tar\\.gz|\\.tgz|\\.zip)",
"$"
)
##' @export
##' @method check_field DescriptionVersion
check_field.DescriptionVersion <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk(paste("must be a sequence of at least two (usually three)",
" non-negative integers separated by a single dot or dash",
" character"),
grepl(paste0("^", valid_version_regexp, "$"), x$value))
)
}
## TODO: It also must be a license R CMD check recognizes
##
##' @export
##' @method check_field DescriptionLicense
check_field.DescriptionLicense <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must contain only ASCII characters",
is_ascii(x$value)),
chk("must not be empty",
str_trim(x$value) != "")
)
}
##' @export
##' @method check_field DescriptionDescription
check_field.DescriptionDescription <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must not be empty",
str_trim(x$value) != ""),
chk("must contain one or more complete sentences",
grepl("[.!?]['\")]?$", str_trim(x$value))),
chk("must not start with 'The package', 'This Package, 'A package'",
!grepl("^(The|This|A|In this|In the) package", x$value)),
chk("must start with a capital letter",
grepl("^['\"]?[[:upper:]]", x$value))
)
}
##' @export
##' @method check_field DescriptionTitle
check_field.DescriptionTitle <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must not be empty",
str_trim(x$value) != ""),
chk("must not end with a period",
!grepl("[.]$", str_trim(x$value)) ||
grepl("[[:space:]][.][.][.]|et[[:space:]]al[.]", str_trim(x$value)))
)
}
##' @export
##' @method check_field DescriptionMaintainer
check_field.DescriptionMaintainer <- function(x, warn = FALSE, ...) {
re_maint <- paste0(
"^[[:space:]]*(.*<",
RFC_2822_email_regexp,
">|ORPHANED)[[:space:]]*$"
)
chks(
x = x, warn = warn,
chk("must not be empty",
str_trim(x$value) != ""),
chk("must contain an email address",
grepl(re_maint, x$value))
)
}
## TODO
##' @export
##' @method check_field DescriptionAuthorsAtR
check_field.DescriptionAuthorsAtR <- function(x, warn = FALSE, ...) {
TRUE
}
##' @export
##' @method check_field DescriptionDependencyList
check_field.DescriptionDependencyList <- function(x, warn = FALSE, ...) {
deps <- parse_deps(x$key, x$value)
is_package_list <- function(xx) {
p <- lapply(xx, function(pc)
check_field.DescriptionPackage(
list(key = "Package", value = pc),
R = x$key[1] == "Depends"
)
)
all_true(p)
}
is_version_req <- function(x) {
x <- str_trim(x)
if (x == "*") return(TRUE)
re <- paste0(
"^(<=|>=|<|>|==|!=)\\s*",
valid_version_regexp,
"$"
)
grepl(re, x)
}
is_version_req_list <- function(x) {
all_true(vapply(x, is_version_req, TRUE))
}
chks(
x = x, warn = warn,
chk("must contain valid package names",
is_package_list(deps$package)),
chk("must contain valid version requirements",
is_version_req_list(deps$version))
)
}
##' @export
##' @method check_field DescriptionRemotes
check_field.DescriptionRemotes <- function(x, warn = FALSE, ...) {
is_remote <- function(x) {
xx <- str_trim(strsplit(x, ",", fixed = TRUE)[[1]])
p <- grepl("^[^[:space:]]+$", xx)
all_true(p)
}
chks(
x = x, warn = warn,
chk("must be a comma separated list of remotes",
is_remote(x$value))
)
}
##' @export
##' @method check_field DescriptionPackageList
check_field.DescriptionPackageList <- function(x, warn = FALSE, ...) {
is_package_list <- function(x) {
xx <- str_trim(strsplit(x, ",", fixed = TRUE)[[1]])
p <- lapply(xx, function(pc)
check_field.DescriptionPackage(list(key = "Package", value = pc)))
all_true(p)
}
chks(
x = x, warn = warn,
chk("must be a comma separated list of package names",
is_package_list(x$value))
)
}
##' @export
##' @method check_field DescriptionRepoList
check_field.DescriptionRepoList <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be a comma separated list repository URLs",
is_url_list(x$value))
)
}
##' @export
##' @method check_field DescriptionURL
check_field.DescriptionURL <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be a http, https or ftp URL",
is_url(x$value))
)
}
##' @export
##' @method check_field DescriptionURLList
check_field.DescriptionURLList <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be a comma separated list of http, https or ftp URLs",
is_url_list(x$value))
)
}
##' @export
##' @method check_field DescriptionPriority
check_field.DescriptionPriority <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be one of 'base', 'recommended' or 'defunct-base'",
str_trim(x$value) %in% c("base", "recommended", "defunct-base"))
)
}
##' @export
##' @method check_field DescriptionCollate
check_field.DescriptionCollate <- function(x, warn = FALSE, ...) {
coll <- tolower(parse_collate(x$value))
chks(
x = x, warn = warn,
chk("must contain a list of .R files",
all(grepl("[.]r$", coll)))
)
}
##' @export
##' @method check_field DescriptionLogical
check_field.DescriptionLogical <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be one of 'true', 'false', 'yes' or 'no' (case insensitive)",
str_trim(tolower(x$value)) %in% c("true", "false", "yes", "no"))
)
}
##' @export
##' @method check_field DescriptionEncoding
check_field.DescriptionEncoding <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be one of 'latin1', 'latin2' and 'UTF-8'",
x$value %in% c("latin1", "latin2", "UTF-8"))
)
}
##' @export
##' @method check_field DescriptionOSType
check_field.DescriptionOSType <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be one of 'unix' and 'windows'",
x$value %in% c("unix", "windows"))
)
}
##' @export
##' @method check_field DescriptionType
check_field.DescriptionType <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be either 'Package' or 'Translation'",
x$value %in% c("Package", "Translation"))
)
}
##' @export
##' @method check_field DescriptionClassification
check_field.DescriptionClassification <- function(x, warn = FALSE, ...) {
TRUE
}
##' @export
##' @method check_field DescriptionLanguage
check_field.DescriptionLanguage <- function(x, warn = FALSE, ...) {
is_language_list <- function(x) {
x <- str_trim(strsplit(x, ",", fixed = TRUE)[[1]])
all(grepl("^[a-z][a-z][a-z]?(-[A-Z]+)?$", x))
}
chks(
x = x, warn = warn,
chk("must be a list of IETF language codes defined by RFC 5646",
is_language_list(x$value))
)
}
##' @export
##' @method check_field DescriptionDate
check_field.DescriptionDate <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk(
paste0(
"must be an ISO date: yyyy-mm-dd, but it is actually better\n",
"to leave this field out completely. It is not required."),
grepl("^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]$", x$value)
)
)
}
##' @export
##' @method check_field DescriptionCompression
check_field.DescriptionCompression <- function(x, warn = FALSE, ...) {
chks(
x = x, warn = warn,
chk("must be one of 'bzip2', 'xz', 'gzip'",
x$value %in% c("bzip2", "xz", "gzip"))
)
}
##' @export
##' @method check_field DescriptionRepository
check_field.DescriptionRepository <- function(x, warn = FALSE, ...) {
TRUE
}
##' @export
##' @method check_field DescriptionFreeForm
check_field.DescriptionFreeForm <- function(x, warn = FALSE, ...) {
TRUE
}
##' @export
##' @method check_field DescriptionAddedByRCMD
check_field.DescriptionAddedByRCMD <- function(x, warn = FALSE, ...) {
TRUE
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.