R/SingleOption-class.R

In jokergoo/GetoptLong: Parsing Command-Line Arguments and Simple Variable Interpolation

SingleOption = setRefClass("SingleOption",
    fields = list(
    	"name" = "character",
    	"spec" = "character",
    	"desc" = "character",
    	"full_opt" = "character",
    	"has_default" = "logical",
    	"is_mandatory" = "logical",
    	"value" = "ANY",
    	"default" = "ANY",
    	"var_type" = "character",
    	"opt_type" = "character",
    	"sub_opt" = "ANY"
    )
)

DEFAULT_OPTIONS = c("help", "version")

SingleOption$methods(
	initialize = function(spec, desc = "", envir = parent.frame(4), ...) {
		obj = callSuper(...)
		full_opt_names = extract_opt_name(spec)
		opt_name = full_opt_names[1]
		
		if(!grepl("^[a-zA-Z_\\.][a-zA-Z0-9_\\.]*$", opt_name)) {
			stop_wrap("Option name in option (@{spec}) can only be a valid R variable name which only uses numbers, letters,'.' and '_' (It should match /^[a-zA-Z_\\.][a-zA-Z0-9_\\.]+$/).")
		}
	
		obj$name = opt_name
		obj$spec = spec
		obj$full_opt = full_opt_names
		obj$value = NULL
		obj$desc = desc
		if(grepl("^\\s*$", obj$desc)) obj$desc = "No description is provided."

		obj$is_mandatory = detect_mandatory_on_spec(spec)

		if(detect_optional_on_spec(spec)) {
			stop_wrap("type :[isfo] is not allowed, use =[isfo] instead.")
		}

		obj$var_type = detect_var_type(spec) # scalar/array/hash
		obj$opt_type = detect_opt_type(spec) # character/integer/numeric/logical/negatable_logical

		obj$has_default = FALSE
		obj$is_mandatory = TRUE
		obj$default = NULL
		obj$sub_opt = NULL

		# assign defaults
		if(exists(opt_name, envir = envir, inherits = FALSE)) {
			v = get(opt_name, envir = envir, inherits = FALSE)
			if(is.function(v)) {
				obj$has_default = FALSE
				obj$is_mandatory = TRUE
				obj$default = NULL
			} else {
				obj$has_default = TRUE
				obj$default = v
				obj$is_mandatory = FALSE
			}
		}

		if(obj$opt_type == "negatable_logical") {
			if(!obj$has_default) {
				obj$has_default = TRUE
				obj$default = FALSE
				obj$is_mandatory = FALSE
			}
		} else if(obj$opt_type == "logical") {
			if(obj$has_default) {
				message_wrap(qq("The default of `@{opt_name}` is ignored unless the specification is set as '@{opt_name}!'. Reset it to FALSE."))
			}
			obj$has_default = TRUE
			obj$default = FALSE
			obj$is_mandatory = FALSE
		}

		## check the format of the default value
		v = obj$default
		if(obj$has_default && !obj$name %in% DEFAULT_OPTIONS) {
			if(!is.null(v)) {
				if(obj$opt_type == "logical") {
					
				} else if(obj$opt_type == "negatable_logical") {
					if(!(identical(v, TRUE) || identical(v, FALSE))) {
						if(is.atomic(v) && is.vector(v)) {
							if(length(v) > 1) {
								obj$default = TRUE
							} else if(length(v) == 1 ) {
								if(is.na(v)) {
									obj$default = FALSE
								} else if(is.numeric(v)) {
									obj$default = as.logical(v)
								} else if(is.character(v)) {
									if(grepl("^\\s*$", v)) {
										obj$default = FALSE
									} else {
										obj$default = TRUE
									}
								} else {
									obj$default = FALSE
								}
							} else {
								obj$default = FALSE
							}
						} else {
							if(length(v) > 1) {
								obj$default = TRUE
							} else {
								obj$default = FALSE
							}
						} 
						message_wrap(qq("The default of `@{opt_name}` should be a logical scalar. Reset `@{opt_name}` as @{obj$default}."))
					}
				} else if(obj$var_type == "scalar") {
					if(length(v) != 1) {
						stop_wrap(qq("`@{opt_name}` is set as a scalar. The length of the default must be 1."))
					}
					if(!(is.atomic(v) && is.vector(v))) {
						stop_wrap(qq("`@{opt_name}` is set as a scalar. The value of the default should be an atomic scalar."))
					}
					if(obj$opt_type %in% c("integer", "numeric")) {
						if(is.na(v) && !is.numeric(v)) {
							if(.self$opt_type == "integer") {
								v = NA_integer_
							} else {
								v = NA_real_
							}
							.self$default = v
						}
						if(!is.numeric(v)) {
							stop_wrap(qq("`@{opt_name}` is set in integer/numeric. The value of the default must be number."))
						}
					}
					if(obj$opt_type == "character") {
						if(is.na(v) && !is.character(v)) {
							v = NA_character_
							.self$default = v
						}
						if(!is.character(v)) {
							stop_wrap(qq("`@{opt_name}` is set in character. The value of the default must be a character."))
						}
					}
				} else if(obj$var_type == "array") {
					if(!(is.atomic(v) && is.vector(v))) {
						stop_wrap(qq("`@{opt_name}` is set as an array. The value of the default should be an atomic vector"))
					}
					if(obj$opt_type %in% c("integer", "numeric")) {
						if(!is.numeric(v)) {
							stop_wrap(qq("`@{opt_name}` is set in integer/numeric. The value of the default must be number."))
						}
					}
					if(obj$opt_type == "character") {
						if(!is.character(v)) {
							stop_wrap(qq("`@{opt_name}` is set in character. The value of the default must be a character."))
						}
					}
				} else if(obj$var_type == "hash") {
					if(!is.list(v)) {
						stop_wrap(qq("`@{opt_name}` is set as a hash (name-value pairs). The value of the default should be a list."))
					}
					if(is.null(names(v))) {
						stop_wrap(qq("`@{opt_name}` is set as a hash (name-value pairs). The value of the default should be a named list."))
					}
					for(i in seq_along(v)) {
						if(!(is.atomic(v[[i]]) && is.vector(v[[i]]))) {
							stop_wrap(qq("`@{opt_name}` is set as an hash (name-value pairs). The value of the default should be an atomic vector."))
						}
						if(obj$opt_type %in% c("integer", "numeric")) {
							if(!is.numeric(v[[i]])) {
								stop_wrap(qq("`@{opt_name}` is set in integer/numeric. The value of the default must be number."))
							}
						}
						if(obj$opt_type == "character") {
							if(!is.character(v[[i]])) {
								stop_wrap(qq("`@{opt_name}` is set in character. The value of the default must be a character."))
							}
						}
					}
				}
			}
		}

		return(obj)
	}
)

SingleOption$methods(
	set_opt = function(v) {
		if(.self$var_type == "hash") {
			if(.self$has_default) {
				old_nm = setdiff(names(.self$default), names(v))
				v = c(v, .self$default[old_nm])
			}
		}
		.self$value = v
	}
)

SingleOption$methods(
	validate_mandatory = function(v) {
		if(missing(v)) v = .self$value
		if(is.null(v)) {
			if(.self$is_mandatory) {
				return(FALSE)
			}
		}
		TRUE
	}
)

SingleOption$methods(
	help_message = function(prefix = "  ", width = GetoptLong.options$help_width, 
		which = c("opt_line", "desc_line"), data_type = TRUE) {

		msg = ""

		if("opt_line" %in% which) {
			opt_line = NULL
			for(nm in .self$full_opt) {
				if(nchar(nm) == 1) {
					opt_line = c(opt_line, qq("-@{nm}"))
				} else {
					opt_line = c(opt_line, paste0("--", gsub("(?<=\\w)_(?=\\w)", "-", nm, perl = TRUE)))
				}
			}
			opt_line = paste(opt_line, collapse = ", ")
			opt_line = paste0(prefix, opt_line)

			# data type
			if(data_type) {
				if(.self$var_type == "scalar") {
					if(.self$opt_type == "logical") {

					} else if(.self$opt_type == "negatable_logical") {
						opt_line = paste0(opt_line, ", -no-", gsub("(?<=\\w)_(?=\\w)", "-", .self$name, perl = TRUE))
					} else {
						opt_line = paste0(opt_line, " ", .self$opt_type)
					}
				} else if(.self$var_type == "array") {
					opt_line = paste0(opt_line, " ", qq("[@{.self$opt_type}, ...]"))
				} else if(.self$var_type == "hash") {
					opt_line = paste0(opt_line, " ", qq("{name=@{.self$opt_type}, ...}"))
				}
			}
			msg = paste0(msg, opt_line, "\n")
		}

		if("desc_line" %in% which) {
			desc_line = format_text(.self$desc, prefix = prefix, width = width)

			msg = paste0(msg, desc_line, "\n")
			default_str = .self$default_as_string()
			if(!is.null(default_str)) {
				msg = paste0(msg, prefix, "  ", "[default: ", default_str, "]\n")
			}

			abbr = c("character" = "chr", "integer" = "int", "extended_integer" = "int", "numeric" = "num")

			if(.self$var_type == "hash") {
				if(!is.null(.self$sub_opt)) {
					sub_opt_line = paste0("\n", prefix, "  Sub named options:\n")
					so = .self$sub_opt
					for(nm in names(so)) {
						str1 = paste0(prefix, "  ", nm, qq("=@{.self$opt_type}"))
						str2 = format_text(so[nm], prefix = paste0(prefix, strrep(" ", nchar(str1) + 1 - nchar(prefix) - 2)))
						substr(str2, 1, nchar(str1)) = str1
						sub_opt_line = paste0(sub_opt_line, str2, "\n")
					}

					msg = paste0(msg, sub_opt_line)
				}
			}
		}

		return(msg)
	}
)

SingleOption$methods(
	help_message_two_columns = function(prefix = "  ", only_opt = FALSE, opt_width = NULL,
		width = max(GetoptLong.options$help_width, opt_width + 60)) {
		
		opt_line = NULL
		for(nm in .self$full_opt) {
			if(nchar(nm) == 1) {
				opt_line = c(opt_line, qq("-@{nm}"))
			} else {
				opt_line = c(opt_line, paste0("--", gsub("(?<=\\w)_(?=\\w)", "-", nm, perl = TRUE)))
			}
		}
		opt_line = paste(opt_line, collapse = ", ")
		opt_line = paste0(prefix, opt_line)

		abbr = c("character" = "chr", "integer" = "int", "extended_integer" = "int", "numeric" = "num")

		if(.self$var_type == "scalar") {
			if(.self$opt_type == "logical") {

			} else if(.self$opt_type == "negatable_logical") {
				opt_line = paste0(opt_line, ", -no-", gsub("(?<=\\w)_(?=\\w)", "-", .self$name, perl = TRUE))
			} else {
				opt_line = c(opt_line, paste0(prefix, "  [type: ", abbr[.self$opt_type], "]"))
			}
		} else if(.self$var_type == "array") {
			opt_line = c(opt_line, paste0(prefix, "  [type: ", qq("[@{abbr[.self$opt_type]}, ...]"), "]"))
		} else if(.self$var_type == "hash") {
			opt_line = c(opt_line, paste0(prefix, "  [type: ", qq("{name=@{abbr[.self$opt_type]}, ...}"), "]"))
		}
		
		if(only_opt) {
			return(opt_line)
		}

		prefix2 = strrep(" ", opt_width + 2)
		desc_line = format_text(.self$desc, prefix = prefix2, width = width)

		default_str = .self$default_as_string()
		if(!is.null(default_str)) {
			desc_line = paste0(desc_line, prefix2, "\n", prefix2, "  ", "[default: ", default_str, "]")
		}

		if(.self$var_type == "hash") {
			if(!is.null(.self$sub_opt)) {
				sub_opt_line = paste0(prefix2, "\n", prefix2, "  Sub named options:\n")
				so = .self$sub_opt
				for(nm in names(so)) {
					str1 = paste0(prefix2, "  ", nm, qq("=@{abbr[.self$opt_type]}"))
					str2 = format_text(so[nm], prefix = paste0(prefix2, strrep(" ", nchar(str1) + 1 - nchar(prefix2) - 2)))
					substr(str2, 1, nchar(str1)) = str1
					sub_opt_line = paste0(sub_opt_line, str2, "\n")
				}
				desc_line = paste0(desc_line, prefix2, "\n", sub_opt_line, "\n")
			}
		}

		desc_line = strsplit(desc_line, "\n")[[1]]

		n1 = length(opt_line)
		n2 = length(desc_line)
		msg = character(max(n1, n2))
		for(i in seq_along(msg)) {
			if(i <= n1 && i <= n2) {
				msg[i] = desc_line[i]
				substr(msg[i], 1, nchar(opt_line[i])) = opt_line[i]
			} else if(i > n1) {
				msg[i] = desc_line[i]
			} else if(i > n2) {
				msg[i] = opt_line[i]
			}
		}

		paste(msg, collapse = "\n")

	}
)

SingleOption$methods(
	default_as_string = function() {
		if(.self$has_default) {
			if(.self$opt_type == "logical") {
				return(NULL)
			} else if(.self$opt_type == "negatable_logical") {
				if(.self$default) {
					return("on")
				} else {
					return("off")
				}
			} else if(.self$var_type == "scalar") {
				if(is.null(.self$default)) {
					return("NULL")
				} else {
					return(as.character(.self$default))
				}
			} else if(.self$var_type == "array") {
				if(is.null(.self$default)) {
					return("NULL")
				} else {
					return(paste(.self$default, collapse = ", "))
				}
			} else if(.self$var_type == "hash") {
				if(is.null(.self$default)) {
					return("NULL")
				} else {
					return(paste(names(.self$default), .self$default, sep = "=", collapse = ", "))
				}
			}
		} else {
			return(NULL)
		}
	}
)