The R Project SVN R

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

tk_select.list <-
    function(choices, preselect = NULL, multiple = FALSE, title = NULL)
{
    have_ttk <- as.character(tcl("info", "tclversion")) >= "8.5"
    if(!have_ttk) ttkbutton <- tkbutton
    lvar <- tclVar()
    tclObj(lvar) <- choices
    oldmode <- tclServiceMode(FALSE)
    dlg <- tktoplevel()
    tkwm.title(dlg, title)
    tkwm.deiconify(dlg)
    tkgrab.set(dlg)
    tkfocus(dlg)
    if(!is.null(title) && nzchar(title)) {
        lab <- if(have_ttk) ttklabel(dlg, text = title, foreground = "blue")
        else tklabel(dlg, text = title, fg = "blue")
        tkpack(lab, side="top")
    }
    onOK <- function() {
        res <- 1L + as.integer(tkcurselection(box))
        ans.select_list <<- choices[res]
        tkgrab.release(dlg)
        tkdestroy(dlg)
    }
    onCancel <- function() {
        tkgrab.release(dlg)
        tkdestroy(dlg)
    }
    buttons <- tkframe(dlg)
    tkpack(buttons, side="bottom")
    OK <- ttkbutton(buttons, text = gettext("OK"), width = 6, command = onOK)
    Cancel <- ttkbutton(buttons, text = gettext("Cancel"), command = onCancel)
    tkpack(OK, Cancel, side="left", fill="x", padx="2m")

    scht <- as.numeric(tclvalue(tkwinfo("screenheight", dlg))) - 200L
    ## allow for win furniture and buttons, and for e.g. KDE panel
    ht <- min(length(choices), scht %/% 20) # a guess of font height
    s_mode <- if(multiple) "multiple" else "single"
    box <- tklistbox(dlg, height = ht,
                     listvariable = lvar, bg = "white", setgrid = 1,
                     selectmode = s_mode)
    tmp <- tcl("font", "metrics", tkcget(box, font=NULL))
    ## fudge factor here seems to be 1 on Windows, 3 on X11.
    tmp <- as.numeric(sub(".*linespace ([0-9]+) .*", "\\1", tclvalue(tmp)))+3
    ht <- min(length(choices), scht %/% tmp)
    tkdestroy(box)
    if(ht < length(choices)) {
        scr <- if(have_ttk) ttkscrollbar(dlg, command = function(...) tkyview(box, ...))
        else tkscrollbar(dlg, repeatinterval=5, command = function(...) tkyview(box, ...))
        box <- tklistbox(dlg, height = ht, width = 0,
                         listvariable = lvar, bg = "white", setgrid = 1,
                         selectmode = s_mode,
                         yscrollcommand = function(...)tkset(scr,...))
        tkpack(box, side="left", fill="both", expand=TRUE)
        tkpack(scr, side="right", fill="y")
    } else {
        box <- tklistbox(dlg, height = ht, width = 0,
                         listvariable = lvar, bg = "white",
                         selectmode = s_mode)
        tkpack(box, side="left", fill="both")
    }
    preselect <- match(preselect, choices)
    preselect <- preselect[preselect > 0L] - 1L # 0-based
    if(length(preselect)) {
        for(i in preselect) tkselection.set(box, i)
        ## ensure first (and usally only) pre-selection is visible
        tkyview(box, preselect[1L])
    }

    ans.select_list <- character() # avoid name conflicts
    tkbind(dlg, "<Destroy>", onCancel)
    tkbind(box, "<Double-ButtonPress-1>", onOK)
    tkfocus(box)
    tclServiceMode(oldmode)
    tkwait.window(dlg)
    Sys.sleep(0.1) # allow time for window to be removed.
    if(!multiple && !length(ans.select_list)) ans.select_list <- ""
    ans.select_list
}

tkProgressBar <- function(title = "R progress bar", label = "",
                          min = 0, max = 1, initial = 0, width = 300)
{
    useText <- FALSE
    have_ttk <- as.character(tcl("info", "tclversion")) >= "8.5"
    if(!have_ttk && as.character(tclRequire("PBar")) == "FALSE") useText <- TRUE


    .win <- tktoplevel()
    .val <- initial
    .killed <- FALSE

    tkwm.geometry(.win, sprintf("%dx80", width+40))
    tkwm.title(.win, title)
    fn <- tkfont.create(family="helvetica", size=12)

    if(useText) {
        ## currently unused
        .lab <- tklabel(.win, text=label, font=fn, padx=20)
        tkpack(.lab, side = "left")
        fn2 <- tkfont.create(family="helvetica", size=16)
       .vlab <- tklabel(.win, text="0%", font=fn2, padx=20)
        tkpack(.vlab, side = "right")
        up <- function(value) {
            if(!is.finite(value) || value < min || value > max) return()
            .val <<- value
             tkconfigure(.vlab,
                         text=sprintf("%d%%",
                         round(100*(value - min)/(max - min))))
        }
    } else {
        .lab <- tklabel(.win, text=label, font=fn, pady=10)
       .tkval <- tclVar(0)
        tkpack(.lab, side="top")
        tkpack(tklabel(.win, text="", font = fn), side="bottom")

        pBar <- if(have_ttk) ttkprogressbar(.win, length=width, variable=.tkval) else tkwidget(.win, "ProgressBar", width=width, variable=.tkval)
        tkpack(pBar, side="bottom")
        up <- function(value) {
            if(!is.finite(value) || value < min || value > max) return()
            .val <<- value
            tclvalue(.tkval) <<- 100*(value - min)/(max - min)
        }
    }
    getVal <- function() .val
    kill <- function() if(!.killed) {tkdestroy(.win); .killed <<- TRUE}
    title <- function(title) tkwm.title(.win, title)
    lab <- function(label) tkconfigure(.lab, text=label)
    tkbind(.win, "<Destroy>", kill)
    up(initial)

    structure(list(getVal=getVal, up=up, title=title, label=lab, kill=kill),
              class = "tkProgressBar")
}

getTkProgressBar <- function(pb)
{
    if(!inherits(pb, "tkProgressBar"))
        stop(gettextf("'pb' is not from class %s",
                      dQuote("tkProgressBar")),
             domain = NA)
    pb$getVal()
}

setTkProgressBar <- function(pb, value, title = NULL, label = NULL)
{
    if(!inherits(pb, "tkProgressBar"))
        stop(gettextf("'pb' is not from class %s",
                      dQuote("tkProgressBar")),
             domain = NA)
    oldval <- pb$getVal()
    pb$up(value)
    if(!is.null(title)) pb$title(title)
    if(!is.null(label)) pb$label(label)
    tcl("update", "idletasks")
    invisible(oldval)
}

close.tkProgressBar <- function(con, ...)
{
    con$kill()
    invisible(NULL)
}

tk_choose.files <-
    function(default = '', caption = 'Select files', multi = TRUE,
             filters = NULL, index = 1)
{
    args <- list("tk_getOpenFile", title = caption, multiple = multi)
    if(nzchar(default)) args <- c(args, initialdir = dirname(default),
                                   initialfile = basename(default))
    if(!is.null(filters)) {
        if(!is.character(filters) || length(dim(filters)) != 2 || ncol(filters) != 2)
            stop("'filters' must be a 2-column character matrix")
        f <- filters
        f[] <- paste0("{", filters, "}")
        ff <- apply(f, 1, paste, collapse = " ")
        fff <- paste0("{", ff, "}")
        args <- c(args, filetypes = paste(fff, collapse = " "))
    }
    ## Be careful here: If multi is FALSE, tk_getOpenFile() returns a single unquoted string
    ## which is interpreted as a list by as.character() if it contains spaces.
    res <- do.call(tcl, args)
    if (multi)
        as.character(res)
    else {
        res <- tclvalue(res)
        if(nzchar(res)) res else character(0)
    }
}


tk_choose.dir <- function(default = '', caption = 'Select directory')
{
    res <- tclvalue(tcl("tk_chooseDirectory", initialdir = default, title = caption))
    if(nzchar(res)) res else NA_character_
}

tk_messageBox <-
    function(type = c("ok", "okcancel", "yesno", "yesnocancel",
                      "retrycancel", "abortretryignore"),
             message, caption = "", default = "", ...)
{
    type <- match.arg(type)
    args <- list("tk_messageBox", type=type, message=message,
                 title=caption, ...)
    if(nzchar(default)) args <- c(args, default=default)
    tclvalue(do.call("tcl", args))
}

## aadded for R 3.2.0, enhanced for R 4.6.0
##tclVersion <- function() as.character(tcl("info", "patchlevel"))

tclVersion <- function(with_patchlevel = FALSE)
{
    if(isTRUE(with_patchlevel)) as.character(tcl("info", "patchlevel"))
    else as.character(tcl("info", "tclversion"))
}