## functions for generating documentation
setGeneric("prompt",
function(object, filename = NULL, name = NULL, ...)
standardGeneric("prompt"))
setMethod("prompt", "missing",
function(object, filename, name, ...)
prompt(get(name, parent.frame()), filename, name, ...))
promptStageMethods <- function(object, doc)
{
## add methods for displayName, inType and outType
stageValues <- c(displayName = displayName(object),
inType = inType(object), outType = outType(object))
stageMethods <- paste("Returns \"", stageValues, "\".", sep = "")
fillMethod <- function(i)
{
raw <- doc$`section{Methods}`[i+2]
filled <- sub("...", stageMethods[i], raw, fixed = TRUE)
link <- paste("\\link{", names(stageValues)[i], "}", sep = "")
sub(names(stageValues)[i], link, filled, fixed = TRUE)
}
filledMethods <- sapply(seq_along(stageMethods), fillMethod)
doc$`section{Methods}`[seq_along(filledMethods)+2] <- filledMethods
doc
}
setMethod("prompt", "Stage",
function(object, filename, name, protocols = TRUE,
where = .externalCallerEnv(), ...)
{
force(where)
protos <- sapply(protocolClasses(object, where), new)
methods <- paste(role(object), sapply(protos, method), sep = ".")
############# STAGE CLASS
cl <- class(object)
cp <- promptClass(cl, NA, where = where, ...)
# set title to display name
cp$title <- rdmacro("title", paste(displayName(object)))
# set description to something generic
methodLink <- rdlink(role(object))
desc <- paste("A role that a protocol might play in a pipeline. ",
"See", methodLink, "for details.")
cp$description <- rdmacro("description", desc)
# objects-from-the-class can be created using Stage()
ofc <- paste("Create instances with \\code{\\link{Stage}(\"",
role(object), "\")}.", sep = "")
ofc <- rdmacro("section{Objects from the Class}", ofc)
cp$`section{Objects from the Class}` <- ofc
# add methods for displayName, inType and outType
cp <- promptStageMethods(object, cp)
# author - the package developers
cp$author <- "The package developers"
# seealso - the main method for performing protocols
seealso <- paste(methodLink, "to perform a protocol of this stage.")
cp$seealso <- rdmacro("seealso", seealso)
# add 'internal' keyword
internal <- rdmacro("keyword", "internal")
cp$keywords <- paste(cp$keywords, internal, sep = "\n")
# stuff we don't want to include
cp$references <- character(0)
cp$note <- character(0)
cp$examples <- character(0)
############ MAIN METHOD
met <- role(object)
mp <- promptMethods(met, NA, ...)
mp$aliases <- c(mp$aliases, rdmacro("alias", met))
mp$title <- rdmacro("title", met)
mp$keywords <- mp$keywords[1] # drop dummy keyword
mp$author <- cp$author
seealso <- paste(paste(rdlink(methods), collapse=", "),
"for details on each (built-in) method.")
mp$seealso <- rdmacro("seealso", seealso)
############ PROTOCOL ACCESSORS
# produce and fill-in getter docs
getter <- paste(role(object), "Proto", sep = "")
gp <- promptMethods(getter, NA)
gp$aliases <- c(gp$aliases, rdmacro("alias", getter))
title <- paste("Access", displayName(object), "Protocols")
gp$title <- rdmacro("title", title)
desc <- paste("Get or replace a", rdlink(role(object)), "protocol.")
gp$description <- rdmacro("description", desc)
getCode <- paste(getter, "(object)", sep = "")
getBlurb <- paste(rdmacro("\\code", getCode), ": Get the first",
rdmacro("\\code", role(object)), "protocol.")
getterMethods <- gp$`section{Methods}`
filledMethods <- sub("~~.*? }", paste(getBlurb, "}"), getterMethods)
gp$keywords[2] <- rdmacro("keyword", "internal")
# merge in setter docs
setter <- paste(getter, "<-", sep = "")
sp <- promptMethods(setter, NA)
gp$aliases <- c(gp$aliases, sp$aliases, rdmacro("alias", setter))
setCode <- paste(getter, "(object) <- value", sep = "")
setBlurb <- paste(rdmacro("\\code", setCode), ": Replace the first",
rdmacro("\\code", role(object)), "protocol.")
setterMethods <- tail(head(sp$`section{Methods}`, -1), -1)
findSig <- function(txt) sub(".*object = \"([^\"]*).*", "\\1", txt)
setterSig <- findSig(setterMethods)
getterSig <- findSig(getterMethods)
mm <- match(setterSig, getterSig)
settersAdded <- sub(" }", paste("\n", setBlurb, "}"),
filledMethods[mm])
filledMethods[mm] <- settersAdded
gp$`section{Methods}` <- filledMethods
############ PROTOCOLS
if (is.null(filename))
filename <- getwd()
pp <- NULL
if (protocols)
pp <- sapply(protos, prompt, filename = filename, ...)
############ OUTPUT
if (!is.na(filename)) {
rdwrite(cp, filename, cl, "class")
rdwrite(mp, filename, met, "methods")
rdwrite(gp, filename, getter, "methods")
invisible(filename)
} else list(class = cp, method = mp, accessor = gp, protocols = pp)
})
setMethod("prompt", "Protocol",
function(object, filename, name, where = .externalCallerEnv(), ...)
{
print(filename)
cl <- class(object)
force(where)
stage <- stage(object, where)
role <- role(stage)
method <- method(object, where)
############## PROTOCOL CLASS
cp <- promptClass(cl, NA, where = where, ...)
# set title to dicsplay name
cp$title <- rdmacro("title", displayName(object))
# set description to something generic
met <- paste(role, method, sep = ".")
methodLink <- rdlink(met)
desc <- paste("An object that performs an analysis strategy.",
"See", methodLink, "for details.")
cp$description <- rdmacro("description", desc)
# objects-from-the-class can be created using Stage()
ofc <- paste("Create instances with \\code{\\link{Protocol}(\"",
role, "\", \"", method, "\")}.", sep = "")
ofc <- rdmacro("section{Objects from the Class}", ofc)
cp$`section{Objects from the Class}` <- ofc
# note that slots are parameters
slotMessage <- paste("Slots match parameters in ", methodLink, ".",
sep = "")
cp$`section{Slots}`[1] <- paste(cp$`section{Slots}`[1], slotMessage)
cp$`section{Slots}` <- sub(" ~~ ", "", cp$`section{Slots}`)
# add the displayName, inType, outType methods
cp <- promptStageMethods(object, cp)
# author - the developers
cp$author <- rdmacro("author", "The package developers")
# seealso - the main method for performing protocols
seealso <- paste(methodLink, "to perform this protocol.")
cp$seealso <- rdmacro("seealso", seealso)
# add 'internal' keyword
internal <- rdmacro("keyword", "internal")
cp$keywords <- c(cp$keywords, internal)
# stuff we don't want to include
cp$references <- character(0)
cp$note <- character(0)
cp$examples <- character(0)
############ MAIN METHOD
mp <- promptMethods(met, NA, ...)
mp$aliases <- c(mp$aliases, rdmacro("alias", met))
mp$title <- rdmacro("title", displayName(object))
mp$keywords <- mp$keywords[1] # drop dummy keyword
mp$author <- cp$author
seealso <- paste(rdlink(role), "which delegates to this function.")
mp$seealso <- rdmacro("seealso", seealso)
############ OUTPUT
if (is.null(filename))
filename <- getwd()
if (!is.na(filename)) {
rdwrite(cp, filename, cl, "class")
rdwrite(mp, filename, met, "methods")
invisible(filename)
} else list(class = cp, method = mp)
})
# convenience wrappers
promptStage <- function(role, filename = NULL, protocols = TRUE,
where = topenv(parent.frame()), ...)
{
prompt(Stage(role), filename, protocols = protocols, where = where, ...)
}
promptProtocol <- function(role, method, filename = NULL,
where = topenv(parent.frame()), ...)
{
prompt(Protocol(role, method), filename, where = where, ...)
}
# utils
rdmacro <- function(name, args)
paste(paste("\\", name, "{", args, "}", sep = ""), collapse = "\n")
rdlink <- function(to) rdmacro("code", rdmacro("link", to))
rdwrite <- function(prompt, dir, name, suffix)
{
filebase <- paste(paste(name, suffix, sep = "-"), "Rd", sep = ".")
if (!is.null(dir))
filepath <- file.path(dir, filebase)
else filepath <- filebase
writeLines(unlist(prompt), filepath)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.