The R Project SVN R

#  File src/library/utils/R/windows/winDialog.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2017 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/

winDialog <- function(type = c("ok", "okcancel", "yesno", "yesnocancel"),
                       message)
{
    if (!interactive())
        stop("winDialog() cannot be used non-interactively")
    type <- match.arg(type)
    res <- .External2(C_winDialog, type, message)
    if(res == 10L) return(invisible(NULL))
    c("NO", "CANCEL", "YES", "OK")[res+2L]
}

winDialogString <- function(message, default)
{
    if (!interactive())
        stop("winDialogString() cannot be used non-interactively")
    .External2(C_winDialogString, message, default)
}

winMenuDel <- function(menuname)
    invisible(.External2(C_winMenuDel, menuname, NULL))

winMenuDelItem <- function(menuname, itemname)
    invisible(.External2(C_winMenuDel, menuname, itemname))

winMenuAdd <- function(menuname)
    invisible(.External2(C_winMenuAdd, menuname, NULL, NULL))

winMenuAddItem <- function(menuname, itemname, action) {
    ## If specified menu does not exist, add it
    if (! menuname %in% winMenuNames()) winMenuAdd(menuname)

    invisible(.External2(C_winMenuAdd, menuname, itemname, action))
}

winMenuNames <- function() .External2(C_winMenuNames)

winMenuItems <- function(menuname) .External2(C_winMenuItems, menuname)

## There is internal coercion, but using as.xxx here allows method dispatch
winProgressBar <- function(title = "R progress bar", label = "",
                           min = 0, max = 1, initial = 0, width = 300L)
{
    res <- .External2(C_winProgressBar, as.integer(width), as.character(title),
                      as.character(label), as.double(min),
                      as.double(max), as.double(initial))
    structure(list(pb=res), class = "winProgressBar")
}

close.winProgressBar <- function(con, ...)
    .External2(C_closeWinProgressBar, con$pb)

setWinProgressBar <- function(pb, value, title=NULL, label=NULL)
{
    if(!inherits(pb, "winProgressBar"))
       stop(gettextf("'pb' is not from class %s",
                     dQuote("winProgressBar")),
            domain = NA)
    if(!is.null(title)) title <- as.character(title)
    if(!is.null(label)) label <- as.character(label)
    invisible(.External2(C_setWinProgressBar, pb$pb, as.double(value),
                         title, label))
}

getWinProgressBar <- function(pb)
{
    if(!inherits(pb, "winProgressBar"))
        stop(gettextf("'pb' is not from class %s",
                      dQuote("winProgressBar")),
             domain = NA)
    .External2(C_setWinProgressBar, pb$pb, NULL, NULL, NULL)
}

# Windows Rgui setup will set this as the askYesNo option

askYesNoWinDialog <- function(msg, ...) {
    flush.console() # so warning is seen
    ans <- winDialog("yesnocancel", msg)
    switch(ans,
            YES = TRUE,
            NO  = FALSE,
            NA)
}