in source/src/library/tools/R/RdConv2.R [585:976]
psub <- function(pattern, replacement, x)
## gsub(pattern, replacement, x, perl = TRUE, useBytes = TRUE)
.Internal(gsub(pattern, replacement, x, FALSE, TRUE, FALSE, TRUE))
psub1 <- function(pattern, replacement, x)
## sub(pattern, replacement, x, perl = TRUE, useBytes = TRUE)
.Internal(sub(pattern, replacement, x, FALSE, TRUE, FALSE, TRUE))
fsub <- function(pattern, replacement, x)
## gsub(pattern, replacement, x, fixed = TRUE, useBytes = TRUE)
.Internal(gsub(pattern, replacement, x, FALSE, FALSE, TRUE, TRUE))
fsub1 <- function(pattern, replacement, x)
## sub(pattern, replacement, x, fixed = TRUE, useBytes = TRUE)
.Internal(sub(pattern, replacement, x, FALSE, FALSE, TRUE, TRUE))
## for lists of messages, see ../man/checkRd.Rd
checkRd <- function(Rd, defines=.Platform$OS.type, stages = "render",
unknownOK = TRUE, listOK = TRUE, ..., def_enc = FALSE)
{
warnRd <- function(block, Rdfile, ..., level=0)
{
srcref <- attr(block, "srcref")
msg <- if (is.null(srcref))
paste0("file '", Rdfile, "': ", ...)
else {
loc <- paste0(Rdfile, ":", srcref[1L])
if (srcref[1L] != srcref[3L]) loc <- paste0(loc, "-", srcref[3L])
paste0(loc, ": ", ...)
}
msg <- sprintf("checkRd: (%d) %s", level, msg)
.messages <<- c(.messages, msg)
}
checkLink <- function(tag, block) {
option <- attr(block, "Rd_option")
if(!is.null(option)) checkContent(option, tag)
checkContent(block, tag)
get_link(block, tag, Rdfile) ## to do the same as Rd2HTML
}
## blocktag is unused
checkBlock <- function(block, tag, blocktag)
{
switch(tag,
## parser already warned here
UNKNOWN = if (!unknownOK)
stopRd(block, Rdfile, "Unrecognized macro ", block[[1L]]),
VERB = ,
RCODE = ,
TEXT = {
if(!def_enc) {
## check for encoding; this is UTF-8 if known
## (but then def_enc = TRUE?)
msg2 <- if(inEnc2) "in second part of \\enc" else "without declared encoding"
if(Encoding(block) == "UTF-8")
warnRd(block, Rdfile, level = -1,
"Non-ASCII contents ", msg2)
if(grepl("<[0123456789abcdef][0123456789abcdef]>", block))
warnRd(block, Rdfile, level = -3,
"Apparent non-ASCII contents ", msg2)
}
## check if this renders as non-whitespace
if(!grepl("^[[:space:]]*$", block)) has_text <<- TRUE
},
USERMACRO =,
"\\newcommand" =,
"\\renewcommand" =,
COMMENT = {},
LIST = if (length(block)) {
deparse <- sQuote(paste(as.character.Rd(block), collapse=""))
if(!listOK)
stopRd(block, Rdfile, "Unnecessary braces at ", deparse)
else warnRd(block, Rdfile, level = -3,
"Unnecessary braces at ", deparse)
checkContent(block, tag)
},
"\\describe"=,
"\\enumerate"=,
"\\itemize"=,
"\\bold"=,
"\\cite"=,
"\\command"=,
"\\dfn"=,
"\\emph"=,
"\\kbd"= checkContent(block, tag),
"\\code"=,
"\\preformatted"= checkCodeBlock(block, tag),
"\\Sexpr"=,
"\\special"=,
"\\strong"=,
"\\var" =,
"\\verb"= checkContent(block, tag),
"\\linkS4class" =,
"\\link" = checkLink(tag, block),
"\\email" =,
"\\url" = has_text <<- TRUE,
"\\cr" ={},
"\\dots" =,
"\\ldots" =,
"\\R" = has_text <<- TRUE,
"\\acronym" =,
"\\env" =,
"\\file" =,
"\\option" =,
"\\pkg" =,
"\\samp" =,
"\\sQuote" =,
"\\dQuote" = checkContent(block, tag),
"\\method" =,
"\\S3method" =,
"\\S4method" =
warnRd(block, Rdfile, level = 7, "Tag ", tag,
" not valid outside a code block"),
"\\enc" = {
checkContent(block[[1L]], tag)
## second arg should always be ASCII
save_enc <- def_enc
def_enc <<- FALSE
inEnc2 <<- TRUE
checkContent(block[[2L]], tag)
def_enc <<- save_enc
inEnc2 <<- FALSE
},
"\\eqn" =,
"\\deqn" =,
"\\figure" = {
checkContent(block[[1L]])
if (length(block) > 1L) checkContent(block[[2L]])
},
"\\tabular" = checkTabular(block),
"\\subsection" = checkSection(block, tag),
"\\if" =,
"\\ifelse" = {
condition <- block[[1L]]
tags <- RdTags(condition)
if (!all(tags %in% c("TEXT", "\\Sexpr")))
stopRd(block, Rdfile, "Condition must be \\Sexpr or plain text")
condition <- condition[tags == "TEXT"]
allow <- trimws(strsplit(paste(condition, collapse=""), ",")[[1L]])
unknown <- allow[!(allow %in%
c("", "latex", "example", "text", "html", "TRUE", "FALSE"))]
if (length(unknown))
warnRd(block, Rdfile, "Unrecognized format: ", unknown)
checkContent(block[[2L]])
if (tag == "\\ifelse")
checkContent(block[[3L]])
},
"\\href" = {
if (!identical(RdTags(block[[1L]]), "VERB"))
stopRd(block, Rdfile, "First argument to \\href must be verbatim URL")
checkContent(block[[2L]], tag)
},
"\\out" = {
tags <- RdTags(block)
if (!all(tags == "VERB"))
stopRd(block, Rdfile, "Must contain verbatim text")
},
warnRd(block, Rdfile, level = 7, "Tag ", tag, " not recognized"))
}
checkCodeBlock <- function(blocks, blocktag)
{
for (block in blocks) {
tag <- attr(block, "Rd_tag")
switch(tag,
## parser already warned here
UNKNOWN = if (!unknownOK)
stopRd(block, Rdfile, "Unrecognized macro ", block[[1L]]),
VERB = ,
RCODE = ,
TEXT = {
if(!def_enc) {
## check for encoding; this is UTF-8 if known
## (but then def_enc = TRUE?)
msg2 <- if(inEnc2) "in second part of \\enc" else "without declared encoding"
if(Encoding(block) == "UTF-8")
warnRd(block, Rdfile, level = -1,
"Non-ASCII contents ", msg2)
if(grepl("<[0123456789abcdef][0123456789abcdef]>", block))
warnRd(block, Rdfile, level = -3,
"Apparent non-ASCII contents ", msg2)
}
## check if this renders as non-whitespace
if(!grepl("^[[:space:]]*$", block)) has_text <<- TRUE
},
USERMACRO =,
"\\newcommand" =,
"\\renewcommand" =,
COMMENT = {},
"\\var" = checkCodeBlock(block, blocktag), # not preformatted, but the parser checks that
"\\special" = checkCodeBlock(block, blocktag),
"\\dots" = has_text <<- TRUE,
"\\ldots" = {
## but it is rendered as ... in all converters
warnRd(block, Rdfile, level = -3,
"Tag ", tag, " is invalid in a code block")
has_text <<- TRUE
},
## these are valid in \code, at least
"\\linkS4class" =,
"\\link" = checkLink(tag, block),
"\\method" =,
"\\S3method" =,
"\\S4method" = if(blocktag == "\\usage") {
checkContent(block[[1L]], tag) # generic
checkContent(block[[2L]], tag) # class
} else warnRd(block, Rdfile, level = 7,
"Tag ", tag, " is only valid in \\usage"),
"\\dontrun" =,
"\\donttest" =,
"\\dontshow" =,
"\\testonly" = if(blocktag == "\\examples")
checkCodeBlock(block, blocktag)
else warnRd(block, Rdfile, level = 7,
"Tag ", tag, " is only valid in \\examples"),
{
warnRd(block, Rdfile, level = 7,
"Tag ", tag, " is invalid in a ",
blocktag, " block")
has_text <<- TRUE # likely, e.g. \url
})
}
}
checkTabular <- function(table) {
has_text <<- TRUE
format <- table[[1L]]
content <- table[[2L]]
if (length(format) != 1 || RdTags(format) != "TEXT")
warnRd(table, Rdfile, level = 7,
"\\tabular format must be simple text")
format <- strsplit(format[[1L]], "", fixed=TRUE)[[1L]]
if (!all(format %in% c("l", "c", "r")))
warnRd(table, Rdfile, level = 7,
"Unrecognized \\tabular format: ", table[[1L]][[1L]])
tags <- RdTags(content)
newrow <- TRUE
for (i in seq_along(tags)) {
if (newrow) {
newrow <- FALSE
col <- 0
newcol <- TRUE
}
if (newcol) {
col <- col + 1
if (col > length(format))
warnRd(table, Rdfile, level = 7,
"Only ", length(format),
" columns allowed in this table")
newcol <- FALSE
}
switch(tags[i],
"\\tab" = {
newcol <- TRUE
},
"\\cr" = {
newrow <- TRUE
},
checkBlock(content[[i]], tags[i], "\\tabular"))
}
}
checkContent <- function(blocks, blocktag) {
inlist <- FALSE
tags <- RdTags(blocks)
for (i in seq_along(tags)) {
tag <- tags[i]
block <- blocks[[i]]
switch(tag,
"\\item" = {
if (!inlist) inlist <- TRUE
switch(blocktag,
"\\arguments"= {
checkContent(block[[1L]], tag)
checkContent(block[[2L]], tag)
},
"\\value"=,
"\\describe"= {
checkContent(block[[1L]], tag)
checkContent(block[[2L]], tag)
},
"\\enumerate"=,
"\\itemize"= {})
},
{ # default
if (inlist && !(blocktag %in% c("\\itemize", "\\enumerate"))
&& !(tag == "TEXT" && isBlankRd(block))) {
inlist <- FALSE
}
checkBlock(block, tag, blocktag)
})
}
}
has_text <- FALSE
checkSection <- function(section, tag) {
if (tag == "\\section" || tag == "\\subsection") {
title <- section[[1L]]
checkContent(title, tag)
section <- section[[2L]]
## replace 'tag' in message below
tagtitle <- sQuote(as.character(title))
} else tagtitle <- tag
has_text <<- FALSE
if (tag == "\\synopsis")
stopRd(section, Rdfile, "\\synopsis was removed in R 3.1.0")
if (tag %in% c("\\usage", "\\examples"))
checkCodeBlock(section, tag)
else checkContent(section, tag)
if(!has_text) warnRd(section, Rdfile, level = 3,
"Empty section ", tagtitle)
}
checkUnique <- function(tag) { # currently only used for \description
which <- which(sections == tag)
if (length(which) < 1L)
warnRd(Rd, Rdfile, level = 5, "Must have a ", tag)
else {
if (length(which) > 1L)
warnRd(Rd[[which[2L]]], Rdfile, level = 5,
"Only one ", tag, " is allowed")
empty <- TRUE
for(block in Rd[which]) {
switch(attr(block, "Rd_tag"),
TEXT = if(!grepl("^[[:space:]]*$", block))
empty <- FALSE,
empty <- FALSE)
}
if(empty)
warnRd(Rd[[which[1L]]], Rdfile, level = 5,
"Tag ", tag, " must not be empty")
}
}
dt <- which(RdTags(Rd) == "\\docType")
docTypes <- character(length(dt))
if (length(dt)) {
for (i in dt) {
docType <- Rd[[i]]
if(!identical(RdTags(docType), "TEXT"))
warnRd(docType, Rdfile, level = 7,
"'docType' must be plain text")
## Some people have \docType{ package } and similar.
docTypes[i] <- sub("^ *", "", sub(" *$", "", docType[[1L]]))
}
}
.messages <- character()
.whandler <- function(e) {
.messages <<- c(.messages, paste("prepare_Rd:", conditionMessage(e)))
invokeRestart("muffleWarning")
}
Rd <- withCallingHandlers({
prepare_Rd(Rd, defines=defines, stages=stages,
warningCalls = FALSE, ..., msglevel = 1)
}, warning = .whandler)
Rdfile <- attr(Rd, "Rdfile")
sections <- RdTags(Rd)
enc <- which(sections == "\\encoding")
## sanity was checked in prepare2_Rd
if (length(enc)) def_enc <- TRUE
inEnc2 <- FALSE
if(!identical("package", docTypes))
checkUnique("\\description")
## Check other standard sections are unique
## \alias, \keyword and \note are allowed to be repeated
## Normally prepare_Rd will have dropped duplicates already
unique_tags <-
paste("\\",
c("name", "title", # "description" checked above
"usage", "arguments", "synopsis",
"format", "details", "value", "references", "source",
"seealso", "examples", "author", "encoding"),
sep = "")
for(tag in intersect(sections[duplicated(sections)], unique_tags))
warnRd(Rd, Rdfile, level = 5,
sprintf("multiple sections named '%s' are not allowed", tag))
for (i in seq_along(sections))
checkSection(Rd[[i]], sections[i])
structure(.messages, class = "checkRd")
}