Nothing
#########################################################################/**
# @RdocClass Options
#
# @title "The Options class"
#
# @synopsis
#
# \arguments{
# \item{options}{A tree @list structure of options.}
# \item{...}{Not used.}
# }
#
# \description{
# @classhierarchy
#
# A class to set and get either options stored in a @list tree structure.
#
# Each option has a pathname. The format of a pathname is similar to a
# (Unix) filesystem pathname, e.g. "graphics/cex". See examples for
# more details.
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \value{
# The constructor returns an Options object.
# }
#
# \details{
# Note, this class and its methods do \emph{not} operate on the global
# options structure defined in \R (\link{options}).
# }
#
# @examples "../incl/Options.Rex"
#
# @author
#
# @keyword programming
#*/#########################################################################
setConstructorS3("Options", function(options=list(), ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'options':
if (!is.list(options))
throw("Argument 'options' must be a list: ", mode(options))
extend(Object(), "Options",
.options = options
)
})
###########################################################################/**
# @RdocMethod "as.character"
#
# @title "Returns a character string version of this object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns a @character string.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("as.character", "Options", function(x, ...) {
# To please R CMD check
this <- x
s <- paste(class(this)[1], ": ", nbrOfOptions(this), " options set.", sep="")
s
})
#########################################################################/**
# @RdocMethod as.list
#
# @title "Gets a list representation of the options"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns a tree @list structure.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("as.list", "Options", function(x, ...) {
# To please R CMD check
this <- x
as.list(this$.options)
})
#########################################################################/**
# @RdocMethod equals
#
# @title "Checks if this object is equal to another Options object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{other}{Another Options object.}
# \item{...}{Not used.}
# }
#
# \value{Returns @TRUE if they are equal, otherwise @FALSE.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("equals", "Options", function(this, other, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
equals.list <- function(list1, list2) {
if (length(list1) != length(list2))
return(FALSE)
for (kk in seq_along(list1)) {
obj1 <- list1[[kk]]
obj2 <- list2[[kk]]
if (is.list(obj1)) {
comp <- equals.list(obj1, obj2)
} else {
comp <- equals(obj1, obj2)
}
if (!comp)
return(comp)
} # for (kk ...)
TRUE
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Main comparison
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (!inherits(other, "Options"))
return(FALSE)
list1 <- as.list(this)
list2 <- as.list(other)
equals.list(list1, list2)
})
###########################################################################/**
# @RdocMethod str
#
# @title "Prints the structure of the options"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{header}{A @character string header to be printed at the top.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("str", "Options", function(object, header=paste(class(this)[1], ":\n", sep=""), ...) {
# To please R CMD check
this <- object
cat(header)
res <- list()
for (name in names(this))
res[[name]] <- getOption(this, name)
str(res)
})
#########################################################################/**
# @RdocMethod names
#
# @title "Gets the full pathname of all (non-list) options"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns a @vector of @character strings.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("names", "Options", function(x, ...) {
# To please R CMD check
this <- x
names(getLeaves(this, ...))
})
#########################################################################/**
# @RdocMethod getLeaves
#
# @title "Gets all (non-list) options in a flat list"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns a flat @list structure.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("getLeaves", "Options", function(this, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
getLeaves <- function(list, ...) {
if (length(list) == 0)
return(NULL)
names <- names(list)
isList <- unlist(lapply(list, FUN=is.list))
leafs <- list[!isList]
trees <- list[isList]
treeNames <- names(trees)
for (kk in seq_along(trees)) {
tree <- trees[[kk]]
treeName <- treeNames[kk]
treeLeaves <- getLeaves(tree, ...)
names(treeLeaves) <- paste(treeName, names(treeLeaves), sep="/")
leafs <- c(leafs, treeLeaves)
}
leafs
}
getLeaves(as.list(this))
})
#########################################################################/**
# @RdocMethod nbrOfOptions
#
# @title "Gets the number of options set"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns an @integer.}
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("nbrOfOptions", "Options", function(this, ...) {
length(names(this))
})
#########################################################################/**
# @RdocMethod hasOption
#
# @title "Checks if an option exists"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{A single or a @vector of @character strings specifying
# the paths to the options to be queried.}
# \item{...}{Not used.}
# }
#
# \value{Returns a @logical (@vector).}
#
# @author
#
# \seealso{
# @seemethod "getOption".
# @seemethod "setOption".
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("hasOption", "Options", function(this, pathname, ...) {
if (length(pathname) > 1) {
res <- c()
for (kk in seq_along(pathname))
res[kk] <- hasOption(this, pathname[kk])
names(res) <- pathname
return(res)
}
# Argument 'pathname':
pathname <- as.character(pathname)
if (length(pathname) != 1) {
throw("Argument 'pathname' must be a single character string: ",
paste(pathname, collapse=", "))
}
if (regexpr("\\.", pathname) != -1) {
throw("Argument 'pathname' must not contain a period: ", pathname)
}
pathname <- unlist(strsplit(pathname, split="/"))
if (any(nchar(pathname, type="chars") == 0))
throw("Argument 'pathname' contains a zero length elements.")
cur <- as.list(this)
if (length(cur) == 0)
return(FALSE)
depth <- length(pathname)
for (kk in seq_len(depth)) {
key <- pathname[kk]
keys <- names(cur)
if (key %in% keys) {
cur <- cur[[key]]
if (kk == depth)
return(TRUE)
} else {
return(FALSE)
}
if (!is.list(cur))
break
}
FALSE
})
#########################################################################/**
# @RdocMethod getOption
#
# @title "Gets an option"
#
# \description{
# @get "title" in the options tree structure or return a default value.
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{A single or a @vector of @character strings specifying
# the paths to the options to be queried.
# By default the complete options structure is returned.}
# \item{defaultValue}{The default value to be returned, if option is
# missing. If multiple options are queried at the same times, multiple
# default values may be specified as a @vector or a @list.}
# \item{...}{Not used.}
# }
#
# \value{If a single option is queried, a single value is returned.
# If a @vector of options are queried, a @list of values are returned.
# For non-existing options, the default value is returned.}
#
# @author
#
# \seealso{
# @seemethod "hasOption".
# @seemethod "setOption".
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("getOption", "Options", function(this, pathname=NULL, defaultValue=NULL, ...) {
if (length(pathname) > 1) {
defaultValue <- rep(defaultValue, length.out=length(pathname))
res <- list()
for (kk in seq_along(pathname))
res[[kk]] <- getOption(this, pathname[kk], defaultValue[kk])
names(res) <- pathname
return(res)
}
if (is.null(pathname))
return(as.list(this))
# Argument 'pathname':
pathname <- as.character(pathname)
if (length(pathname) != 1) {
throw("Argument 'pathname' must be a single character string: ",
paste(pathname, collapse=", "))
}
# if (regexpr("\\.", pathname) != -1) {
# throw("Argument 'pathname' must not contain a period: ", pathname)
# }
pathname <- unlist(strsplit(pathname, split="/"))
if (any(nchar(pathname, type="chars") == 0))
throw("Argument 'pathname' contains a zero length elements.")
cur <- as.list(this)
if (length(pathname) == 0)
return(cur)
if (length(cur) == 0)
return(defaultValue)
depth <- length(pathname)
for (kk in seq_len(depth)) {
key <- pathname[kk]
keys <- names(cur)
if (key %in% keys) {
cur <- cur[[key]]
if (kk == depth)
return(cur)
} else {
return(defaultValue)
}
if (!is.list(cur))
break
}
defaultValue
})
#########################################################################/**
# @RdocMethod setOption
#
# @title "Sets an option"
#
# \description{
# @get "title" in the options tree structure.
# }
#
# @synopsis
#
# \arguments{
# \item{pathname}{A single @character string specifying the path to the
# option.}
# \item{value}{The value to be assigned to the option.}
# \item{overwrite}{If @TRUE, already existing options are overwritten,
# otherwise not.}
# \item{...}{Not used.}
# }
#
# \value{Returns (invisibly) the old option value.}
#
# @author
#
# \seealso{
# @seemethod "hasOption".
# @seemethod "setOption".
# @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("setOption", "Options", function(this, pathname, value, overwrite=TRUE, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local functions
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
setOptionList <- function(list, path, value) {
if (length(path) == 1) {
list[[path]] <- value
} else {
name <- path[1]
if (!is.list(list[[name]]))
list[[name]] <- list()
list[[name]] <- setOptionList(list[[name]], path[-1], value)
}
list
} # setOptionList()
# Argument 'pathname':
pathname <- as.character(pathname)
if (length(pathname) != 1) {
throw("Argument 'pathname' must be a single character string: ",
paste(pathname, collapse=", "))
}
# if (regexpr("\\.", pathname) != -1) {
# throw("Argument 'pathname' must not contain a period: ", pathname)
# }
oldValue <- getOption(this, pathname)
# If option is already set, should it be overwritten.
if (!is.null(oldValue) && !overwrite)
return(invisible(oldValue))
pathname <- unlist(strsplit(pathname, split="/"))
if (any(nchar(pathname, type="chars") == 0))
throw("Argument 'pathname' contains a zero length elements.")
if (is.null(this$.options))
this$.options <- list()
this$.options <- setOptionList(this$.options, pathname, value)
invisible(oldValue)
})
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.