Nothing
###########################################################################/**
# @RdocClass RspDirective
#
# @title "The abstract RspDirective class"
#
# \description{
# @classhierarchy
#
# An RspDirective is an @see "RspConstruct" that represents an
# RSP preprocessing directive of format \code{<\%@ ... \%>}.
# The directive is independent of the underlying programming language.
# }
#
# @synopsis
#
# \arguments{
# \item{value}{A @character string.}
# \item{...}{Arguments passed to the constructor of @see "RspConstruct".}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspDirective", function(value=character(), ...) {
extend(RspConstruct(value, ...), "RspDirective")
})
#########################################################################/**
# @RdocMethod "requireAttributes"
#
# @title "Asserts that certain attributes exist"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{condition}{A @character specifying the condition to be tested.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns itself (invisibly).
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("requireAttributes", "RspDirective", function(this, names, condition=c("all", "any"), ...) {
# Argument 'condition':
condition <- match.arg(condition)
attrs <- getAttributes(this)
ok <- is.element(names, names(attrs))
if (condition == "all") {
if (!all(ok)) {
throw(RspPreprocessingException(sprintf("One or more required attributes (%s) are missing", paste(sQuote(names[!ok]), collapse=", ")), item=this))
}
} else if (condition == "any") {
if (!any(ok)) {
throw(RspPreprocessingException(sprintf("At least one of the required attributes (%s) must be given", paste(sQuote(names[!ok]), collapse=", ")), item=this))
}
}
invisible(this)
}, protected=TRUE)
setMethodS3("getNameContentDefaultAttributes", "RspDirective", function(item, known=NULL, doc=NULL, ...) {
name <- getAttribute(item, "name")
content <- getAttribute(item, "content")
default <- getAttribute(item, "default")
file <- getAttribute(item, "file")
# Was directive given in short format <@<directive> file="<content>">?
if (is.null(name) && is.null(content) && !is.null(file)) {
name <- "file"
content <- file
file <- NULL
}
# Was directive given in short format <@<directive> <name>="<content>">?
if (is.null(name) && is.null(content)) {
attrs <- getAttributes(item)
names <- setdiff(names(attrs), c("file", "default", known))
if (length(names) == 0L) {
throw(RspPreprocessingException("At least one of attributes 'name' and 'content' must be given", item=item))
}
name <- names[1L]
content <- attrs[[name]]
if (length(content) > 1L) content <- paste(content, collapse="")
}
# Was directive given with 'file' attribute?
if (!is.null(file) && !is.null(doc)) {
path <- getPath(doc)
if (!is.null(path)) {
pathname <- file.path(getPath(doc), file)
} else {
pathname <- file
}
# Sanity check
stop_if_not(!is.null(pathname))
content <- .readText(pathname)
}
## Sanity check
stop_if_not(is.null(content) || length(content) == 1L)
# Use default?
if (!is.null(content) && (is.na(content) || content == "NA")) {
value <- default
} else {
value <- content
}
list(name=name, value=value, content=content, file=file, default=default)
}, protected=TRUE) # getNameContentDefaultAttributes()
setMethodS3("asRspString", "RspDirective", function(object, ...) {
body <- unclass(object)
attrs <- getAttributes(object)
if (length(attrs) == 0L) {
attrs <- ""
} else {
attrs <- sprintf('%s="%s"', names(attrs), attrs)
attrs <- paste(c("", attrs), collapse=" ")
}
comment <- getComment(object)
if (length(comment) == 0L) {
comment <- ""
} else {
comment <- sprintf(" #%s", comment)
}
suffixSpecs <- attr(object, "suffixSpecs")
if (length(suffixSpecs) == 0L) {
suffixSpecs <- ""
}
fmtstr <- "@%s%s%s%s"
fmtstr <- paste(escFmtStr(.rspBracketOpen), fmtstr, escFmtStr(.rspBracketClose), sep="")
s <- sprintf(fmtstr, body, attrs, comment, suffixSpecs)
RspString(s)
})
###########################################################################/**
# @RdocClass RspUnparsedDirective
#
# @title "The RspUnparsedDirective class"
#
# \description{
# @classhierarchy
#
# An RspUnparsedDirective is an @see RspDirective that still has not
# been parsed for its class and content. After @see "parse":ing such
# an object, the class of this RSP directive will be known.
# }
#
# @synopsis
#
# \arguments{
# \item{value}{A @character string.}
# \item{...}{Arguments passed to @see "RspDirective".}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspUnparsedDirective", function(value="unparsed", ...) {
extend(RspDirective(value, ...), "RspUnparsedDirective")
})
#########################################################################/**
# @RdocMethod parseDirective
#
# @title "Parses the unknown RSP directive for its class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns an @see "RspDirective" of known class.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("parseDirective", "RspUnparsedDirective", function(expr, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local function
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
parseAttributes <- function(rspCode, known=mandatory, mandatory=NULL, ...) {
bfr <- rspCode
# Argument 'known':
known <- unique(union(known, mandatory))
# Remove all leading white spaces
pos <- regexpr("^[ \t\n\r]+", bfr)
len <- attr(pos, "match.length")
bfr <- substring(bfr, first=len+1L)
attrs <- list()
if (nchar(bfr) > 0L) {
# Add a white space
bfr <- paste(" ", bfr, sep="")
while (nchar(bfr) > 0L) {
# Read all (mandatory) white spaces
pos <- regexpr("^[ \t\n\r]+", bfr)
if (pos == -1L) {
throw(Exception("Error when parsing attributes of RSP preprocessing directive. Expected white space: ", code=sQuote(rspCode)))
}
len <- attr(pos, "match.length")
bfr <- substring(bfr, first=len+1L)
# Nothing left?
if (nchar(bfr) == 0L) {
break
}
# Is the remaining part a comment?
if (regexpr("^#", bfr) != -1L) {
# ...then add it as an (R) attribute to 'attrs'.
comment <- gsub("^#", "", bfr)
attr(attrs, "comment") <- comment
# ...and finish.
break
}
# Read the attribute name
pos <- regexpr("^[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_][abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0-9_]*", bfr)
if (pos == -1L) {
throw(Exception("Error when parsing attributes of RSP preprocessing directive. Expected an attribute name: ", code=sQuote(rspCode)))
}
len <- attr(pos, "match.length")
name <- substring(bfr, first=1L, last=len)
bfr <- substring(bfr, first=len+1L)
# Read the '=' with optional white spaces around it
pos <- regexpr("^[ \t\n\r]*=[ \t\n\r]*", bfr)
if (pos == -1L) {
throw(Exception("Error when parsing attributes of RSP preprocessing directive. Expected an equal sign: ", code=sQuote(rspCode)))
}
len <- attr(pos, "match.length")
bfr <- substring(bfr, first=len+1L)
# Work with a raw buffer
bfrR <- charToRaw(bfr)
# Read the value with mandatory brackets around it
# (a) Identify the bracket symbols
lbracketR <- bfrR[1L]
lbracket <- rawToChar(lbracketR)
rbracket <- c("{"="}", "("=")", "["="]", "<"=">")[lbracket]
# (b) Single brackets or paired ones?
if (is.na(rbracket)) {
# (i) Single, e.g. '...', "...", @...@ etc.
bfrR <- bfrR[-1L]
wbracket <- 1L
# Find first non-escape symbol
pos <- which(bfrR == lbracketR)
# Failed to locate a string enclosed in quotation marks
if (length(pos) == 0L) {
throw(Exception("Error when parsing attributes of RSP preprocessing directive. Expected an attribute value within quotation marks: ", code=sQuote(rspCode)))
}
# An empty value?
if (pos[1L] == 1L) {
value <- ""
} else {
# Drop escaped brackets
keep <- (bfrR[pos-1L] != charToRaw("\\"))
pos <- pos[keep]
# Failed to locate a string enclosed in quotation marks
if (length(pos) == 0L) {
throw(Exception("Error when parsing attributes of RSP preprocessing directive. Expected an attribute value within quotation marks: ", code=sQuote(rspCode)))
}
pos <- pos[1L]
bfrR <- bfrR[1:(pos-1)]
value <- rawToChar(bfrR)
}
# Record brackets
brackets <- c(lbracket, lbracket)
# Update buffer
bfr <- substring(bfr, first=pos+2L)
} else {
# (ii) Paired brackets, e.g. {...}, [...], <<...>>
# Width of left bracket, i.e. how many symbols?
for (wbracket in seq_len(nchar(bfr))) {
ch <- substring(bfr, first=wbracket, last=wbracket)
if (ch != lbracket) {
wbracket <- wbracket - 1L
break
}
}
bfr <- substring(bfr, first=wbracket+1L)
# (c) Identify right bracket symbol (escaped for regexpr)
rbracket <- c("{"="\\}", "("="\\)", "["="\\]", "<"=">",
"+"="\\+", "."="\\.", "?"="\\?", "|"="\\|")[lbracket]
if (is.na(rbracket)) rbracket <- lbracket
# Right bracket sequence
rbrackets <- paste(rep(rbracket, times=wbracket), collapse="")
# .*? is a non-greedy .* expression
pattern <- sprintf("^(.*?)([^\\]?)%s", rbrackets)
pos <- regexpr(pattern, bfr)
# Failed to locate a string enclosed in brackets
if (pos == -1L) {
throw(Exception("Error when parsing attributes of RSP preprocessing directive. Expected a attribute value within brackets: ", code=sQuote(rspCode)))
}
# Extract value
len <- attr(pos, "match.length")
value <- substring(bfr, first=1L, last=len-wbracket)
# Record brackets
lbrackets <- paste(rep(lbracket, times=wbracket), collapse="")
rbrackets <- gsub("\\\\", "\\", rbrackets)
brackets <- c(lbrackets, rbrackets)
# Consume buffer
bfr <- substring(bfr, first=len+wbracket)
} # if (is.na(rbracket))
# Set the name of the value
names(value) <- name
# TODO: Record brackets used
# ...
attrs <- c(attrs, value)
}
} # if (nchar(bfr) > 0L)
# Check for duplicated attributes
if (length(names(attrs)) != length(unique(names(attrs))))
throw(Exception("Duplicated attributes in RSP preprocessing directive.", code=sQuote(rspCode)))
# Check for unknown attributes
if (!is.null(known)) {
nok <- which(is.na(match(names(attrs), known)))
if (length(nok) > 0L) {
nok <- paste("'", names(attrs)[nok], "'", collapse=", ", sep="")
throw(Exception("Unknown attribute(s) in RSP preprocessing directive: ", nok, code=sQuote(rspCode)))
}
}
# Check for missing mandatory attributes
if (!is.null(mandatory)) {
nok <- which(is.na(match(mandatory, names(attrs))))
if (length(nok) > 0L) {
nok <- paste("'", mandatory[nok], "'", collapse=", ", sep="")
throw(Exception("Missing attribute(s) in RSP preprocessing directive: ", nok, code=sQuote(rspCode)))
}
}
# Return parsed attributes.
attrs
} # parseAttributes()
body <- expr
pattern <- "^[ ]*([abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ][abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0-9]*)([ \t\n\r]+(.*))*"
# Sanity check
if (regexpr(pattern, body) == -1L) {
throw("Not an RSP preprocessing directive: ", body)
}
# <%@foo attr1="bar" attr2="geek"%> => ...
directive <- gsub(pattern, "\\1", body)
directive <- tolower(directive)
# Parse the attributes
attrs <- gsub(pattern, "\\2", body)
attrs <- parseAttributes(attrs, known=NULL)
comment <- attr(attrs, "comment")
# Infer the class name
className <- sprintf("Rsp%sDirective", capitalize(directive))
# Get constructor
clazz <- tryCatch({
ns <- getNamespace("R.rsp")
Class$forName(className, envir=ns)
}, error = function(ex) {
NULL
})
# Instantiate object
if (!is.null(clazz)) {
res <- newInstance(clazz, attrs=attrs, comment=comment)
} else {
res <- RspUnknownDirective(directive, attrs=attrs)
}
# Preserve attributes
attr(res, "suffixSpecs") <- attr(expr, "suffixSpecs")
res
})
setMethodS3("asRspString", "RspUnparsedDirective", function(object, ...) {
body <- unclass(object)
suffixSpecs <- attr(object, "suffixSpecs")
fmtstr <- "@%s%s"
fmtstr <- paste(escFmtStr(.rspBracketOpen), fmtstr, escFmtStr(.rspBracketClose), sep="")
s <- sprintf(fmtstr, body, suffixSpecs)
RspString(s)
})
###########################################################################/**
# @RdocClass RspIncludeDirective
#
# @title "The RspIncludeDirective class"
#
# \description{
# @classhierarchy
#
# An RspIncludeDirective is an @see "RspDirective" that causes the
# RSP parser to include (and parse) an external RSP file.
# }
#
# @synopsis
#
# \arguments{
# \item{value}{A @character string.}
# \item{...}{Optional arguments passed to the constructor
# of @see "RspDirective".}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspIncludeDirective", function(value="include", ...) {
this <- extend(RspDirective(value, ...), "RspIncludeDirective")
if (!missing(value)) {
requireAttributes(this, names=c("file", "text"), condition="any")
}
this
})
#########################################################################/**
# @RdocMethod getFile
#
# @title "Gets the file attribute"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("getFile", "RspIncludeDirective", function(directive, ...) {
getAttribute(directive, "file")
})
#########################################################################/**
# @RdocMethod getContent
#
# @title "Gets the content of the RSP include directive"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("getContent", "RspIncludeDirective", function(directive, ...) {
getAttribute(directive, "content")
})
#########################################################################/**
# @RdocMethod getVerbatim
#
# @title "Checks if verbatim include should be used or not"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @logical.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("getVerbatim", "RspIncludeDirective", function(directive, ...) {
res <- getAttribute(directive, "verbatim", default=FALSE)
res <- as.logical(res)
res <- isTRUE(res)
res
})
#########################################################################/**
# @RdocMethod getWrap
#
# @title "Get the wrap length"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns an @integer, or @NULL.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("getWrap", "RspIncludeDirective", function(directive, ...) {
res <- getAttribute(directive, "wrap")
if (!is.null(res)) {
res <- as.integer(res)
}
res
})
###########################################################################/**
# @RdocClass RspEvalDirective
#
# @title "The RspEvalDirective class"
#
# \description{
# @classhierarchy
#
# An RspEvalDirective is an @see "RspDirective" that causes the
# RSP parser to evaluate a piece of R code (either in a text string
# or in a file) as it is being parsed.
# }
#
# @synopsis
#
# \arguments{
# \item{value}{A @character string.}
# \item{...}{Optional arguments passed to the constructor
# of @see "RspDirective".}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspEvalDirective", function(value="eval", ...) {
this <- extend(RspDirective(value, ...), "RspEvalDirective")
if (!missing(value)) {
requireAttributes(this, names=c("file", "text"), condition="any")
lang <- getAttribute(this, default="R")
this <- setAttribute(this, "language", lang)
}
this
})
#########################################################################/**
# @RdocMethod getFile
#
# @title "Gets the file attribute"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("getFile", "RspEvalDirective", function(directive, ...) {
getAttribute(directive, "file")
})
#########################################################################/**
# @RdocMethod getContent
#
# @title "Gets the content of the RSP eval directive"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("getContent", "RspEvalDirective", function(directive, ...) {
getAttribute(directive, "content")
})
###########################################################################/**
# @RdocClass RspPageDirective
#
# @title "The RspPageDirective class"
#
# \description{
# @classhierarchy
#
# An RspPageDirective is an @see "RspDirective" that annotates the
# content of the RSP document, e.g. the content type.
# }
#
# @synopsis
#
# \arguments{
# \item{value}{A @character string.}
# \item{...}{Arguments passed to the constructor of @see "RspDirective".}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspPageDirective", function(value="page", ...) {
extend(RspDirective(value, ...), "RspPageDirective")
})
#########################################################################/**
# @RdocMethod getType
#
# @title "Gets the content type"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{default}{If unknown/not set, the default content type to return.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("getType", "RspPageDirective", function(directive, default=NA, as=c("text", "IMT"), ...) {
as <- match.arg(as)
res <- getAttribute(directive, "type", default=as.character(default))
res <- tolower(res)
if (as == "IMT" && !is.na(res)) {
res <- parseInternetMediaType(res)
}
res
})
###########################################################################/**
# @RdocClass RspUnknownDirective
#
# @title "The RspUnknownDirective class"
#
# \description{
# @classhierarchy
#
# An RspUnknownDirective is an @see "RspDirective" that is unknown.
# }
#
# @synopsis
#
# \arguments{
# \item{value}{A @character string.}
# \item{...}{Arguments passed to the constructor of @see "RspDirective".}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspUnknownDirective", function(value="unknown", ...) {
extend(RspDirective(value, ...), "RspUnknownDirective")
})
###########################################################################/**
# @RdocClass RspErrorDirective
#
# @title "The RspErrorDirective class"
#
# \description{
# @classhierarchy
#
# An RspErrorDirective is an @see "RspDirective" that generates an
# RSP preprocessing error (if processed).
# }
#
# @synopsis
#
# \arguments{
# \item{value}{A @character string.}
# \item{...}{Arguments passed to the constructor of @see "RspDirective".}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspErrorDirective", function(value="error", ...) {
extend(RspDirective(value, ...), "RspErrorDirective")
})
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.