# == title
# Produce a function which can get or set global options
#
# == param
# -... specification of options, see 'details' section
#
# == detail
# The function has a short name `set_opt`.
#
# The most simple way is to construct an option function (e.g. ``opt()``) as:
#
# opt = set_opt(
# "a" = 1,
# "b" = "text"
# )
#
# Then users can get or set the options by
#
# opt()
# opt("a")
# opt$a
# opt[["a"]]
# opt(c("a", "b"))
# opt("a", "b")
# opt("a" = 2)
# opt$a = 2
# opt[["a"]] = 2
# opt("a" = 2, "b" = "new_text")
#
# Options can be reset to their default values by:
#
# opt(RESET = TRUE)
#
# The value for each option can be set as a list which contains more configurations of the option:
#
# opt = set_opt(
# "a" = list(.value = 1,
# .length = 1,
# .class = "numeric",
# .validate = function(x) x > 0)
# )
#
# The different fields in the list can be used to filter or validate the option values.
#
# -``.value`` The default value.
# -``.length`` The valid length of the option value. It can be a vector, the check will be passed if one of the length fits.
# -``.class`` The valid class of the option value. It can be a vector, the check will be passed if one of the classes fits.
# -``.validate`` Validation function. The input parameter is the option value and should return a single logical value.
# -``.failed_msg`` Once validation failed, the error message that is printed.
# -``.filter`` Filtering function. The input parameter is the option value and it should return a filtered option value.
# -``.read.only`` Logical. The option value can not be modified if it is set to ``TRUE``.
# -``.visible`` Logical. Whether the option is visible to users.
# -``.private`` Logical. The option value can only be modified in the same namespace where the option function is created.
# -``.synonymous`` a single option name which should have been already defined ahead of current option. The option specified will be shared by current option.
# -``.description`` a short text for describing the option. The description is only used when printing the object.
#
# For more detailed explanation, please go to the vignette.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# opt = set_opt(
# a = 1,
# b = "text"
# )
# opt
# # for more examples, please go to the vignette
setGlobalOptions = function(...) {
# the environment where the function is called
envoking_env = parent.frame()
args = list(...)
if(any(is.null(names(args))) || any(names(args) == "")) {
stop("You should provide named arguments.")
}
if("RESET" %in% names(args)) {
stop("Don't use 'RESET' as the option name.")
}
if("READ.ONLY" %in% names(args)) {
stop("Don't use 'READ.ONLY' as the option name.")
}
if("LOCAL" %in% names(args)) {
stop("Don't use 'LOCAL' as the option name.")
}
if("ADD" %in% names(args)) {
stop("Don't use 'ADD' as the option name.")
}
add_opt = function(arg, name, envoking_env, calling_ns = NULL) {
if(is.list(arg)) {
if(".synonymous" %in% names(arg)) {
if(is.null(options[[ arg[[".synonymous"]] ]])) {
stop(paste0("Option ", arg[[".synonymous"]], " has not been created yet."))
}
opt = options[[ arg[[".synonymous"]] ]]
return(opt)
}
}
# if it is an advanced setting
if(is.list(arg) && length(setdiff(names(arg), c(".value", ".class", ".length", ".validate", ".failed_msg", ".filter", ".read.only", ".private", ".visible", ".description"))) == 0) {
default_value = arg[[".value"]]
length = if(is.null(arg[[".length"]])) numeric(0) else arg[[".length"]]
class = if(is.null(arg[[".class"]])) character(0) else arg[[".class"]]
if(is.null(arg[[".validate"]])) {
validate = function(x) TRUE
} else {
if(is.function(arg[[".validate"]])) {
validate = arg[[".validate"]]
} else {
stop(paste("'.validate' field in", name, "should be a function.\n"))
}
}
failed_msg = ifelse(is.null(arg[[".failed_msg"]]), "Your option is invalid.", arg[[".failed_msg"]][1])
if(is.null(arg[[".filter"]])) {
filter = function(x) x
} else {
if(is.function(arg[[".filter"]])) {
filter = arg[[".filter"]]
} else {
stop(paste("'.filter' field in", name, "should be a function.\n"))
}
}
read.only = ifelse(is.null(arg[[".read.only"]]), FALSE, arg[[".read.only"]])
private = ifelse(is.null(arg[[".private"]]), FALSE, arg[[".private"]])
visible = ifelse(is.null(arg[[".visible"]]), TRUE, arg[[".visible"]])
description = ifelse(is.null(arg[[".description"]]), "", arg[[".description"]])
} else {
if(is.list(arg) &&
length(intersect(names(arg), c(".value", ".class", ".length", ".validate", "failed_msg", ".filter", ".read.only", ".private", ".visible", ".synonymous", ".description"))) > 0 &&
length(setdiff(names(arg), c(".value", ".class", ".length", ".validate", "failed_msg", ".filter", ".read.only", ".private", ".visible", ".synonymous", ".description"))) > 0) {
warning(paste("Your definition for '", name, "' is mixed. It should only contain\n.value, .class, .length, .validate, .failed_msg, .filter, .read.only, .private, .visible, .synonymous, .description. Ignore the setting and use the whole list as the default value.\n", sep = ""))
}
default_value = arg
length = numeric(0)
class = character(0)
validate = function(x) TRUE
failed_msg = "Your option is invalid."
filter = function(x) x
read.only = FALSE
private = FALSE
visible = TRUE
description = ""
}
opt = GlobalOption$new(
name = name,
default_value = default_value,
value = default_value,
length = length,
class = class,
validate = validate,
failed_msg = failed_msg,
filter = filter,
read.only = read.only,
private = private,
visible = visible,
description = description,
"__generated_namespace__" = topenv(envoking_env))
if(!is.null(calling_ns)) {
opt$set(default_value, calling_ns)
} else {
opt$set(default_value, calling_ns, initialize = TRUE)
}
return(opt)
}
# format the options
options = vector("list", length = length(args))
opt_names = names(args)
names(options) = opt_names
for(i in seq_along(args)) {
options[[i]] = add_opt(args[[i]], opt_names[i], envoking_env)
}
local_options = NULL
local_options_start_env = NULL
opt_fun = function(..., RESET = FALSE, READ.ONLY = NULL, LOCAL = FALSE, ADD = FALSE) {
# the environment where foo.options() is called
calling_ns = topenv(parent.frame()) # top package where foo.options() is called
e = environment()
if(!missing(LOCAL) && !LOCAL) {
local_options_start_env <<- NULL
local_options <<- NULL
options = options
# cat("enforce to be global mode.\n")
return(invisible(NULL))
} else if(LOCAL) {
# check whether there is already local_options initialized
if(is.null(parent.env(e)$local_options_start_env)) {
local_options_start_env <<- parent.frame() # parent envir is where opt_fun is called
local_options <<- lapply(options, function(opt) opt$copy())
} else if(!is.parent.frame(parent.env(e)$local_options_start_env, parent.frame())) {
local_options_start_env <<- parent.frame() # parent envir is where opt_fun is called
local_options <<- lapply(options, function(opt) opt$copy())
}
options = local_options
# cat("under local mode: ", get_env_str(local_options_start_env), "\n")
return(invisible(NULL))
} else {
# if local_options_start_env exists, it probably in local mode
if(!is.null(parent.env(e)$local_options_start_env)) {
# if calling frame is offspring environment of local_options_start_env
if(identical(parent.env(e)$local_options_start_env, parent.frame())) {
options = local_options
# cat("in a same environment, still under local mode.\n")
} else if(is.parent.frame(parent.env(e)$local_options_start_env, parent.frame())) {
options = local_options
# cat("in child environment, still under local mode.\n")
} else {
local_options_start_env <<- NULL
local_options <<- NULL
under_local_mode = FALSE
options = options
# cat("leave the local mode, now it is global mode.\n")
}
} else {
options = options
# cat("under global mode.\n")
}
}
if(RESET) {
for(i in seq_along(options)) {
options[[i]]$reset(calling_ns)
}
return(invisible(NULL))
}
args = list(...)
# input value is NULL
if(length(args) == 1 && is.null(names(args)) && is.null(args[[1]])) {
return(NULL)
}
# if settings are stored in one object and send this object
if(length(args) == 1 && is.list(args[[1]]) && is.null(names(args))) {
args = args[[1]]
}
# refresh all
# lapply(options[intersect(names(args), names(options))], function(opt) opt$refresh())
# getting all options
if(length(args) == 0 && ADD) {
return(invisible(NULL))
}
if(length(args) == 0) {
opts = lapply(options, function(opt) opt$get(calling_ns, read.only = READ.ONLY))
# some NULL are valid value, some NULL means do not output this option
opts = opts[sapply(opts, function(opt) is.null(attr(opt, "not_available")))]
return(opts)
}
# getting part of the options
if(is.null(names(args)) && ADD) {
return(invisible(NULL))
}
if(is.null(names(args))) {
args = unlist(args)
if(length(setdiff(args, names(options)))) {
stop(paste("No such option(s):", paste(setdiff(args, names(options)), collapse = "")))
}
opts = lapply(options[args], function(opt) opt$get(calling_ns, read.only = READ.ONLY, enforce_visible = TRUE))
opts = opts[sapply(opts, function(opt) is.null(attr(opt, "not_available")))]
if(length(args) == 1) {
opts = opts[[1]]
}
return(opts)
}
# set the options
name = names(args)
option.names = names(options)
if(any(name == "")) {
stop("When setting options, all arguments should be named.")
} else {
# first check on copy
for(i in seq_along(args)) {
# if there are names which are not defined in options, create one
if(sum(name[i] %in% option.names) == 0) {
if(ADD) {
options[[ name[i] ]] <<- add_opt(args[[ name[i] ]], name[i], envoking_env, calling_ns)
} else {
stop(paste("No such option: '", name[i], "'.\nIf you want to add this new option, please use your_opt_fun(", name[i], " = ..., ADD = TRUE)", sep = ""))
}
} else {
# user's value
value = args[[ name[i] ]]
options[[ name[i] ]]$set(value, calling_ns)
}
}
}
return(invisible(NULL))
}
class(opt_fun) = "GlobalOptionsFun"
return(opt_fun)
}
# == title
# Print the GlobalOptionsFun object
#
# == param
# -x the option object returned by `set_opt` or `setGlobalOptions`.
# -... other arguments
#
# == author
# z.gu@dkfz.de
#
print.GlobalOptionsFun = function(x, ...) {
lt = x()
options = get("options", envir = environment(x))
options = options[names(lt)]
option = names(options)
value = sapply(options, function(opt) value2text(opt$real_value, width = Inf))
description = sapply(options, function(opt) opt$description)
option_max_width = max(nchar(c("Option", option)))
value_max_width = max(nchar(c("Value", value)))
desc_max_width = max(nchar(description))
cat(" ", "Option", strrep(" ", option_max_width - 6), sep = "")
cat(" ", "Value", strrep(" ", value_max_width - 5), sep = "")
cat("\n")
cat(" ", strrep("-", option_max_width), sep = "")
cat(":", strrep("-", min( max(value_max_width + 2, desc_max_width), getOption("width") - option_max_width - 2)), sep = "")
cat("\n")
for(i in seq_along(option)) {
cat(" ", option[i], strrep(" ", option_max_width - nchar(option[i])), sep = "")
cat(" ", value[i], strrep(" ", value_max_width - nchar(value[i])), sep = "")
cat("\n")
if(description[i] != "") {
txt = paste0("(", description[i], ")")
txt = strwrap(txt, width = 0.9*getOption("width") - option_max_width + 1)
txt = paste(strrep(" ", option_max_width + 2), txt, sep = "")
txt = paste(txt, collapse = "\n")
cat(txt, sep = "")
cat("\n")
}
}
# cat(" ", strrep("-", option_max_width), sep = "")
# cat("-", strrep("-", min( max(value_max_width + 2, desc_max_width), getOption("width") - option_max_width - 2)), sep = "")
# cat("\n")
# cat(" Use `", opt_nm, "$opt_name` or `", opt_nm, "[['opt_name']]` to retrieve the value.\n", sep = "")
# cat(" Use `", opt_nm, "$opt_name = value` or `", opt_nm, "[['opt_name']] = value` to set the value.\n", sep = "")
}
# == title
# Get a single GlobalOption object
#
# == param
# -x the option object returned by `set_opt` or `setGlobalOptions`.
# -nm a single name of the option.
#
# == details
# This function is only used internally.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# opt = set_opt(a = 1, b = "b")
# opt["a"]
# opt["b"]
"[.GlobalOptionsFun" = function(x, nm) {
options = get("options", envir = environment(x))
if(length(nm) > 1) {
stop("The index can only be length of 1.\n")
}
options[[nm]]
}
# == title
# Print all fields of a single option
#
# == param
# -opt the option object returned by `set_opt` or `setGlobalOptions`.
# -opt_name a single name of the option.
#
# == details
# Actually this function is identical to ``opt[opt_name]``.
#
# == author
# z.gu@dkfz.de
#
# == example
# opt = set_opt(a = 1, b = "b")
# dump_opt(opt, "a")
# dump_opt(opt, "b")
dump_opt = function(opt, opt_name) {
if(length(opt_name) > 1) {
stop("The option name can only be length of 1.\n")
}
opt[opt_name]
}
# == title
# Get option value by subset operator
#
# == param
# -x the option object returned by `set_opt` or `setGlobalOptions`.
# -nm a single option name.
#
# == details
# ``opt[["a"]]`` is same as ``opt("a")`` or ``opt$a``.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# opt = set_opt(a = 1)
# opt[["a"]]
"[[.GlobalOptionsFun" = function(x, nm) {
if(is.numeric(nm)) {
stop("The index should only be option name.\n")
}
if(length(nm) > 1) {
stop("The index can only be length of 1.\n")
}
x(nm)
}
# == title
# Set option value by subset operator
#
# == param
# -x the option object returned by `set_opt` or `setGlobalOptions`.
# -nm a single option name.
# -value the value which is assigned to the option.
#
# == details
# ``opt[["a"]] = 1`` is same as ``opt("a" = 1)`` or ``opt$a = 1``.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# opt = set_opt(a = 1)
# opt[["a"]] = 2
# opt$a
"[[<-.GlobalOptionsFun" = function(x, nm, value) {
if(is.numeric(nm)) {
stop("The index should only be option names.\n")
}
if(length(nm) > 1) {
stop("The index can only be length of 1.\n")
}
lt = list(value)
names(lt) = nm
assign(".__temp_opt__.", x, envir = parent.frame())
do.call(".__temp_opt__.", lt, envir = parent.frame())
rm(".__temp_opt__.", envir = parent.frame())
return(x)
}
# == title
# Option names
#
# == param
# -x the option object returned by `set_opt` or `setGlobalOptions`.
#
# == value
# A vector of option names
#
# == example
# opt = set_opt(
# a = 1,
# b = "text"
# )
# names(opt)
names.GlobalOptionsFun = function(x) {
names(x())
}
# == title
# The .DollarNames method for the GlobalOptionsFun class
#
# == param
# -x the object returned by `set_opt` or `setGlobalOptions`.
# -pattern pattern, please ignore it.
#
# == details
# This makes the option object looks like a list that it allows
# option name completion after ``$``.
#
# == author
# z.gu@dkfz.de
#
.DollarNames.GlobalOptionsFun = function(x, pattern = "") {
lt = x()
names(lt)
}
# == title
# Produce a function which can get or set global options
#
# == param
# -... all go to `setGlobalOptions`
#
# == details
# This is just a short name for `setGlobalOptions`.
#
# == author
# z.gu@dkfz.de
set_opt = function(...) {}
set_opt = setGlobalOptions
env2txt = function(env) {
if(identical(env, emptyenv())) {
return("R_EmptyEnv")
} else if(identical(env, .GlobalEnv)){
return("R_GlobalEnv")
} else if(isNamespace(env)) {
return(getNamespaceName(env))
} else if(!is.null(attr(env, "name"))) {
return(attr(env, "name"))
} else {
return(get_env_str(env))
}
}
insertEnvBefore = function(fun, e) {
oe = environment(fun) # where `fun` is defined
environment(fun) = e
parent.env(e) = oe
return(fun)
}
deleteEnvBefore = function(fun) {
environment(fun) = parent.env(environment(fun))
return(fun)
}
print_env_stack = function(e, depth = Inf) {
if(is.function(e)) {
env = environment(e)
} else {
env = e
}
i_depth = 0
while(!identical(env, emptyenv()) && i_depth < depth) {
cat(env2txt(env), "\n")
env = parent.env(env)
i_depth = i_depth + 1
}
}
is.parent.env = function(p, e) {
while(1) {
e = parent.env(e)
if(identical(e, emptyenv())) {
return(FALSE)
}
if(identical(p, e)) {
return(TRUE)
}
}
return(FALSE)
}
is.parent.frame = function(p, e) {
if(identical(p, e)) {
return(FALSE)
}
i = 1 + 1
while(!is_top_env(e)) {
e = parent.frame(n = i)
if(identical(p, e)) {
return(TRUE)
}
i = i + 1
}
return(FALSE)
}
is_top_env = function(e) {
if(identical(e, .GlobalEnv)) {
return(TRUE)
} else if(isNamespace(e)) {
return(TRUE)
} else {
return(FALSE)
}
}
# with_sink is copied from testthat package
with_sink = function (connection, code, ...) {
sink(connection, ...)
on.exit(sink())
code
}
get_env_str = function(env) {
temp = file()
with_sink(temp, print(env))
output <- paste0(readLines(temp, warn = FALSE), collapse = "\n")
close(temp)
return(output)
}
stop = function(msg) {
base::stop(paste(strwrap(msg), collapse = "\n"), call. = FALSE)
}
warning = function(msg) {
base::warning(paste(strwrap(msg), collapse = "\n"), call. = FALSE)
}
# == title
# Get option value by dollar symbol
#
# == param
# -x the object returned by `set_opt` or `setGlobalOptions`.
# -nm a single option name.
#
# == details
# ``opt$a`` is same as ``opt("a")``.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# opt = set_opt(a = 1)
# opt$a
"$.GlobalOptionsFun" = function(x, nm) {
x(nm)
}
# == title
# Set option value by dollar symbol
#
# == param
# -x the object returned by `set_opt` or `setGlobalOptions`.
# -nm a single option name.
# -value the value which is assigned to the option.
#
# == details
# ``opt$a = 1`` is same as ``opt("a" = 1)``.
#
# Note you cannot reconfigurate the option by assigning a configuration list.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# opt = set_opt(a = 1)
# opt$a = 2
# opt$a
"$<-.GlobalOptionsFun" = function(x, nm, value) {
lt = list(value)
names(lt) = nm
assign(".__temp_opt__.", x, envir = parent.frame())
do.call(".__temp_opt__.", lt, envir = parent.frame())
rm(".__temp_opt__.", envir = parent.frame())
return(x)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.