src/library/utils/R/widgets.R

#  File src/library/utils/R/widgets.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

select.list <-
    function(choices, preselect = NULL, multiple = FALSE, title = NULL,
             graphics = getOption("menu.graphics"))
{
    if(!interactive()) stop("select.list() cannot be used non-interactively")
    if(!is.null(title) && (!is.character(title) || length(title) != 1))
        stop("'title' must be NULL or a length-1 character vector")
    if(isTRUE(graphics)) {
        if (.Platform$OS.type == "windows" || .Platform$GUI == "AQUA")
        return(.External2(C_selectlist, choices, preselect, multiple, title))
        ## must be Unix here
        ## Tk might not require X11 on macOS, but if DISPLAY is set
        ## this will work for Aqua Tcl/Tk.
        ## OTOH, we do want to check Tk works!
        else if(graphics && capabilities("tcltk") &&
                capabilities("X11") && suppressWarnings(tcltk::.TkUp))
            return(tcltk::tk_select.list(choices, preselect, multiple, title))
    }
    ## simple text-based alternatives.
    if(!multiple) {
        res <- menu(choices, FALSE, title)
        if(res < 1L || res > length(choices)) return("")
        else return(choices[res])
    } else {
        nc <- length(choices)
        if (length(title) && nzchar(title[1L]))
            cat(title, "\n", sep = "")
        def <- if(is.null(preselect)) rep.int(FALSE, nc)
        else choices %in% preselect
        op <- paste0(format(seq_len(nc)), ": ",
                     ifelse(def, "+", " "), " ", choices)
        if(nc > 10L) {
            fop <- format(op)
            nw <- nchar(fop[1L], "w") + 2L
            ncol <- getOption("width") %/% nw
            if(ncol > 1L)
                op <- paste0(fop, c(rep.int("  ", ncol - 1L), "\n"),
                             collapse = "")
            cat("", op, sep = "\n")
        } else cat("", op, "", sep = "\n")
        cat(gettext("Enter one or more numbers separated by spaces, or an empty line to cancel\n"))
	repeat {
            res <- tryCatch(scan("", what = 0, quiet = TRUE, nlines = 1),
                            error = identity)
	    if(!inherits(res, "error")) break
	    cat(gettext("Invalid input, please try again\n"))
	}
        if(!length(res) || (length(res) == 1L && !res[1L])) return(character())
        res <- sort(res[1 <= res && res <= nc])
        return(choices[res])
    }
}

flush.console <- function() invisible(.Call(C_flushconsole))

process.events <- function() invisible(.Call(C_processevents))