Nothing
# == title
# Wrapper of the Perl module ``Getopt::Long`` in R
#
# == param
# -... Specification of options. The value can be a two-column matrix, a vector with even number of elements
# or a text template. See the vignette for detailed explanation.
# -help_head Head of the help message when invoking ``Rscript foo.R --help``.
# -help_foot Foot of the help message when invoking ``Rscript foo.R --help``.
# -envir User's enrivonment where `GetoptLong` looks for default values and exports variables.
# -argv_str A string that contains command-line arguments. It is only for testing purpose.
# -template_control A list of parameters for controlling when the specification is a template.
# -help_style The style of the help messages. Value should be either "one-column" or "two-column".
#
# == details
# Following shows a simple example. Put following code at the beginning of your script (e.g. ``foo.R``):
#
# library(GetoptLong)
#
# cutoff = 0.05
# GetoptLong(
# "number=i", "Number of items.",
# "cutoff=f", "Cutoff for filtering results.",
# "verbose", "Print message."
# )
#
# Then you can call the script from command line either by:
#
# Rscript foo.R --number 4 --cutoff 0.01 --verbose
# Rscript foo.R --number 4 --cutoff=0.01 --verbose
# Rscript foo.R -n 4 -c 0.01 -v
# Rscript foo.R -n 4 --verbose
#
# In this example, ``number`` is a mandatory option and it should only be in
# integer mode. ``cutoff`` is optional and it already has a default value 0.05.
# ``verbose`` is a logical option. If parsing is successful, two variables ``number``
# and ``verbose`` will be imported into the working environment with the specified
# values. Value for ``cutoff`` will be updated if it is specified in command-line.
#
# For advanced use of this function, please go to the vignette.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
GetoptLong = function(..., help_head = NULL, help_foot = NULL, envir = parent.frame(),
argv_str = NULL, template_control = list(),
help_style = GetoptLong.options$help_style) {
if(is.null(get_scriptname())) {
IS_UNDER_COMMAND_LINE = FALSE
} else {
IS_UNDER_COMMAND_LINE = TRUE
}
if(is.null(argv_str)) {
argv_str = GetoptLong.options("__argv_str__")
}
on.exit(GetoptLong.options("__argv_str__" = NULL))
# to test whether the script is run under command-line or in R interactive environment
if(IS_UNDER_COMMAND_LINE || is.null(argv_str)) {
OUT = stderr()
} else {
OUT = stdout() # message from STDOUT is important under testing mode
}
############### parse specification ##################
spec = list(...)
# a vector or a two-column matrix
if(length(spec) == 1) {
spec = spec[[1]]
} else {
spec = unlist(spec)
}
# check first argument
# it should be a matrix with two columns or a vector with even number of elements
template = NULL
if(is.matrix(spec)) {
if(ncol(spec) != 2) {
stop_wrap("If your specification is a matrix, it should be a two-column matrix.")
}
} else {
if(is.vector(spec)) {
if(length(spec) == 1) {
template = spec
template = gsub("^\\n", "", template)
spec = parse_spec_template(spec)
if(nrow(spec) == 0) {
stop_wrap("Cannot detect option specification in the template.")
}
} else if(length(spec) %% 2) {
stop_wrap("Since your specification is a vector, it should have even number of elements.")
} else {
spec = matrix(spec, ncol = 2, byrow = TRUE)
}
} else {
stop_wrap("Wrong specification.")
}
}
##### extract specification for hash
l_sub_opt = grepl("\\w+\\$\\S+$", spec[, 1])
hash_sub_opt = spec[l_sub_opt, , drop = FALSE]
spec = spec[!l_sub_opt, , drop = FALSE]
spec[, 1] = gsub("\\s*", "", spec[, 1])
#### convert hash_sub_opt into a list
sub_opt = NULL
if(sum(l_sub_opt)) {
sub_opt = lapply(split(seq_len(nrow(hash_sub_opt)), gsub("\\$.*$", "", hash_sub_opt[, 1])), function(ind) {
nm = apply(hash_sub_opt[ind, , drop = FALSE], 1, function(x) {
gsub("^.*?\\$", "", x[1])
})
structure(hash_sub_opt[ind, 2], names = nm)
})
}
### opt groups
l_opt_group = grepl("^[-=\\+#%]*$", spec[, 1])
if(any(l_opt_group)) {
i_opt = 0
i_group = 0
opt_group = list()
opt_group_desc = NULL
if(!l_opt_group[1]) {
opt_group[[1]] = list()
opt_group_desc = ""
i_group = 1
}
for(i in seq_along(l_opt_group)) {
if(l_opt_group[i]) {
i_group = i_group + 1
opt_group[[i_group]] = list()
opt_group_desc = c(opt_group_desc, spec[i, 2])
} else {
i_opt = i_opt + 1
opt_group[[i_group]] = c(opt_group[[i_group]], i_opt)
}
}
spec = spec[!l_opt_group, , drop = FALSE]
} else {
opt_group = list(1:nrow(spec))
opt_group_desc = "Options:"
}
if(is.list(envir)) envir = as.environment(envir)
############### construct a list of SingleOption objects ####################
opt_lt = list()
for(i in seq_len(nrow(spec))) {
opt_lt[[i]] = SingleOption(spec = spec[i, 1], desc = spec[i, 2], envir = envir)
}
names(opt_lt) = sapply(opt_lt, function(x) x$name)
if("help" %in% names(opt_lt)) {
stop_wrap("`help` is reserved as a default option. Please do not use it.")
}
if("version" %in% names(opt_lt)) {
stop_wrap("`version` is reserved as a default option. Please do not use it.")
}
opt_lt$help = SingleOption(spec = "help", "Print help message and exit.")
opt_lt$version = SingleOption(spec = "version", "Print version information and exit.")
n_opt = length(opt_lt)
opt_group[[length(opt_group)]] = c(opt_group[[length(opt_group)]], n_opt - 1, n_opt)
if(!is.null(sub_opt)) {
for(i in seq_len(n_opt)) {
if(opt_lt[[i]]$name %in% names(sub_opt) && opt_lt[[i]]$var_type == "hash") {
opt_lt[[i]]$sub_opt = sub_opt[[ opt_lt[[i]]$name ]]
}
}
}
## add short opt name
first_letter = lapply(opt_lt, function(opt) {
full_opt = opt$full_opt
substr(full_opt, 1, 1)
})
first_letter_tb = table(unlist(first_letter))[unique(unlist(first_letter))]
first_letter_unique = names(first_letter_tb[first_letter_tb == 1])
for(le in first_letter_unique) {
ind = which(sapply(first_letter, function(x) any(x == le)))
opt_lt[[ind]]$full_opt = unique(c(opt_lt[[ind]]$full_opt, le))
}
# get the path of binary perl
# it will look in PATH and also user's command-line argument
perl_bin = find_perl_bin(con = OUT, from_command_line = IS_UNDER_COMMAND_LINE)
# check whether Getopt::Long is in @INC
# normally, it is shippped with standard Perl distributions
if(!check_perl("Getopt::Long", perl_bin = perl_bin)) {
cat(red("Error: Cannot find Getopt::Long module in your Perl library.\n"), file = OUT)
if(IS_UNDER_COMMAND_LINE) {
q(save = "no", status = 127)
} else if(!is.null(argv_str)) { # under test
return(invisible(NULL))
} else {
stop("You have an error.\n")
}
}
# check whether JSON is in @INC
if(!check_perl("JSON", inc = qq("@{system.file('extdata', package='GetoptLong')}/perl_lib"), perl_bin = perl_bin)) {
cat(red("Error: Cannot find JSON module in your Perl library.\n"), file = OUT)
if(IS_UNDER_COMMAND_LINE) {
q(save = "no", status = 127)
} else if(!is.null(argv_str)) { # under test
return(invisible(NULL))
} else {
stop("You have an error.\n")
}
}
json_file = tempfile(fileext = ".json")
perl_script = generate_perl_script(opt_lt, json_file)
# get arguments string
if(is.null(argv_str)) {
ARGV = commandArgs(TRUE)
ARGV_string = reformat_argv_string(opt_lt, ARGV)
} else {
if(grepl("'|\\\"", argv_str)) {
ARGV_string = argv_str
} else {
ARGV_string = reformat_argv_string(opt_lt, strsplit(argv_str, "\\s+")[[1]])
}
}
cmd = qq("\"@{perl_bin}\" \"@{perl_script}\" @{ARGV_string}");
res = system(cmd, intern = TRUE)
res = as.vector(res)
script_name = NULL
# if you specified wrong arguments
if(length(res)) {
cat(red(qq("Error: @{res}\n")), file = OUT)
print_help_msg(opt_lt, file = OUT, script_name = script_name, head = help_head, foot = help_foot,
template = template, template_control = template_control, style = help_style,
opt_group = opt_group, opt_group_desc = opt_group_desc)
suppressWarnings({
file.remove(json_file)
file.remove(perl_script)
})
if(IS_UNDER_COMMAND_LINE) {
q(save = "no", status = 127)
} else if(!is.null(argv_str)) { # under test
return(invisible(NULL))
} else {
stop("You have an error.\n")
}
}
# if arguments are correct, values for options will be stored in .json file
opt_json = fromJSON(file = json_file)
suppressWarnings({
file.remove(json_file)
file.remove(perl_script)
})
for(opt_name in names(opt_json)) {
opt = opt_lt[[opt_name]]
opt$set_opt(opt_json[[opt_name]])
opt_lt[[opt_name]] = opt
}
## logical options always have values no matter they are specified or not
## reset the value to NULL if they are not specified.
for(opt_name in names(opt_json)) {
opt = opt_lt[[opt_name]]
if(opt$opt_type == "negatable_logical") {
if(!negatable_logical_is_called(opt_name, ARGV_string)) {
opt$set_opt(NULL)
}
}
}
if(opt_json$help) {
print_help_msg(opt_lt, file = stdout(), script_name = script_name, head = help_head, foot = help_foot,
template = template, template_control = template_control, style = help_style,
opt_group = opt_group, opt_group_desc = opt_group_desc)
if(IS_UNDER_COMMAND_LINE) {
q(save = "no", status = 0)
} else if(!is.null(argv_str)) { # under test
return(invisible(NULL))
} else {
stop("You have an error.\n")
}
}
if(opt_json$version) {
print_version_msg(envir, file = stdout())
if(IS_UNDER_COMMAND_LINE) {
q(save = "no", status = 0)
} else if(!is.null(argv_str)) { # under test
return(invisible(NULL))
} else {
stop("You have an error.\n")
}
}
# check mandatory options
for(opt_name in names(opt_json)) {
if(!opt_lt[[opt_name]]$validate_mandatory(opt_json[[opt_name]])) {
cat(red(qq("Error: `@{opt_name}` is mandatory\n")), file = OUT)
print_help_msg(opt_lt, file = OUT, script_name = script_name, head = help_head, foot = help_foot,
template = template, template_control = template_control, style = help_style,
opt_group = opt_group, opt_group_desc = opt_group_desc)
if(IS_UNDER_COMMAND_LINE) {
q(save = "no", status = 127)
} else if(!is.null(argv_str)) { # under test
return(invisible(NULL))
} else {
stop_wrap("You have an error.\n")
}
}
}
export_to_parent_frame(opt_lt, envir = envir)
return(invisible(opt_lt))
}
# test whether long_name is called in argv_str
# negatable_logical_is_called("verbose", "--verbose")
# negatable_logical_is_called("verbose", "-verbose")
# negatable_logical_is_called("verbose", "--v")
# negatable_logical_is_called("verbose", "-v")
# negatable_logical_is_called("verbose", "--no-verbose")
negatable_logical_is_called = function(long_name, argv_str) {
argv = strsplit(argv_str, " ")[[1]]
argv = argv[grepl("^-", argv)]
if(length(argv)) {
argv = gsub("^-+", "", argv)
if(any(sapply(argv, function(x) grepl(qq("^@{x}"), long_name)))) {
return(TRUE)
} else {
any(sapply(argv, function(x) grepl(qq("(no-?)?@{long_name}$"), x)))
}
} else {
return(FALSE)
}
}
# == title
# Wrapper of the Perl module ``Getopt::Long`` in R
#
# == param
# -... Pass to `GetoptLong`.
# -envir User's enrivonment where `GetoptLong` looks for default values and exports variables.
#
# == details
# This function is the same as `GetoptLong`. It is just to make it consistent as the ``GetOptions()``
# subroutine in ``Getopt::Long`` module in Perl.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
GetOptions = function(..., envir = parent.frame()) GetoptLong(..., envir = envir)
export_to_parent_frame = function(opt_lt, envir = parent.frame()) {
n = length(opt_lt)
for(i in seq_len(n)) {
opt = opt_lt[[i]]
if(opt$name %in% c("help", "version")) {
next
}
if(!is.null(opt$value)) {
v = opt$value
assign(opt$name, v, envir = envir)
}
}
return(invisible(NULL))
}
# == title
# File name of current script
#
# == value
# If the R script is not run from the command-line, it returns ``NULL``.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
get_scriptname = function() {
args = commandArgs()
if(length(args) == 1) {
return(NULL)
}
f = grep("^--file=", args, value = TRUE)
if(length(f)) {
f = gsub("^--file=(.*)$", "\\1", f[1])
return(f)
} else {
return(GetoptLong.options("__script_name__"))
}
}
# == title
# Directory of current script
#
# == value
# If the R script is not run from the command-line, it returns ``NULL``.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
get_scriptdir = function() {
args = commandArgs()
f = grep("^--file=", args, value = TRUE)
if(length(f)) {
f = gsub("^--file=(.*)$", "\\1", f[1])
return(dirname(normalizePath(f)))
} else {
return(NULL)
}
}
# == title
# Source the R script with command-line arguments
#
# == param
# -file The R script
# -... Pass to `base::source`.
# -argv_str The command-line arguments.
#
source_script = function(file, ..., argv_str = NULL) {
GetoptLong.options("__argv_str__" = argv_str)
GetoptLong.options("__script_name__" = file)
on.exit({
GetoptLong.options("__script_name__" = NULL)
GetoptLong.options("__argv_str__" = NULL)
})
base::source(file, ...)
}
source = function (file, ..., argv = NULL) {
GetoptLong.options(`__argv_str__` = argv)
GetoptLong.options(`__script_name__` = file)
on.exit({
GetoptLong.options(`__script_name__` = NULL)
GetoptLong.options(`__argv_str__` = NULL)
})
base::source(file, ...)
}
parse_spec_template = function(template, match = GetoptLong.options("template_tag")) {
lt = find_code(match, template)
spec = cbind(lt$code, rep("", length(lt$code)))
spec = spec[!grepl("^#", spec[, 1]), ,drop = FALSE]
return(spec)
}
## careful when ARGV_string is --a '1 2 3' where '1, 2, 3' should not be split
reformat_argv_string = function(opt_lt, argv) {
current_tag = NA
tag_increment = 0
argv2 = NULL
for(i in seq_along(argv)) {
if(grepl("^(-|\\+)", argv[i])) {
current_tag = argv[i]
tag_increment = 0
argv2 = c(argv2, argv[i])
} else {
tag_increment = tag_increment + 1
if(tag_increment == 1) argv2 = c(argv2, argv[i])
}
if(tag_increment >= 2) {
opt = look_up_opt_by_tag(opt_lt, current_tag)
if(is.null(opt)) {
argv2 = c(argv2, argv[i])
} else {
if(grepl("(@|%)$", opt$spec)) {
argv2 = c(argv2, qq("--@{opt$name}"), argv[i])
} else {
argv2 = c(argv2, argv[i])
}
}
}
}
argv2 = sapply(argv2, function(x) {
if(grepl(" ", x)) {
x = paste0("'", x, "'")
} else {
x
}
})
paste(argv2, collapse = " ")
}
look_up_opt_by_tag = function(opt_lt, tag) {
tag = gsub("^(-|--|\\+)", "", tag)
ind = NULL
for(i in seq_along(opt_lt)) {
opt = opt_lt[[i]]
if(tag %in% opt$full_opt) {
ind = c(ind, i)
} else if(any(grepl(qq("^@{tag}"), opt$full_opt))) {
ind = c(ind, i)
}
}
if(length(ind) != 1) {
return(NULL)
} else {
return(opt_lt[[ind]])
}
}
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.