GetoptLong.R

parseSpec <- function(spec) {
    vars <- strsplit(spec, "\\|")[[1]]
    if (any(grepl("\\s", vars))) {
        stop()
    }
    #lastvar <- sub("([^=:]+)([=:])?", "\\1 \\2 ", vars[length(vars)])
    lastvar <- sub("([^=:]+)(=)?", "\\1 \\2 ", vars[length(vars)])
    lastvar.elems <- strsplit(lastvar, " ")[[1]]
    strlen <- nchar(lastvar.elems[1])
    if (substring(lastvar.elems[1], strlen) %in% c("!", "+")) {
        opt.class <- substring(lastvar.elems[1], strlen)
        vars[length(vars)] <- substr(lastvar.elems[1], 1, strlen - 1)
    } else {
        vars[length(vars)] <- lastvar.elems[1]
    }
    if (lastvar.elems[2] != "" && (lastvar.elems[3] == "" || lastvar.elems[3] %in% c("!", "+"))) {
        stop()
    }
    if (length(lastvar.elems) == 3) {
        opt.class <- lastvar.elems[3]
    } else if (!exists("opt.class")) {
        opt.class <- "l"
    }

    if (!grepl("^[filos+!][@%]?$", opt.class)) {
        stop()
    }

    ret <- rep(opt.class, length(vars))
    names(ret) <- vars
    return(ret)
}

checkType <- function(value, opt.class) {
    type <- substr(opt.class, 1, 1)
    if (type == "i" && grepl("^[+-]?\\d+$", value)) {
        value <- as.numeric(value)
    } else if (type == "f" && grepl("^[+-]?(?:\\d+(?:\\.?\\d*)|\\d*(?:\\.\\d+))$", value)) {
        value <- as.numeric(value)
    } else if (type == "o" && grepl("^(?:0x\\d+|[+-]?(?:[1-9]\\d*(?:\\.?\\d*)|0?(?:\\.\\d+)))$", value)) {
        value <- as.numeric(value)
    } else if (type == "o" && grepl("^0\\d+$", value)) {
        value <- as.numeric(as.octmode(value))
    } else if (type == "s") {
        value <- value
    } else {
        stop()
    }

    return(value)
}

GetOptions <- function(..., opts = NULL) {
    if (length(match.call()) == 1) {
        stop("specify at least 1 argument!")
    }
    func.name <- as.character(match.call()[1])
    var.names <- as.character(match.call()[-1])  # parent.frameで代入する変数の名前
    spec <- names(substitute(list(...)))[-1]
    parsed.spec <- lapply(spec, parseSpec)  # 順番にvar.namesに対応するspec
    # 最後に指定されたものが適用されるようにrevする
    spec.list <- rev(unlist(lapply(spec, parseSpec)))
    # spec.list と var.names を対応付ける
    # (spec.list の n 番目にマッチするコマンドラインパラメータは var.names[var.spec.map[n]] に代入)
    if (is.null(opts)) {
        # opts argument is for Unit test
        opts <- commandArgs(trailingOnly = TRUE)
    } else {
        var.names <- var.names[-length(var.names)]
    }
    var.spec.map <- rev(rep(seq(length(var.names)), sapply(parsed.spec, length)))

    i <- 1
    ret <- list()
    pos <- NULL
    while (i <= length(opts)) {
        opt <- opts[i]
        opt.name <- sub("^--?([^=]+).*", "\\1", opt)
        if (opt.name == opt) {
            stop()
        }
        if (substr(opt.name, 1, 2) == "no") {
            match.pos <- which(names(spec.list) == substring(opt.name, 3))
            match.pos.no <- which(names(spec.list) == opt.name)
            if (!(length(match.pos) == 0 || (length(match.pos.no) > 0 && min(match.pos.no) < min(match.pos))) && spec.list[substring(opt.name, 3)] == "!") {
                pos <- min(which(names(spec.list) == substring(opt.name, 3)))
                #ret[[substring(opt.name, 3)]] <- FALSE
                ret[[var.names[var.spec.map[pos]]]] <- FALSE
                i <- i + 1
                next
            }
        }
        if (!(opt.name %in% names(spec.list))) {
            stop()
        }
        pos <- min(which(names(spec.list) == opt.name))
        opt.class <- spec.list[pos]
        var.name <- var.names[var.spec.map[pos]]
        if (opt.class %in% c("l", "!")) {
            ret[[var.name]] <- TRUE
        } else if (opt.class == "+") {
            ret[[var.name]] <- ifelse(is.null(ret[[var.name]]), 1, ret[[var.name]] + 1)
        } else {
            value <- sub(".*?=(.+)", "\\1", opt)
            if (value == opt) {
                # --hoge=hoge ではなく --hoge hoge という指定
                i <- i + 1
                value <- opts[i]
            }
            if (nchar(opt.class) == 1) {
                ret[[var.name]] <- checkType(value, opt.class)
            } else if (substr(opt.class, 2, 2) == "@") {
                ret[[var.name]] <- c(ret[[var.name]], checkType(value, opt.class))
            } else if (substr(opt.class, 2, 2) == "%") {
                keyvalue <- strsplit(value, "=")[[1]]
                tmp.value <- checkType(keyvalue[2], opt.class)
                names(tmp.value) <- keyvalue[1]
                ret[[var.name]] <- c(ret[[var.name]], tmp.value)
            }
        }
        i <- i + 1
    }

    for (var in names(ret)) {
        assign(var, ret[[var]], envir = parent.frame())
    }
}