[Sciviews-commits] r382 - in pkg: . svDialogs svDialogs/R svDialogs/man svDialogstcltk svDialogstcltk/R svDialogstcltk/inst svDialogstcltk/man svGUI svGUI/R svGUI/man svHttp svHttp/R svHttp/inst svHttp/man svKomodo svKomodo/R svKomodo/inst svKomodo/man svMisc/R svSocket/man svWidgets tcltk2
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Aug 1 01:05:47 CEST 2011
Author: phgrosjean
Date: 2011-08-01 01:05:46 +0200 (Mon, 01 Aug 2011)
New Revision: 382
Added:
pkg/svDialogs/R/dlgDir.R
pkg/svDialogs/R/dlgInput.R
pkg/svDialogs/R/dlgList.R
pkg/svDialogs/R/dlgMessage.R
pkg/svDialogs/R/guiDlg.R
pkg/svDialogs/man/dlgDir.Rd
pkg/svDialogs/man/dlgInput.Rd
pkg/svDialogs/man/dlgList.Rd
pkg/svDialogs/man/dlgMessage.Rd
pkg/svDialogstcltk/
pkg/svDialogstcltk/DESCRIPTION
pkg/svDialogstcltk/LICENSE
pkg/svDialogstcltk/NAMESPACE
pkg/svDialogstcltk/NEWS
pkg/svDialogstcltk/R/
pkg/svDialogstcltk/R/dlgDir.tcltkWidgets.R
pkg/svDialogstcltk/R/dlgInput.tcltkWidgets.R
pkg/svDialogstcltk/R/dlgList.tcltkWidgets.R
pkg/svDialogstcltk/R/dlgMessage.tcltkWidgets.R
pkg/svDialogstcltk/R/svDialogs.tcltk-Internal.R
pkg/svDialogstcltk/TODO
pkg/svDialogstcltk/inst/
pkg/svDialogstcltk/inst/CITATION
pkg/svDialogstcltk/man/
pkg/svDialogstcltk/man/svDialogstcltk-package.Rd
pkg/svGUI/R/dontAsk.R
pkg/svGUI/R/gui.R
pkg/svGUI/R/guiAdd.R
pkg/svGUI/R/setUI.R
pkg/svGUI/man/dontAsk.Rd
pkg/svGUI/man/gui.Rd
pkg/svGUI/man/guiAdd.Rd
pkg/svGUI/man/setUI.Rd
pkg/svHttp/
pkg/svHttp/DESCRIPTION
pkg/svHttp/LICENSE
pkg/svHttp/NAMESPACE
pkg/svHttp/NEWS
pkg/svHttp/R/
pkg/svHttp/R/httpServer.R
pkg/svHttp/TODO
pkg/svHttp/inst/
pkg/svHttp/inst/CITATION
pkg/svHttp/man/
pkg/svHttp/man/httpServer.Rd
pkg/svHttp/man/svHttp-package.Rd
pkg/svKomodo/
pkg/svKomodo/DESCRIPTION
pkg/svKomodo/LICENSE
pkg/svKomodo/NAMESPACE
pkg/svKomodo/NEWS
pkg/svKomodo/R/
pkg/svKomodo/R/koCmd.R
pkg/svKomodo/R/koInstall.R
pkg/svKomodo/R/koRefresh.R
pkg/svKomodo/R/koUninstall.R
pkg/svKomodo/R/svKomodo-internal.R
pkg/svKomodo/TODO
pkg/svKomodo/inst/
pkg/svKomodo/inst/CITATION
pkg/svKomodo/man/
pkg/svKomodo/man/koCmd.Rd
pkg/svKomodo/man/koInstall.Rd
pkg/svKomodo/man/koRefresh.Rd
pkg/svKomodo/man/svKomodo-package.Rd
pkg/tcltk2/tcltk2_tk2icoReplacement.R
Removed:
pkg/svDialogs/R/fixedDlg.R
pkg/svDialogs/man/guiDlgAssistant.Rd
pkg/svDialogs/man/guiDlgColor.Rd
pkg/svDialogs/man/guiDlgDir.Rd
pkg/svDialogs/man/guiDlgDoubleList.Rd
pkg/svDialogs/man/guiDlgFont.Rd
pkg/svDialogs/man/guiDlgFormula.Rd
pkg/svDialogs/man/guiDlgGraphOptions.Rd
pkg/svDialogs/man/guiDlgGrid.Rd
pkg/svDialogs/man/guiDlgInput.Rd
pkg/svDialogs/man/guiDlgItemSel.Rd
pkg/svDialogs/man/guiDlgList.Rd
pkg/svDialogs/man/guiDlgMessage.Rd
pkg/svDialogs/man/guiDlgOpen.Rd
pkg/svDialogs/man/guiDlgOptions.Rd
pkg/svDialogs/man/guiDlgProgress.Rd
pkg/svDialogs/man/guiDlgSave.Rd
pkg/svDialogs/man/guiDlgText.Rd
pkg/svDialogs/man/guiDlgVarSel.Rd
pkg/svDialogs/man/guiDlgView.Rd
pkg/svGUI/R/guiInstall.R
pkg/svGUI/R/guiRefresh.R
pkg/svGUI/R/guiUninstall.R
pkg/svGUI/R/httpServer.R
pkg/svGUI/R/koCmd.R
pkg/svGUI/man/guiInstall.Rd
pkg/svGUI/man/guiRefresh.Rd
pkg/svGUI/man/httpServer.Rd
pkg/svGUI/man/koCmd.Rd
pkg/tcltk2/tcltk2 tk2icoReplacement.R
Modified:
pkg/svDialogs/DESCRIPTION
pkg/svDialogs/NAMESPACE
pkg/svDialogs/NEWS
pkg/svDialogs/TODO
pkg/svDialogs/man/guiDlgFunction.Rd
pkg/svDialogs/man/svDialogs-package.Rd
pkg/svGUI/DESCRIPTION
pkg/svGUI/NAMESPACE
pkg/svGUI/NEWS
pkg/svGUI/R/svGUI-internal.R
pkg/svGUI/TODO
pkg/svGUI/man/svGUI-package.Rd
pkg/svMisc/R/rmTemp.R
pkg/svSocket/man/startSocketServer.Rd
pkg/svSocket/man/svSocket-package.Rd
pkg/svWidgets/TODO
Log:
Major refactoring: svGUI function now in svHttp or svKomodo. New functions in svGUI to manage GUIs. Functions in svDialogs also changed and code placed in svDialogstcltk.
Modified: pkg/svDialogs/DESCRIPTION
===================================================================
--- pkg/svDialogs/DESCRIPTION 2011-07-26 07:22:23 UTC (rev 381)
+++ pkg/svDialogs/DESCRIPTION 2011-07-31 23:05:46 UTC (rev 382)
@@ -1,12 +1,12 @@
Package: svDialogs
Type: Package
Title: SciViews GUI API - Dialog boxes
-Depends: R (>= 2.6.0), tcltk
-Imports: svMisc
+Depends: R (>= 2.6.0), svGUI (>= 0.9-52), tcltk, svMisc
+SystemRequirements: TODO!!!
Description: Rapidly construct dialog boxes for your GUI, including an automatic
function assistant
-Version: 0.9-43
-Date: 2010-09-25
+Version: 0.9-44
+Date: 2011-07-29
Author: Philippe Grosjean
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
License: GPL-2
Modified: pkg/svDialogs/NAMESPACE
===================================================================
--- pkg/svDialogs/NAMESPACE 2011-07-26 07:22:23 UTC (rev 381)
+++ pkg/svDialogs/NAMESPACE 2011-07-31 23:05:46 UTC (rev 382)
@@ -1,30 +1,46 @@
-import(tcltk, svMisc)
+# To be eliminated, except for svGUI
+import(tcltk, svMisc, svGUI)
-export(display,
+export(
+ dlgDir,
+ dlgInput,
+ dlgList,
+ dlgMessage,
+ #dlgOpen,
+ #dlgSave,
+ # To be reworked
+ display,
guiDlg,
- guiDlgAssistant,
- guiDlgColor,
- guiDlgDir,
- guiDlgDoubleList,
- guiDlgFont,
- guiDlgFormula,
guiDlgFunction,
- guiDlgGraphOptions,
- guiDlgGrid,
- guiDlgInput,
- guiDlgItemSel,
- guiDlgList,
- guiDlgMessage,
- guiDlgOpen,
- guiDlgOptions,
- guiDlgProgress,
- guiDlgSave,
- guiDlgText,
- guiDlgVarSel,
- guiDlgView,
+ guiEval,
guiPane.tcltk,
guiPane.entry.tcltk,
guiPane.list.tcltk,
guiSetStyle.tcltk)
+# To be eliminated
S3method(display, guiDlg)
+
+S3method(dlgDir, gui)
+S3method(dlgDir, textCLI)
+S3method(dlgDir, nativeGUI)
+
+S3method(dlgInput, gui)
+S3method(dlgInput, textCLI)
+S3method(dlgInput, nativeGUI)
+
+S3method(dlgList, gui)
+S3method(dlgList, textCLI)
+S3method(dlgList, nativeGUI)
+
+S3method(dlgMessage, gui)
+S3method(dlgMessage, textCLI)
+S3method(dlgMessage, nativeGUI)
+
+#S3method(dlgOpen, gui)
+#S3method(dlgOpen, textCLI)
+#S3method(dlgOpen, nativeGUI)
+
+#S3method(dlgSave, gui)
+#S3method(dlgSave, textCLI)
+#S3method(dlgSave, nativeGUI)
Modified: pkg/svDialogs/NEWS
===================================================================
--- pkg/svDialogs/NEWS 2011-07-26 07:22:23 UTC (rev 381)
+++ pkg/svDialogs/NEWS 2011-07-31 23:05:46 UTC (rev 382)
@@ -1,5 +1,25 @@
= svDialogs News
+== Changes in svDialogs 0.9-44
+
+* The guiDlgXXX() functions are reworked into S3 methods and their interface
+ changes. To avoid any confusion, they are renamed dlgXXX().
+
+* dlgMessage() is reworked into native dialog box, but it looses a couple
+ of options during the process (title, icon, parent). The previous code is now
+ moved to svDialogs.tcltk.
+
+* dlgInput() is reworked the same way, and it looses the 'parent' argument that
+ was not implemented yet, anyway, and the 'title' argument that is now always
+ "question" in order to match winDialogString() function for Windows.
+
+* dlgList() is also refactored that way. Its interface is completely changed
+ to better match the arguments of select.list() and to make it a direct
+ replacement for that function.
+
+* dlgDir() is completely rewritten, as well as, dlgOpen() and dlgSave().
+
+
== Changes in svDialogs 0.9-43
* tcltk R package is moved from depends to imports.
Added: pkg/svDialogs/R/dlgDir.R
===================================================================
--- pkg/svDialogs/R/dlgDir.R (rev 0)
+++ pkg/svDialogs/R/dlgDir.R 2011-07-31 23:05:46 UTC (rev 382)
@@ -0,0 +1,162 @@
+## Define the S3 method
+dlgDir <- function (default = getwd(), message, ..., gui = .GUI) {
+ if (!gui$startUI("dlgDir", call = match.call(), default = default,
+ msg = "Displaying a modal dir selection dialog box",
+ msg.no.ask = "A modal dir selection dialog box was by-passed"))
+ return(invisible(gui))
+
+ ## Check and rework main arguments and place them in gui$args
+ if (!is.null(default) && !inherits(default, "character") &&
+ length(default) != 1)
+ stop("'default' must be a length 1 character string or NULL")
+ if (is.null(default)) default <- getwd()
+ if (file.exists(default)) {
+ if (!file.info(default)$isdir)
+ stop("'default' must be a directory, not a file!")
+ }
+ default <- path.expand(default)
+ ## Under Windows, it uses \\ as separator, although .Platform$file.sep
+ ## is now / (tested in R 2.11.1) => replace it
+ if (.Platform$OS.type == "windows")
+ default <- gsub("\\\\", "/", default)
+ if (missing(message) || message == "") message <- "Choose a directory" else
+ message <- paste(message, collapse = "\n")
+ gui$setUI(args = list(default = default, message = message))
+
+ ## ... and dispatch to the method
+ UseMethod("dlgDir", gui)
+}
+
+## Used to break the chain of NextMethod(), searching for a usable method
+## in the current context
+dlgDir.gui <- function (default = getwd(), message, ..., gui = .GUI) {
+ msg <- paste("No workable method available to display a dir selection dialog box using:",
+ paste(guiWidgets(gui), collapse = ", "))
+ gui$setUI(status = "error", msg = msg, widgets = "none")
+ stop(msg)
+}
+
+## The pure textual version used a fallback in case no GUI could be used
+dlgDir.textCLI <- function (default = getwd(), message, ..., gui = .GUI)
+{
+ gui$setUI(widgets = "textCLI")
+ ## Ask for the directory
+ res <- readline(paste(gui$args$message, " [", gui$args$default, "]: ",
+ sep = ""))
+ if (res == "") res <- gui$args$default else res <- res
+ ## To get the same behaviour as the GUI equivalents, we must make sure
+ ## it is a directory, or try to create it (possibly recursively, if it
+ ## does not exist). Also return absolute path
+ if (file.exists(res)) {
+ ## Check that this is a directory, not a file!
+ if (!file.info(res)$isdir) {
+ warning(res, " is not a directory")
+ res <- character(0) # Same as if the user did cancel the dialog box
+ }
+ } else {
+ ## The directory does not exists, try to create it now...
+ dir.create(res, recursive = TRUE)
+ if (!file.exists(res) || !file.info(res)$isdir) {
+ warning("Error while creating the directory ", res)
+ res <- character(0)
+ }
+ }
+ if (length(res)) res <- normalizePath(res)
+ gui$setUI(res = res, status = NULL)
+ return(invisible(gui))
+}
+
+## The native version of the input box
+dlgDir.nativeGUI <- function (default = getwd(), message, ..., gui = .GUI)
+{
+ gui$setUI(widgets = "nativeGUI")
+ ## A 'choose a directory' dialog box
+ ## It almost follows the conventions of tkchooseDirectory()
+ ## The argument default indicates the initial directory
+ ## If cancelled, then return character(0)
+ ## This dialog box is always modal
+ ##
+ ## It is a replacement for choose.dir(), tk_choose.dir() & tkchooseDirectory()
+ res <- switch(Sys.info()["sysname"],
+ Windows = .winDlgDir(gui$args$default, gui$args$message),
+ Darwin = .macDlgDir(gui$args$default, gui$args$message),
+ .unixDlgDir(gui$args$default, gui$args$message)
+ )
+
+ ## Do we need to further dispatch?
+ if (is.null(res)) NextMethod("dlgDir", gui) else {
+ gui$setUI(res = res, status = NULL)
+ return(invisible(gui))
+ }
+}
+
+## Windows version
+.winDlgDir <- function (default = getwd(), message = "")
+{
+ res <- choose.dir(default = default, caption = message)
+ if (is.na(res)) res <- character(0) else res <- gsub("\\\\", "/", res)
+ return(res)
+}
+
+## Mac OS X version
+.macDlgDir <- function (default = getwd(), message = "")
+{
+ ## Display a modal directory selector with native Mac dialog box
+ if (.Platform$GUI == "AQUA") app <- "(name of application \"R\")" else
+ app <- "\"Terminal\""
+ ## Avoid displaying warning message when the user clicks on 'Cancel'
+ owarn <- getOption("warn")
+ on.exit(options(warn = owarn))
+ options(warn = -1)
+ if (message == "") mcmd <- "" else mcmd <- paste("with prompt \"",
+ message, "\" ", sep = "")
+ cmd <- paste("-e 'tell application ", app,
+ " to set foldername to choose folder ", mcmd, "default location \"",
+ default , "\"' -e 'POSIX path of foldername'", sep = "")
+ ## For some reasons, I cannot use system(intern = TRUE) with this in R.app/R64.app
+ ## (deadlock situation?), but I can in R run in a terminal. system2() also
+ ## works, but this preclue of using svDialogs on R < 2.12.0.
+ ## The hack is thus to redirect output to a file, then, to read the content
+ ## of that file and to desctroy it
+ tfile <- tempfile()
+ on.exit(unlink(tfile))
+ res <- try(system(paste("osascript", cmd, ">", tfile), wait = TRUE,
+ intern = FALSE, ignore.stderr = TRUE), silent = TRUE)
+ if (inherits(res, "try-error") || !length(res)) return(character(0))
+ if (res > 0) return(character(0)) # User cancelled input
+ res <- readLines(tfile)
+ #res <- sub("^text returned:", "", res)
+ #res <- sub(", button returned:.*$", "", res)
+ #res <- paste(res, collapse = " ")
+ return(res)
+}
+
+## Linux/Unix version
+.unixDlgDir <- function (default = getwd(), message = "")
+{
+ ## zenity must be installed on this machine!
+ if (Sys.which("zenity") == "") return(NULL)
+ ## Avoid displaying warning message in case user clicks on Cancel
+ owarn <- getOption("warn")
+ on.exit(options(warn = owarn))
+ options(warn = -1)
+ ## Use zenity to display the directory selection
+ ## There is no message area here, but one can set the title
+ if (message == "") {
+ message <- "Choose a directory" # Default message
+ } else {
+ ## Determine if the message is multiline...
+ if (regexpr("\n", message) > 0) {
+ ## Try to use a notification instead
+ if (Sys.which("notify-send") != "") {
+ system(paste("notify-send --category=\"R\"",
+ " \"R message\" \"", message, "\"", sep = ""), wait = FALSE)
+ message <- "Choose folder"
+ } # Else the wole message cannot be displayed!!
+ }
+ }
+ msg <- paste("zenity --file-selection --title=\"", message,
+ "\" --directory --filename=\"", default, "\"", sep = "")
+ res <- system(msg, intern = TRUE)
+ return(res)
+}
Added: pkg/svDialogs/R/dlgInput.R
===================================================================
--- pkg/svDialogs/R/dlgInput.R (rev 0)
+++ pkg/svDialogs/R/dlgInput.R 2011-07-31 23:05:46 UTC (rev 382)
@@ -0,0 +1,120 @@
+## Define the S3 method
+dlgInput <- function (message = "Enter a value",
+default = "", ..., gui = .GUI) {
+ if (!gui$startUI("dlgInput", call = match.call(), default = default,
+ msg = "Displaying a modal input dialog box",
+ msg.no.ask = "A modal input dialog box was by-passed"))
+ return(invisible(gui))
+
+ ## Check and rework main arguments and place them in gui$args
+ if (is.null(message) || !inherits(message, "character"))
+ stop("'message' must be a character string!")
+ message <- paste(message, collapse = "\n")
+ if (is.null(default)) default <- "" else {
+ if (!inherits(default, "character") || length(default) != 1)
+ stop("'default' must be a unique character string or NULL!")
+ }
+ gui$setUI(args = list(message = message, default = default))
+
+ ## ... and dispatch to the method
+ UseMethod("dlgInput", gui)
+}
+
+## Used to break the chain of NextMethod(), searching for a usable method
+## in the current context
+dlgInput.gui <- function (message = "Enter a value",
+default = "", ..., gui = .GUI) {
+ msg <- paste("No workable method available to display an input dialog box using:",
+ paste(guiWidgets(gui), collapse = ", "))
+ gui$setUI(status = "error", msg = msg, widgets = "none")
+ stop(msg)
+}
+
+## The pure textual version used a fallback in case no GUI could be used
+dlgInput.textCLI <- function (message = "Enter a value",
+default = "", ..., gui = .GUI)
+{
+ gui$setUI(widgets = "textCLI")
+ ## Ask for the input with readline()
+ res <- readline(paste(gui$args$message,
+ " [", gui$args$default, "]: ", sep = ""))
+ if (res == "") res <- gui$args$default
+ gui$setUI(res = res, status = NULL)
+ return(invisible(gui))
+}
+
+## The native version of the input box
+dlgInput.nativeGUI <- function (message = "Enter a value",
+default = "", ..., gui = .GUI)
+{
+ gui$setUI(widgets = "nativeGUI")
+ ## A simple text input box using native window
+ ## Return either a string, or character(0) if 'Cancel' clicked
+ res <- switch(Sys.info()["sysname"],
+ Windows = .winDlgInput(gui$args$message, gui$args$default),
+ Darwin = .macDlgInput(gui$args$message, gui$args$default),
+ .unixDlgInput(gui$args$message, gui$args$default)
+ )
+
+ ## Do we need to further dispatch?
+ if (is.null(res)) NextMethod("dlgInput", gui) else {
+ gui$setUI(res = res, status = NULL)
+ return(invisible(gui))
+ }
+}
+
+## Windows version
+.winDlgInput <- function (message, default)
+{
+ res <- winDialogString(message = message, default = default)
+ if (is.null(res)) res <- character(0)
+ return(res)
+}
+
+## Mac OS X version
+.macDlgInput <- function (message, default)
+{
+ ## Display a modal message with native Mac dialog box
+ if (.Platform$GUI == "AQUA") app <- "(name of application \"R\")" else
+ app <- "\"Terminal\""
+ ## Avoid displaying warning message when the user clicks on 'Cancel'
+ owarn <- getOption("warn")
+ on.exit(options(warn = owarn))
+ options(warn = -1)
+ cmd <- paste("-e 'tell application ", app,
+ " to display dialog \"", message, "\" default answer \"", default,
+ "\" with title \"Question\" buttons {\"Cancel\",\"OK\"} cancel button 1",
+ " default button 2'", sep = "")
+ ## For some reasons, I cannot use system(intern = TRUE) with this in R.app/R64.app
+ ## (deadlock situation?), but I can in R run in a terminal. system2() also
+ ## works, but this preclue of using svDialogs on R < 2.12.0.
+ ## The hack is thus to redirect output to a file, then, to read the content
+ ## of that file and to desctroy it
+ tfile <- tempfile()
+ on.exit(unlink(tfile))
+ res <- try(system(paste("osascript", cmd, ">", tfile), wait = TRUE,
+ intern = FALSE, ignore.stderr = TRUE), silent = TRUE)
+ if (inherits(res, "try-error") || !length(res)) return(character(0))
+ if (res > 0) return(character(0)) # User cancelled input
+ res <- readLines(tfile)
+ res <- sub("^text returned:", "", res)
+ res <- sub(", button returned:.*$", "", res)
+ res <- paste(res, collapse = " ")
+ return(res)
+}
+
+## Linux/Unix version
+.unixDlgInput <- function (message, default)
+{
+ ## zenity must be installed on this machine!
+ if (Sys.which("zenity") == "") return(NULL)
+ ## Avoid displaying warning message in case user clicks on Cancel
+ owarn <- getOption("warn")
+ on.exit(options(warn = owarn))
+ options(warn = -1)
+ ## Use zenity to display the prompt box
+ msg <- paste("zenity --entry --title=\"Question\" --text=\"", message,
+ "\" --entry-text=\"", default, "\"", sep = "")
+ res <- system(msg, intern = TRUE)
+ return(res)
+}
Added: pkg/svDialogs/R/dlgList.R
===================================================================
--- pkg/svDialogs/R/dlgList.R (rev 0)
+++ pkg/svDialogs/R/dlgList.R 2011-07-31 23:05:46 UTC (rev 382)
@@ -0,0 +1,165 @@
+## Define the S3 method
+dlgList <- function (choices, preselect = NULL, multiple = FALSE, title = NULL,
+..., gui = .GUI) {
+ ## Check arguments
+ choices <- as.character(choices)
+ if (is.null(choices) || !length(choices)) # Nothing to select
+ return(character(0))
+ preselect <- as.character(preselect)
+ preselect <- preselect[preselect %in% choices]
+ if (!length(preselect)) preselect <- choices[1] # Select first item by default
+
+ ## Start a GUI action... or by-pass it
+ if (!gui$startUI("dlgList", call = match.call(), default = preselect,
+ msg = "Displaying a modal list dialog box",
+ msg.no.ask = "A modal list dialog box was by-passed"))
+ return(invisible(gui))
+
+ ## Further argument checking
+ if (!is.null(multiple) && !is.na(multiple))
+ multiple <- (multiple[1] == TRUE) else multiple <- FALSE
+ if (!is.null(title) && (!is.character(title) || length(title) != 1))
+ stop("'title' must be NULL or a length-1 character vector")
+ gui$setUI(args = list(choices = choices, preselect = preselect,
+ multiple = multiple, title = title))
+
+ ## ... and dispatch to the method
+ UseMethod("dlgList", gui)
+}
+
+## Used to break the chain of NextMethod(), searching for a usable method
+## in the current context
+dlgList.gui <- function (choices, preselect = NULL, multiple = FALSE,
+title = NULL, ..., gui = .GUI) {
+ msg <- paste("No workable method available to display a list dialog box using:",
+ paste(guiWidgets(gui), collapse = ", "))
+ gui$setUI(status = "error", msg = msg, widgets = "none")
+ stop(msg)
+}
+
+## The pure textual version used a fallback in case no GUI could be used
+dlgList.textCLI <- function (choices, preselect = NULL, multiple = FALSE,
+title = NULL, ..., gui = .GUI) {
+ gui$setUI(widgets = "textCLI")
+ ## Ask a selection in a textual menu
+ choices <- gui$args$choices
+ multiple <- gui$args$multiple
+ res <- select.list(choices = choices, preselect = gui$args$preselect,
+ multiple = multiple, title = gui$args$title, graphics = FALSE)
+ ## When multiple is FALSE and user cancelled, returns "" instead of
+ ## character(0) => change this for consistency
+ if (!multiple && res == "" && !"" %in% choices)
+ res <- character(0)
+ res$gui <- res
+ return(invisible(gui))
+}
+
+## The native version of the list box
+dlgList.nativeGUI <- function (choices, preselect = NULL, multiple = FALSE,
+title = NULL, ..., gui = .GUI)
+{
+ gui$setUI(widgets = "nativeGUI")
+ ## This is a simple 'select in the list' dialog box
+ ## It follows the syntax of the select.list() function
+ res <- switch(Sys.info()["sysname"],
+ Windows = .winDlgList(gui$args$choices, gui$args$preselect,
+ gui$args$multiple, gui$args$title),
+ Darwin = .macDlgList(gui$args$choices, gui$args$preselect,
+ gui$args$multiple, gui$args$title),
+ .unixDlgList(gui$args$choices, gui$args$preselect,
+ gui$args$multiple, gui$args$title)
+ )
+
+ ## Do we need to further dispatch?
+ if (is.null(res)) NextMethod("dlgList", gui) else {
+ gui$setUI(res = res, status = NULL)
+ return(invisible(gui))
+ }
+}
+
+## Windows version
+## select.list() does not have exactly the same behaviour, or native look&feel
+## on all R programs => redefine it here to make it more homogeneous
+.winDlgList <- function (choices, preselect = NULL, multiple = FALSE,
+title = NULL)
+{
+ ## To get the same behaviour as under Mac and Linux, that is, to return
+ ## character(0) when the user clicks on 'Cancel'
+ res <- select.list(choices = choices, preselect = preselect,
+ multiple = multiple, title = title, graphics = TRUE)
+ if (length(res) == 1 && res == "") return(character(0)) else return(res)
+}
+
+## Mac OS X version
+.macDlgList <- function (choices, preselect = NULL, multiple = FALSE,
+title = NULL)
+{
+ if (.Platform$GUI == "AQUA") { # Use the R(64).app list box
+ ## Same as select.list(), but force graphics to TRUE
+ ## and always do preselection (first element) to match behaviour
+ ## under Windows
+ if (is.null(preselect) || !any(preselect %in% choices))
+ preselect <- choices[1]
+ return(select.list(choices = choices, preselect = preselect,
+ multiple = multiple, title = title, graphics = TRUE))
+ } else { # Probably run from terminal, use osascript to display the list box
+ ## Make sure to keep only first preselection if !multiple
+ if (!multiple) preselect <- preselect[1]
+ ## Format preselect into a single character string
+ sel <- paste('"', preselect, ' "', sep = "", collapse = ",")
+ ## Format choices in a single string
+ items <- paste('"', choices, ' "', sep = "", collapse = ",")
+ ## Default title
+ if (is.null(title)) if (multiple) title <- "Select one or more" else
+ title <- "Select one"
+ ## Avoid displaying warning message when the user clicks on 'Cancel'
+ owarn <- getOption("warn")
+ on.exit(options(warn = owarn))
+ options(warn = -1)
+ cmd <- paste("-e 'tell application \"Terminal\" to choose from list {",
+ items, "} with title \"Make your selection\" with prompt \"", title,
+ "\" multiple selections allowed ", multiple, " default items {",
+ sel, "}'", sep = "")
+ #res <- system2("osascript", cmd, stdout = TRUE, stderr = TRUE, wait = TRUE)
+ res <- system(paste("osascript", cmd), intern = TRUE, wait = TRUE)
+ if (res == "false") {
+ return(character(0))
+ } else {
+ res <- unlist(strsplit(sub(" $", "", res), " , ", fixed = TRUE))
+ return(res)
+ }
+ }
+}
+
+## Linux/Unix version
+.unixDlgList <- function (choices, preselect = NULL, multiple = FALSE,
+title = NULL) {
+ ## We don't use the ugly (on Linux) Tk version tk_select.list()
+ ## In zenity, the normal list mode do not allow for preselections
+ ## => switch to --checklist (multiple) or --radiolist (single) in this case
+ ## Make sure that we have at least one preselection
+ if (multiple) {
+ kind <- "--checklist --column=\"Pick\" --column=\"Item\" --multiple"
+ } else {
+ kind <- "--radiolist --column=\"Pick\" --column=\"Item\""
+ }
+ ## Make sure only one item is preselected if multiple is FALSE (keep first one)
+ if (!multiple) preselect <- preselect[1]
+ ## Create a string with TRUE/FALSE item alternated
+ sel <- choices %in% preselect
+ items <- paste(sel, ' "', choices, '"', sep = "", collapse = " ")
+ ## Default title
+ if (is.null(title)) if (multiple) title <- "Select one or more" else
+ title <- "Select one"
+ ## Avoid warning when user clicks on 'Cancel'
+ owarn <- getOption("warn")
+ on.exit(options(warn = owarn))
+ options(warn = -1)
+ ## Construct the command to send to zenity
+ cmd <- paste("zenity --list --text=\"", title, "\" ", kind,
+ " --hide-header --title=\"Make your choice\" --separator=\"@@@\" --height=",
+ 80 + 25 * length(choices), " ", items, sep = "")
+ res <- system(cmd, intern = TRUE)
+ res <- unlist(strsplit(res, "@@@", fixed = TRUE))
+ if (is.null(res)) return(character(0)) else return(res)
+}
Added: pkg/svDialogs/R/dlgMessage.R
===================================================================
--- pkg/svDialogs/R/dlgMessage.R (rev 0)
+++ pkg/svDialogs/R/dlgMessage.R 2011-07-31 23:05:46 UTC (rev 382)
@@ -0,0 +1,164 @@
+## Define the S3 method
+dlgMessage <- function (message, type = c("ok", "okcancel", "yesno",
+"yesnocancel"), ..., gui = .GUI) {
+ if (!gui$startUI("dlgMessage", call = match.call(), default = "ok",
+ msg = "Displaying a modal message dialog box",
+ msg.no.ask = "A modal message dialog box was by-passed"))
+ return(invisible(gui))
+
+ ## Check and rework main arguments and place them in gui$args
+ if (missing(message) || !inherits(message, "character"))
+ stop("'message' must be a character string!")
+ message <- paste(message, collapse = "\n")
+ type <- match.arg(type)
+ gui$setUI(args = list(message = message, type = type))
+
+ ## ... and dispatch to the method
+ UseMethod("dlgMessage", gui)
+}
+
+## Used to break the chain of NextMethod(), searching for a usable method
+## in the current context
+dlgMessage.gui <- function (message, type = c("ok", "okcancel", "yesno",
+"yesnocancel"), ..., gui = .GUI) {
+ msg <- paste("No workable method available to display a message dialog box using:",
+ paste(guiWidgets(gui), collapse = ", "))
+ gui$setUI(status = "error", msg = msg, widgets = "none")
+ stop(msg)
+}
+
+## The pure textual version used a fallback in case no GUI could be used
+dlgMessage.textCLI <- function (message, type = c("ok", "okcancel", "yesno",
+"yesnocancel"), ..., gui = .GUI)
+{
+ gui$setUI(widgets = "textCLI")
+ ## Display the message and wait for user action
+ if (gui$args$type == "ok") {
+ readline(paste(gui$args$message, "\n(hit ENTER to continue) ", sep = ""))
+ res <- "ok"
+ } else {
+ ## Use a non-graphical select.list() for the others
+ choices <- switch(gui$args$type,
+ okcancel = c("ok", "cancel"),
+ yesno = c("yes", "no"),
+ yesnocancel = c("yes", "no", "cancel")
+ )
+ res <- select.list(choices, title = gui$ask$message, graphics = FALSE)
+ if (res == "" && type != "yesno") res <- "cancel"
+ if (res == "") res <- "no" # Selection of 0 with yes/no => no
+ }
+ gui$setUI(res = res, status = NULL)
+ return(invisible(gui))
+}
+
+## The native version of the message box
+dlgMessage.nativeGUI <- function (message, type = c("ok", "okcancel", "yesno",
+"yesnocancel"), ..., gui = .GUI)
+{
+ gui$setUI(widgets = "nativeGUI")
+ ## A simple message box
+ ## type can be 'ok' (info), 'okcancel', 'yesno', 'yesnocancel' (question)
+ ## This dialog box is always modal
+ ## Returns invisibly a character with the button that was pressed
+ res <- switch(Sys.info()["sysname"],
+ Windows = .winDlgMessage(gui$ask$message, gui$ask$type),
+ Darwin = .macDlgMessage(gui$ask$message, gui$ask$type),
+ .unixDlgMessage(gui$ask$message, gui$ask$type)
+ )
+
+ ## Do we need to further dispatch?
+ if (is.null(res)) NextMethod("dlgMessage", gui) else {
+ gui$setUI(res = res, status = NULL)
+ return(invisible(gui))
+ }
+}
+
+## Windows version
+.winDlgMessage <- function (message, type = c("ok", "okcancel", "yesno",
+"yesnocancel"))
+{
+ res <- winDialog(type = type, message = message)
+ ## Rework result to match the other functions
+ if (type == "ok") return(invisible("ok")) else return(tolower(res))
+}
+
+## Mac OS X version
+.macDlgMessage <- function (message, type= c("ok", "okcancel", "yesno",
+"yesnocancel"))
+{
+ ## Display a modal message with native Mac dialog box
+ if (.Platform$GUI == "AQUA") app <- "(name of application \"R\")" else
+ app <- "\"Terminal\""
+ type <- match.arg(type)
+ buttons <- switch(type,
+ ok = "\"OK\"",
+ okcancel = "\"Cancel\",\"OK\"",
+ yesno = "\"No\",\"Yes\"",
+ yesnocancel = ",\"Cancel\",\"No\",\"Yes\"",
+ stop("type can only be 'ok'n 'okcancel', 'yesno', 'yesnocancel'"))
+ if (type == "ok") {
+ beep <- " -e 'beep'"
+ icon <- "caution"
+ title <- "\"Information\""
+ more <- " default button 1"
+ } else {
+ beep <- ""
+ icon <- "note"
+ title <- "\"Question\""
+ if (type == "yesnocancel")
+ more <- " default button 3 cancel button 1" else
+ if (type == "yesno") more <- " default button 2" else
+ more <- " default button 2 cancel button 1"
+ }
+ cmd <- paste("exit `osascript", beep, " -e 'tell application ", app,
+ " to set dlg to display dialog \"", message, "\" with title ", title,
+ more, " with icon ", icon, " buttons {", buttons,
+ "}' -e 'if button returned of dlg is \"No\" then 2' 2> /dev/null`",
+ sep = "")
+ res <- system(cmd, ignore.stdout = TRUE, ignore.stderr = TRUE, wait = TRUE)
+ ## Decrypt result
+ if (type == "ok")
+ if (res > 0) return(NULL) else return(invisible("ok"))
+ if (res == 2) return("no")
+ if (res == 1) return("cancel")
+ if (type == "okcancel") return("ok") else return("yes")
+}
+
+## Linux/Unix version
+.unixDlgMessage <- function (message, type = c("ok", "okcancel", "yesno",
+"yesnocancel"))
+{
+ ## zenity must be installed on this machine!
+ if (Sys.which("zenity") == "") return(NULL)
+ type <- match.arg(type)
+ if (type == "ok") {
+ alarm()
+ msg <- paste("zenity --info --text=\"", message,
+ "\" --title=\"Information\"", sep = "")
+ res <- system(msg)
+ if (res > 0) return(NULL) else return(invisible("ok"))
+ } else if (type == "yesnocancel") {
+ type <- "yesno"
+ confirm <- TRUE
+ } else confirm <- FALSE
+ ## Now, we have only "okcancel" or "yesno"
+ if (type == "okcancel") {
+ msg <- paste("zenity --question --text=\"", message,
+ "\" --ok-label=\"OK\" --cancel-label=\"Cancel\" --title=\"Question\"",
+ sep = "")
+ results <- c("ok", "cancel")
+ } else {
+ msg <- paste("zenity --question --text=\"", message,
+ "\" --ok-label=\"Yes\" --cancel-label=\"No\" --title=\"Question\"",
+ sep = "")
+ results <- c("yes", "no")
+ }
+ res <- system(msg)
+ if (res > 1) return(NULL) else res <- results[res + 1]
+ ## Do we ask to continue (if was yesnocancel)?
+ if (confirm) {
+ conf <- system("zenity --question --text=\"Continue?\" --ok-label=\"OK\" --cancel-label=\"Cancel\" --title=\"Confirm\"")
+ if (conf == 1) return("cancel")
+ }
+ return(res)
+}
Deleted: pkg/svDialogs/R/fixedDlg.R
===================================================================
--- pkg/svDialogs/R/fixedDlg.R 2011-07-26 07:22:23 UTC (rev 381)
+++ pkg/svDialogs/R/fixedDlg.R 2011-07-31 23:05:46 UTC (rev 382)
@@ -1,591 +0,0 @@
-guiDlgAssistant <- function (...)
-{
- ## This is a non modal assistant dialog box... could also display tips
- ## TODO...
- stop("Not yet implemented!")
-}
-
-guiDlgColor <- function (...)
-{
- ## A color selection dialog box
- ## TODO: a color range selector?
- stop("Not yet implemented!")
-}
-
-guiDlgDir <- function (title = "Select a directory", dir = getwd(), new = TRUE,
-parent = 0, GUI = getOption("guiWidgets"))
-{
- ## A 'choose a directory' dialog box
- ## It almost follows the conventions of tkchooseDirectory()
- ## The argument dir indicates the initial directory
- ## The argument new indicates if a new file name can be given
- ## parent determines which is the parent window... if 0 then system modal
- ## If cancelled, then return character(0)
- ## This dialog box is always modal
-
- ## Check arguments
- if (!inherits(title, "character") && length(title) < 1)
- stop("'title' must be a non empty character string!")
- title <- title[1] # Keep only first item for title
- if (!is.null(new) && !is.na(new)) new <- (new == TRUE) else new <- FALSE
- if (!inherits(dir, "character"))
- stop("'dir' must be a character string!")
- dir <- dir[1] # Keep only first one, if several are provided
- ## Check this is a directory (if it exists)
- if (file.exists(dir)) {
- if (!file.info(dir)$isdir)
- stop("'dir' must be a directory, not a file!")
- } else {
- if (!new)
- stop("'dir' must be an existing directory if 'new' == TRUE!")
- }
-###TO DO: expand abbreviated directories under windows!
-###TO DO: check 'parent'!
- if (!inherits(GUI, "character") && !is.null(GUI))
- stop("'GUI' must be a character string or NULL!")
-
- if (!is.null(GUI) && GUI != "tcltk") { # Custom GUI widgets
- ## Look for a guiDlgDir.<GUI> function
- fun <- paste("guiDlgDir", GUI, sep=".")
- if (exists(fun, where = 1, mode = "function", inherits = TRUE)) {
- res <- get(fun, pos = 1, mode = "function", inherits = TRUE)(
- title = title, dir = dir, new = new, parent = parent)
- if (!is.null(res)) {
- return(res)
- } else warning("Using default Tcl/tk dialog box instead!")
- }
- }
- ## Otherwise, use the default Tcl/Tk dialog box
- ## Use tkmessageBox()
- ## parent argument is defined, but not used yet here...
- ## should look how to implement it!
- res <- tclvalue(tkchooseDirectory(initialdir = dir, mustexist = !new,
- title = title))
- ## Bug: if new == FALSE and the user indicated a new dir, and then clicked
- ## 'Cancel', the name of the new dir is returned! => recheck
- if (!new && !file.exists(res)) res <- character(0)
- res <- as.character(res)
- if (res == "") res <- character(0) # tkchooseDirectory returns "" if cancelled
- return(as.character(res))
-}
-
-guiDlgDoubleList <- function (list1, list2, title = "Select", default1 = "",
-default2 = "", multi = c(TRUE, TRUE), new = c(FALSE, FALSE), sort = c(TRUE, TRUE),
-transfer = FALSE, parent = 0, GUI = getOption("guiWidgets"))
-{
- ## A 'dual list' dialog box. This list serves two purposes:
- ## 1) select elements in the first list and place them in the second list
- ## (transfer = TRUE)
- ## 2) make a double selection in two separate lists
- ## This dialog box is always modal
- stop("Not yet implemented!")
-}
-
-guiDlgFont <- function (...)
-{
- ## A font selector dialog box
- ## TODO...
- stop("Not yet implemented!")
-}
-
-guiDlgFormula <- function (...)
-{
- ## This dialog box helps to create S language formulas
- ## R Commander has something like that in glm dialog box. Look with John Fox
- ## for permission to reuse it
- ## TODO...
- stop("Not yet implemented!")
-}
-
-guiDlgGraphOptions <- function (...)
-{
- ## A graph options dialog box
- ## Idem as guiDlgOptions, but specific to graph parameters? Or is it possible
- ## to reuse guiDlgOptions?
- ## TODO...
- stop("Not yet implemented!")
-}
-
-guiDlgGrid <- function (table, title = deparse(substitute(table)), edit = TRUE,
-edit.vars = TRUE, add.vars = TRUE, add.rows = TRUE, parent = -1,
-GUI = getOption("guiWidgets"))
-{
- ## A 'grid' display of a one or two dimensional table (vector, matrix,
- ## data.frame)
- ## It is similar to the data editor in Rgui, but can be non modal (parent = -1)
- ## and can be used just to display the content of a table
- ## TODO: possibly tabbed presentation?
- stop("Not yet implemented!")
-}
-
-guiDlgInput <- function (message = "Enter a value", title = "Input",
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 382
More information about the Sciviews-commits
mailing list