# Argument.R
#' ArgumentRefClass to manage one argument
#'
#' @field name the name of the argument - typically the name provided in the argument string
#' @field flag the characater string used to search for the argument. By default
#' the name, prepended by \code{--} or \code{-}. Allowing name and flag to be different
#' is to allow the user to specify a name like 'bosworth' for an argumeent flagged as '-b'
#' @field value the parsed argument value as a list.
#' @field choices a list of allowable argument values (like having a dropdown list)
#' @field nargs the number of expected arguments, by default 1
#' @field required logical - must the user provide a value?
#' @field type charcater specifies the type of argument. Allowed values are
#' \describe{
#' \item{logical}{Explicitly set TRUE/FALSE arguments}
#' \item{set_true}{For arguments set by presence ala --plot}
#' \item{set_false}{For argument set by presence ala --no-plot}
#' \item{character}{For character arguments}
#' \item{numeric}{For numeric arguments ala integers and doubles}
#' \item{integer}{For explictly integer numerics}
#' \item{double}{For explictly double precision numerics}
#' }
#' @field action the name of a function to call with the argument
#' @field default the optional default value
#' @field help a character vector of help text
ArgumentRefClass <- setRefClass("ArgumentRefClass",
fields = list(
name = 'character',
flag = 'character',
value = 'list',
choices = 'list',
nargs = 'numeric',
required = 'logical', # by default FALSE
type = 'character', #logical, character, integer, double, numeric, set_true, set_false
action = 'ANY',
default = 'list',
help = 'character')
)
#' Parse the argument list selecting the one of interest
#'
#' @family Argument
#' @name ArgumentRefClass_parse_argument
#' @param x character argument list
#' @return logical indicating success
NULL
ArgumentRefClass$methods(
parse_argument = function(x){
parseArgument(.self, x)
})
#' Print information about the object
#'
#' @family Argument
#' @name ArgumentRefClass_show
NULL
ArgumentRefClass$methods(
show = function(){
cat(" Reference Class:", classLabel(class(.self)), "\n")
cat(" name:", .self$name, "\n")
cat(" flag:", .self$flag, "\n")
cat(" type:", .self$type, "\n")
cat(" value:", .self$value[[1]], "\n")
cat(" choices:", .self$choices[[1]], "\n")
cat(" nargs:", .self$nargs, "\n")
cat(" action:", .self$action, "\n")
cat(" help:", .self$help, "\n")
})
#' Print usage help
#'
#' @family Argument
#' @name ArgumentRefClass_print_help
NULL
ArgumentRefClass$methods(
print_help = function(){
if (.self$required){
txt <- sprintf("--%s (required, type '%s')", .self$flag, .self$type)
} else {
txt <- sprintf("--%s (type '%s')", .self$flag, .self$type)
}
cat(txt,"\n")
if ((length(.self$help) > 0) && (nchar(.self$help) > 0) ) cat(sprintf(" %s", .self$help),"\n")
if (length(.self$default) > 0) {
cat(sprintf(" %s", "default: "))
if (length(.self$default) == 1) {
cat(.self$default[[1]], "\n")
} else {
print(.self$default)
}
}
})
#' Get usage string
#'
#' @family Argument
#' @name ArgumentRefClass_get_usage
NULL
ArgumentRefClass$methods(
get_usage = function(){
sprintf("[--%s %s]", .self$flag, .self$type)
})
#' Run the 'action' function
#'
#' @family Argument
#' @name ArgumentRefClass_getAction
#' @param ... unspecified arguments
#' @return the value of the argument (type varies)
NULL
ArgumentRefClass$methods(
getAction = function(...){
if (!is.null(.self$action) && nchar(.self$action) > 0){
do.call(.self$action, list(x=.self, ...))
} else {
return(.self$value[[1]])
}
})
#' Get the value(s) of an argument
#'
#' @family Argument
#' @name ArgumentRefClass_get
#' @param ... unspecified arguments for the Argument$getAction() method
#' @return the value of the argument (type varies)
NULL
ArgumentRefClass$methods(
get = function(...){
.self$getAction(...)
})
######
# methods above, functions below
######
#' Create an Argument class object
#'
#' @family Argument
#' @export
#' @param name character name of the argument (required)
#' @param flag character the pattern used to search the argument list, by default name
#' @param choices a vector of the choices if limited to a listing
#' @param default the default value if none provided
#' @param required logical, set to TRUE is required otherwise it is optional
#' @param nargs the number of arguments (maximum)
#' @param action a function name or NULL
#' @param type character, one of the following \code{logical, character, integer, double,
#' numeric, set_true, set_false} \code{set_true} and \code{set_false} are logicals
#' based upon presence/abscence such as --plot or --no-plot Alternatively,
#' use 'logical' for "-plot TRUE" or "-plot FALSE" style booleans.
#' @param help character vector of helpful hints
#' @return an ArgumentRefClass object
Argument <- function(name,
flag = NULL,
choices = NULL,
default = NULL,
required = FALSE,
nargs = 1,
action = '',
type = 'character',
help = character()){
x <- ArgumentRefClass$new()
if (missing(name)) stop("name is required")
x$field("name", name[1])
if (is.null(flag)) flag = x$name
# be sure to strip any leading dashes
x$field("flag", gsub("^-+", "", flag))
x$field("choices", list(choices))
x$field("default", list(default))
x$field("value", list(x$default[[1]]))
x$field("required", required)
x$field("nargs", nargs)
x$field("action", action)
x$field("type", type)
x$field("help", help)
x
}
#' Parse the argument character for this Argument's value(s)
#'
#' @family Argument
#' @export
#' @param X the ArgumentRefClass object
#' @param x the argument character vector to mine for flagged value
#' @return logical indicating success/failure
parseArgument <- function(X, x){
# if flag not present and required then throw a hissy
flag <- paste0("-+",X$flag)
ix <- grep(flag, x)
if ( (length(ix) == 0) && X$required ) {
cat(paste("parseArgument: flag not found but is required", X$name), "\n")
return(FALSE)
}
# not provided? then use the default
if (length(ix) == 0) {
return(TRUE)
}
# set_true, set_false means the argument flag is the value such as
# --plot --no-plot which have no trailing value
# while others will have X$nargs trailing arguments such as
# --outfile 'myplot.pdf' which has nargs=1 trailing value
if (grepl("set_", X$type)){
arg <- x[ix[1]]
} else {
if (X$nargs < 0){
# if nargs must be guessed at then we guess the next possible flag
# NOTE we assume flags start with at least '-'
k <- grep("^-", x)
j <- k[k > ix[1]]
if (length(j) == 0) {
# if there are no further flags then we take the remainder
iy <- length(x)
} else {
# if there are further flags then we go up to but exclude that flag
iy <- j-1
}
index <- seq(from = ix[1]+1, to = iy)
} else {
# if nargs are known it is easy (unless the user messed up)
index <- seq(from = ix[1]+1, to = ix[1]+X$nargs )
}
arg <- x[index]
}
#logical, character, integer, double, numeric, set_true, set_false
value <- switch(X$type,
"logical" = (toupper(arg) %in% c("TRUE", "YES", "T", "Y")) ,
"set_true" = TRUE,
"set_false" = FALSE,
"character" = arg,
"numeric" = as.numeric(arg),
"integer" = as.integer(arg),
"double" = as.double(arg),
NULL)
if (is.null(value)) {
cat(paste("parseArgument: Error converting the value to type -", X$type))
return(FALSE)
}
if (!is.null(X$choices[[1]])) {
ix <- value %in% X$choices[[1]]
if (!any(ix)) {
cat(paste("parseArgument: value not found in choices - value=", value))
cat(paste("parseArgument: value not found in choices - choices=",
paste(X$choices[[1]], collapse = " ") ))
return(FALSE)
}
}
X$value <- list(value)
return(TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.