[Sciviews-commits] r115 - in pkg: . svWidgets svWidgets/R svWidgets/inst svWidgets/inst/gui svWidgets/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Feb 22 14:39:43 CET 2009
Author: phgrosjean
Date: 2009-02-22 14:39:43 +0100 (Sun, 22 Feb 2009)
New Revision: 115
Added:
pkg/svWidgets/
pkg/svWidgets/DESCRIPTION
pkg/svWidgets/NAMESPACE
pkg/svWidgets/R/
pkg/svWidgets/R/Img.R
pkg/svWidgets/R/Menu.R
pkg/svWidgets/R/Tool.R
pkg/svWidgets/R/Win.R
pkg/svWidgets/R/tkImg.R
pkg/svWidgets/R/tkMenu.R
pkg/svWidgets/R/tkTool.R
pkg/svWidgets/R/tkWin.R
pkg/svWidgets/R/winMenu.R
pkg/svWidgets/TODO
pkg/svWidgets/inst/
pkg/svWidgets/inst/CITATION
pkg/svWidgets/inst/gui/
pkg/svWidgets/inst/gui/Menus.txt
pkg/svWidgets/inst/gui/SciViews.ico
pkg/svWidgets/inst/gui/SciViewsDoc.ico
pkg/svWidgets/inst/gui/butCopy.gif
pkg/svWidgets/inst/gui/butCut.gif
pkg/svWidgets/inst/gui/butOpen.gif
pkg/svWidgets/inst/gui/butPaste.gif
pkg/svWidgets/inst/gui/butPrint.gif
pkg/svWidgets/inst/gui/butSave.gif
pkg/svWidgets/inst/gui/logoSciViews.gif
pkg/svWidgets/man/
pkg/svWidgets/man/Img.Rd
pkg/svWidgets/man/Menu.Rd
pkg/svWidgets/man/Tool.Rd
pkg/svWidgets/man/Win.Rd
pkg/svWidgets/man/tkImg.Rd
pkg/svWidgets/man/tkMenu.Rd
pkg/svWidgets/man/tkTool.Rd
pkg/svWidgets/man/tkWin.Rd
pkg/svWidgets/man/winMenu.Rd
Log:
ackage svWidgets added
Added: pkg/svWidgets/DESCRIPTION
===================================================================
--- pkg/svWidgets/DESCRIPTION (rev 0)
+++ pkg/svWidgets/DESCRIPTION 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,11 @@
+Package: svWidgets
+Title: SciViews GUI API - Widgets & Windows
+Depends: R (>= 2.7.0), tcltk, svMisc
+Imports: utils, tcltk, svMisc
+Description: High level management of widgets, windows and other graphical resources.
+Version: 0.9-40
+Date: 2009-02-20
+Author: Philippe Grosjean
+Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
+License: GPL (>= 2)
+URL: http://www.sciviews.org/SciViews-R
Added: pkg/svWidgets/NAMESPACE
===================================================================
--- pkg/svWidgets/NAMESPACE (rev 0)
+++ pkg/svWidgets/NAMESPACE 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,66 @@
+import(tcltk, utils, svMisc)
+
+export(ImgAdd,
+ ImgDel,
+ ImgGet,
+ ImgNames,
+ ImgRead,
+ ImgReadPackage,
+ ImgType,
+ MenuAdd,
+ MenuAddItem,
+ MenuChangeItem,
+ MenuDel,
+ MenuDelItem,
+ MenuInvoke,
+ MenuItems,
+ MenuNames,
+ MenuRead,
+ MenuReadPackage,
+ MenuStateItem,
+ MenuType,
+ tkImgAdd,
+ tkImgDel,
+ tkImgRead,
+ tkMenuAdd,
+ tkMenuAddItem,
+ tkMenuChangeItem,
+ tkMenuDel,
+ tkMenuDelItem,
+ tkMenuInvoke,
+ tkMenuItems,
+ tkMenuStateItem,
+ tkToolAdd,
+ tkToolAddItem,
+ tkToolChangeItem,
+ tkToolDel,
+ tkToolDelItem,
+ tkToolInvoke,
+ tkToolItems,
+ tkToolStateItem,
+ tkWinAdd,
+ tkWinDel,
+ ToolAdd,
+ ToolAddItem,
+ ToolChangeItem,
+ ToolDel,
+ ToolDelItem,
+ ToolInvoke,
+ ToolItems,
+ ToolNames,
+ ToolRead,
+ ToolReadPackage,
+ ToolStateItem,
+ ToolType,
+ WinAdd,
+ WinDel,
+ WinGet,
+ WinNames,
+ winMenuChangeItem,
+ winMenuStateItem,
+ winMenuInvoke)
+
+S3method(print, guiImg)
+S3method(print, guiMenu)
+S3method(print, guiTool)
+S3method(print, guiWin)
\ No newline at end of file
Added: pkg/svWidgets/R/Img.R
===================================================================
--- pkg/svWidgets/R/Img.R (rev 0)
+++ pkg/svWidgets/R/Img.R 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,70 @@
+"print.guiImg" <-
+function (x, ...)
+{
+ cat("A SciViews GUI image object:", "\n")
+ print(unclass(x))
+ return(invisible(x))
+}
+
+"ImgAdd" <-
+function (file, type = "gif", imgtype = "tkImage", update = FALSE, ...)
+{
+ res <- switch(imgtype,
+ tkImage = tkImgAdd(file = file, type = type, update = update),
+ stop("Unrecognized image type '", imgtype, "'"))
+ return(invisible(res))
+}
+
+"ImgDel" <-
+function (image)
+{
+ res <- switch(ImgType(image),
+ tkImage = tkImgDel(image))
+ return(invisible(res))
+}
+
+"ImgGet" <-
+function (image)
+{
+ # Get the image
+ return(getTemp(".guiImgs")[[image]])
+}
+
+"ImgType" <-
+function (image, warn = TRUE)
+{
+ # Get the type of image
+ if (regexpr("^[$]Tk[.]", image) > 0) return("tkImage") else {
+ if (warn) warning("Unrecognized image type for ", image)
+ return(NA)
+ }
+}
+
+"ImgNames" <-
+function ()
+{
+ # List all available images
+ res <- names(getTemp(".guiImgs"))
+ if (is.null(res)) res <- character(0)
+ return(res)
+}
+
+"ImgRead" <-
+function (dir, type = "gif", imgtype = "tkImage")
+{
+ # Depending on 'imgtype', we call a different function
+ res <- switch(imgtype,
+ tkImage = tkImgRead(dir = dir, type = type),
+ stop("Unrecognized image type '", imgtype, "'"))
+ return(invisible(res))
+}
+
+"ImgReadPackage" <-
+function (package, subdir = "gui", type = "gif", imgtype = "tkImage")
+{
+ # Create image resources by reading a series of image files from the 'gui'
+ # subdirectory of a package
+ dir <- system.file(subdir, package = package)
+ res <- ImgRead(dir= dir, type = type, imgtype = imgtype)
+ return(invisible(res))
+}
Added: pkg/svWidgets/R/Menu.R
===================================================================
--- pkg/svWidgets/R/Menu.R (rev 0)
+++ pkg/svWidgets/R/Menu.R 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,214 @@
+"print.guiMenu" <-
+function (x, ...)
+{
+ cat("A SciViews GUI menu object:", "\n")
+ print(unclass(x))
+ return(invisible(x))
+}
+
+"MenuAdd" <-
+function (menu, ...)
+{
+ res <- switch(MenuType(menu),
+ winMenu = if (isRgui()) winMenuAdd(menu),
+ tkMenu = tkMenuAdd(menu, ...))
+ return(invisible(res))
+}
+
+"MenuAddItem" <-
+function (menu, item, action, image = "", accel = "", options = "")
+{
+ res <- switch(MenuType(menu),
+ winMenu = if (isRgui()) {
+ winMenuAddItem(menu, item, action);
+ if (options == 'state = "disable"')
+ winMenuStateItem(menu, item, FALSE) },
+ tkMenu = tkMenuAddItem(menu, item, action, image, accel, options))
+ return(invisible(res))
+}
+
+"MenuDel" <-
+function (menu)
+{
+ res <- switch(MenuType(menu),
+ winMenu = if (isRgui()) winMenuDel(menu),
+ tkMenu = tkMenuDel(menu))
+ return(invisible(res))
+}
+
+"MenuDelItem" <-
+function (menu, item)
+{
+ res <- switch(MenuType(menu),
+ winMenu = if (isRgui()) winMenuDelItem(menu, item),
+ tkMenu = tkMenuDelItem(menu, item))
+ return(invisible(res))
+}
+
+"MenuNames" <-
+function ()
+{
+ res <- character(0)
+ if (isRgui()) res <- winMenuNames()
+ # Eliminate menu names not correctly created (not starting with $...)
+ if (length(res) > 0) res <- res[regexpr("^[$]", res) > 0]
+ # retrieve menu names from tk menus as well
+ res <- c(res, names(getTemp(".guiMenus")))
+ # eliminate toplevel entries
+ if (length(res) > 0) res <- res[regexpr("/", res) > 0]
+ return(res)
+}
+
+"MenuItems" <-
+function (menu)
+{
+ res <- switch(MenuType(menu),
+ winMenu = if (isRgui()) winMenuItems(menu),
+ tkMenu = tkMenuItems(menu))
+ return(res)
+}
+
+"MenuType" <-
+function (menu, warn = TRUE)
+{
+ # Given a menu, return its type ("winMenu", "tkMenu", NA)
+ if (regexpr("^[$]Console(Main|Popup)/", menu) > 0) return("winMenu") else
+ if (regexpr("^[$]Graph[0-9]+(Main|Popup)/", menu) > 0) return("winMenu") else
+ if (regexpr("^[$]Tk[.].+/", menu) > 0) return("tkMenu") else {
+ if (warn) warning("Unrecognized menu type for ", menu)
+ return(NA)
+ }
+}
+
+"MenuChangeItem" <-
+function (menu, item, action = "", options = "")
+{
+ # Change action or options for menu entries
+ res <- switch(MenuType(menu),
+ winMenu = if (isRgui()) winMenuChangeItem(menu, item, action, options),
+ tkMenu = tkMenuChangeItem(menu, item, action, options))
+ return(invisible(res))
+}
+
+"MenuStateItem" <-
+function (menu, item, active = TRUE)
+{
+ # Activate/inactivate menu entries
+ res <- switch(MenuType(menu),
+ winMenu = if (isRgui()) winMenuStateItem(menu, item, active),
+ tkMenu = tkMenuStateItem(menu, item, active))
+ return(invisible(res))
+}
+
+"MenuInvoke" <-
+function (menu, item)
+{
+ # Trigger a menu entry by code
+ res <- switch(MenuType(menu),
+ winMenu = if (isRgui()) winMenuInvoke(menu, item),
+ tkMenu = tkMenuInvoke(menu, item))
+ return(invisible(res))
+}
+
+"MenuRead" <-
+function (file = "Menus.txt")
+{
+ # Read a menu from a file
+ M <- scan(file, character(0), sep = "\n", comment.char = "#", quiet = TRUE)
+ # Split the lines into item, command, options
+ M <- strsplit(M, "~~")
+ # Strip leading and trailing spaces/tabs (used to align items in the file)
+ M <- lapply(M, function(x) sub("[ \t]+$", "", sub("^[ \t]+", "", x)))
+ # Move line after line and replace '|' by values
+ N <- length(M)
+ # Must have at least two entries
+ if (N < 2) return(invisible())
+ # First entry must be a toplevel, thus, it must start with '$'
+ if (regexpr("^[$]", M[[1]][1]) < 0)
+ stop("first entry is not a toplevel menu!")
+ menuLevels <- M[[1]][1]
+ # Initialize a data frame to contain decrypted info
+ dat <- rep("", N)
+ L <- data.frame(menu = I(dat), item = I(dat), image = I(dat),
+ accel = I(dat), action = I(dat), options = I(dat))
+ Litem <- data.frame(menu = I(menuLevels), item = I(""), image = I(""),
+ accel = I(""), action = I("[top]"), options = I(""))
+ L[1, ] <- Litem
+ for (i in 2:N) {
+ entry <- M[[i]][1]
+ # Split on '|'
+ split <- strsplit(entry, "[|]")[[1]]
+ # Combine menuLevels & split
+ last <- length(split)
+ menuLevels[last] <- split[last]
+ menuLevels <- menuLevels[1:last]
+ # Recombine menuLevels for getting recalculated entry
+ entry <- paste(menuLevels, collapse = "/")
+ # Is this just a menu, or a menu/item?
+ lastentry <- basename(entry)
+ if (regexpr("^[$]", lastentry) > 0) { # This is a menu
+ # Remove '$' before menu entries
+ menu <- gsub("/[$]", "/", entry)
+ item <- "" # No item
+ image <- "" # No image
+ accel <- "" # No accel
+ action <- if (last == 1) "[top]" else "[menu]"
+ options <- "" # No options (currently)
+ } else { # This is an entry
+ # menu = entry minus last item (remove '$' before menu entries)
+ menu <- gsub("/[$]", "/", dirname(entry))
+ # Decrypt lastentry to get image, item & accel ([image]item\taccel)
+ lastentry <- strsplit(lastentry, "\t")[[1]]
+ item <- sub("^[[][a-zA-Z0-9 ._-]+[]]", "", lastentry[1])
+ if (item == lastentry[1]) image <- "" else {
+ image <- sub("^[[]([a-zA-Z0-9 ._-]+)[]].+$", "\\1", lastentry[1])
+ # Since these are Tk images resources, I have to prefix '$Tk.'
+ image <- paste("$Tk.", image, sep = "")
+ }
+ accel <- lastentry[2]
+ if (is.na(accel)) accel <- ""
+ action <- M[[i]][2]
+ if (is.na(action)) action <- ""
+ options <- M[[i]][3]
+ if (is.na(options)) options <- ""
+ }
+ Litem <- data.frame(menu = I(menu), item = I(item), image = I(image),
+ accel = I(accel), action = I(action), options = I(options))
+ # add it to the data.frame
+ L[i, ] <- Litem
+ }
+ # The [top] entries are not needed
+ L <- L[L$action != "[top]", ]
+
+ # Execute this line-by-line to create the various menus
+ N <- nrow(L)
+ for (i in 1:N) {
+ action <- L$action[i]
+ if (action == "[menu]") { # Create a menu
+ MenuAdd(menu = L$menu[i])
+ } else { # Create a menu entry
+ MenuAddItem(menu = L$menu[i], item = L$item[i], action = L$action[i],
+ image = L$image[i], accel = L$accel[i], options = L$options[i])
+ }
+ }
+
+ # Return L invisibly
+ return(invisible(L))
+}
+
+"MenuReadPackage" <-
+function (package, subdir = "gui", file = "Menus.txt")
+{
+ # Create menus using a menu definition file located in a R package
+ dir <- system.file(subdir, package = package)
+ # Check that the dir exists
+ if (!file.exists(dir) || !file.info(dir)$isdir)
+ stop("'", dir, "' does not exist, or is not a directory!")
+ # Check that the file exists
+ File <- file.path(dir, file)
+ if (!file.exists(File))
+ stop("'", file, "' not found in '", dir, "'!")
+ # Read the menu file
+ res <- MenuRead(File)
+ return(invisible(res))
+}
Added: pkg/svWidgets/R/Tool.R
===================================================================
--- pkg/svWidgets/R/Tool.R (rev 0)
+++ pkg/svWidgets/R/Tool.R 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,202 @@
+"print.guiTool" <-
+function (x, ...)
+{
+ cat("A SciViews GUI tool object:", "\n")
+ print(unclass(x))
+ return(invisible(x))
+}
+
+"ToolAdd" <-
+function (toolbar, side = "top")
+{
+ res <- switch(ToolType(toolbar),
+ tkTool = tkToolAdd(toolbar = toolbar, side = side))
+ return(invisible(res))
+}
+
+"ToolAddItem" <-
+function (toolbar, item, action, image = "", options = "")
+{
+ res <- switch(ToolType(toolbar),
+ tkTool = tkToolAddItem(toolbar = toolbar, item = item, action = action,
+ image = image, options = options))
+ return(invisible(res))
+}
+
+"ToolDel" <-
+function (toolbar)
+{
+ res <- switch(ToolType(toolbar),
+ tkTool = tkToolDel(toolbar = toolbar))
+ return(invisible(res))
+}
+
+"ToolDelItem" <-
+function (toolbar, item)
+{
+ res <- switch(ToolType(toolbar),
+ tkTool = tkToolDelItem(toolbar = toolbar, item = item))
+ return(invisible(res))
+}
+
+"ToolNames" <-
+function ()
+{
+ res <- character(0)
+ # retrieve toolbar names from tk toolbars
+ res <- c(res, names(getTemp(".guiTools")))
+ # eliminate toplevel entries
+ if (length(res) > 0) res <- res[regexpr("/", res) > 0]
+ return(res)
+}
+
+"ToolItems" <-
+function (toolbar)
+{
+ res <- switch(ToolType(toolbar),
+ tkTool = tkToolItems(toolbar = toolbar))
+ return(res)
+}
+
+"ToolType" <-
+function (toolbar, warn = TRUE)
+{
+ # Given a toolbar, return its type ("tkTool", NA)
+ if (regexpr("^[$]Tk[.].+/", toolbar) > 0) return("tkTool") else {
+ if (warn) warning("Unrecognized toolbar type for ", toolbar)
+ return(NA)
+ }
+}
+
+"ToolChangeItem" <-
+function (toolbar, item, action = "", options = "")
+{
+ # Change action or options for toolbar entries
+ res <- switch(ToolType(toolbar),
+ tkTool = tkToolChangeItem(toolbar, item, action, options))
+ return(invisible(res))
+}
+
+"ToolStateItem" <-
+function (toolbar, item, active = TRUE)
+{
+ # Activate/inactivate toolbar entries
+ res <- switch(ToolType(toolbar),
+ tkTool = tkToolStateItem(toolbar, item, active))
+ return(invisible(res))
+}
+
+"ToolInvoke" <-
+function (toolbar, item)
+{
+ # Invoke a toolbutton
+ res <- switch(ToolType(toolbar),
+ tkTool = tkToolInvoke(toolbar, item))
+ return(invisible(res))
+}
+
+"ToolRead" <-
+function (file = "Tools.txt")
+{
+ # Read toolbars from a file
+ T <- scan(file, character(0), sep = "\n", comment.char = "#", quiet = TRUE)
+ # Split the lines into item, command, options
+ T <- strsplit(T, "~~")
+ # Strip leading and trailing spaces/tabs (used to align items in the file)
+ T <- lapply(T, function(x) sub("[ \t]+$", "", sub("^[ \t]+", "", x)))
+ # Move line after line and replace '|' by values
+ N <- length(T)
+ # Must have at least two entries
+ if (N < 2) return(invisible())
+ # First entry must be a toplevel, thus, it must start with '$'
+ if (regexpr("^[$]", T[[1]][1]) < 0)
+ stop("first entry is not a toolbar!")
+ toolLevels <- T[[1]][1]
+ # Initialize a data frame to contain decrypted info
+ dat <- rep("", N)
+ L <- data.frame(tool = I(dat), item = I(dat), image = I(dat),
+ action = I(dat), options = I(dat))
+ Litem <- data.frame(tool = I(toolLevels), item = I(""), image = I(""),
+ action = I("[toolbar]"), options = I(""))
+ L[1, ] <- Litem
+ for (i in 2:N) {
+ entry <- T[[i]][1]
+ # Split on '|'
+ split <- strsplit(entry, "[|]")[[1]]
+ # Combine toolLevels & split
+ last <- length(split)
+ toolLevels[last] <- split[last]
+ toolLevels <- toolLevels[1:last]
+ # Recombine toolLevels for getting recalculated entry
+ entry <- paste(toolLevels, collapse = "/")
+ # Is this just a tool button, or a menu tool button/menu item?
+ lastentry <- basename(entry)
+ if (regexpr("^[$]", lastentry) > 0) { # This is a tool button
+ # Remove '$' before tool button entries
+ tool <- gsub("/[$]", "/", entry)
+ item <- "" # No item
+ image <- "" # No image
+ action <- if (last == 1) "[toolbar]" else "[tool]"
+ options <- "" # No options (currently)
+ } else { # This is an menu entry in a tool button menu
+ # tool = entry minus last item (remove '$' before tool entries)
+ tool <- gsub("/[$]", "/", dirname(entry))
+ # Decrypt lastentry to get image & item ([image]item)
+ item <- sub("^[[][a-zA-Z0-9 ._-]+[]]", "", lastentry)
+ if (item == lastentry) image <- "" else {
+ image <- sub("^[[]([a-zA-Z0-9 ._-]+)[]].+$", "\\1", lastentry)
+ # Since these are Tk images resources, I have to prefix '$Tk.'
+ image <- paste("$Tk.", image, sep = "")
+ }
+ action <- T[[i]][2]
+ if (is.na(action)) action <- ""
+ options <- T[[i]][3]
+ if (is.na(options)) options <- ""
+ }
+ Litem <- data.frame(tool = I(menu), item = I(item), image = I(image),
+ action = I(action), options = I(options))
+ # add it to the data.frame
+ L[i, ] <- Litem
+ }
+# # The [toolbar] entries are not needed
+# L <- L[L$action != "[toolbar]", ]
+
+ # Execute this line-by-line to create the various tools
+ N <- nrow(L)
+ for (i in 1:N) {
+ action <- L$action[i]
+ if (action == "[toolbar]") { # Create a toolbar
+ ToolAdd(toolbar = L$menu[i])
+# } else if (action == "[tool]") { # Create a tool button
+# ### TODO: determine which type of tool button it is!
+# ToolAddItem(toolbar = L$menu[i])
+# } else { # Create a menu entry for a menu tool button
+# MenuAddItem(menu = L$tool[i], item = L$item[i], action = L$action[i],
+# image = L$image[i], options = L$options[i])
+# }
+ } else { # Create a tool in the toolbar
+ ToolAddItem(tool = L$tool[i], item = L$item[i], action = L$action[i],
+ image = L$image[i], options = L$options[i])
+ }
+ }
+
+ # Return L invisibly
+ return(invisible(L))
+}
+
+"ToolReadPackage" <-
+function (package, subdir = "gui", file = "Tools.txt")
+{
+ # Create toolbars using a toolbar definition file located in a R package
+ dir <- system.file(subdir, package = package)
+ # Check that the dir exists
+ if (!file.exists(dir) || !file.info(dir)$isdir)
+ stop("'", dir, "' does not exist, or is not a directory!")
+ # Check that the file exists
+ File <- file.path(dir, file)
+ if (!file.exists(File))
+ stop("'", file, "' not found in '", dir, "'!")
+ # Read the toolbar file
+ res <- ToolRead(File)
+ return(invisible(res))
+}
Added: pkg/svWidgets/R/Win.R
===================================================================
--- pkg/svWidgets/R/Win.R (rev 0)
+++ pkg/svWidgets/R/Win.R 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,47 @@
+"print.guiWin" <-
+function (x, ...)
+{
+ cat("A SciViews GUI window object:", "\n")
+ print(unclass(x))
+ return(invisible(x))
+}
+
+"WinAdd" <-
+function (name = "win1", type = "tkWin", parent = .TkRoot, title = NULL,
+ pos = NULL, bind.delete = TRUE, ...)
+{
+ # Add a window. This mechanism should be able to use different kinds of
+ # groahical widgets, but currently, only Tcl/Tk is supported.
+ res <- switch(type,
+ tkWin = tkWinAdd(name = name, parent = parent, title = title, pos = pos,
+ bind.delete = bind.delete, ...),
+ stop("Only type = \"tkWin\" is currently supported"))
+ return(invisible(res))
+}
+
+"WinDel" <-
+function (window)
+{
+ # Process depends on the kind of window to delete
+ # Currently, only Tk windows are supported
+ if (inherits(WinGet(window), "tkguiWin")) {
+ return(invisible(tkWinDel(window)))
+ } else stop("Unsupported window type")
+}
+
+"WinGet" <-
+function (window)
+{
+ # Retrieve a "guiWin" object from .guiWins, given its name
+ return(getTemp(".guiWins")[[window]])
+}
+
+"WinNames" <-
+function ()
+{
+ # List all recorded windows in .guiWins
+ ### TODO: if Rgui, list also console, graph, editors and pagers!
+ res <- names(getTemp(".guiWins"))
+ if (is.null(res)) res <- character(0)
+ return(res)
+}
Added: pkg/svWidgets/R/tkImg.R
===================================================================
--- pkg/svWidgets/R/tkImg.R (rev 0)
+++ pkg/svWidgets/R/tkImg.R 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,69 @@
+"tkImgAdd" <-
+function (file, type = "gif", update = FALSE)
+{
+ # Add a Tk image to the list (just GIF for the moment,
+ # but the Tcl/Tk Img package allows for more!)
+ if (type != "gif")
+ stop("Only 'gif' images currently supported!")
+ if (!file.exists(file))
+ stop("File '", file, "' not found!")
+ # Load the image and assign it to an item to the .guiImgs object in TempEnv
+ .guiImgs <- getTemp(".guiImgs")
+ if (is.null(.guiImgs)) {
+ .guiImgs <- list()
+ class(.guiImgs) <- c("guiImg", "gui", class(.guiImgs))
+ }
+ # Calculate image name as being the basename of the file without extension
+ Iname <- sub("[.][^.]+$", "", basename(file))
+ # In order to indicate it is a Tk resource, prepend '$Tk.'
+ Iname <- paste("$Tk.", Iname, sep = "")
+ # If that name already exists, do nothing, except if we ask to update it
+ if (Iname %in% names(.guiImgs)) {
+ if (update) {
+ # Delete the image to recreate it with new resource
+ tcl("image", "delete", Iname)
+ } else return(invisible(Iname)) # Do nothing
+ }
+ Image <- tclVar()
+ tcl("image", "create", "photo", Image, file = file)
+
+ .guiImgs[[Iname]] <- Image
+ # Reassign .guiImgs to TempEnv
+ assignTemp(".guiImgs", .guiImgs)
+ return(invisible(Iname))
+}
+
+"tkImgDel" <-
+function (image)
+{
+ # Delete a tk image ressource from the list
+ .guiImgs <- getTemp(".guiImgs")
+ # Is the image there?
+ if (!image %in% names(.guiImgs)) return(invisible(FALSE))
+ # Delete the image
+ Image <- .guiImgs[[image]]
+ tcl("image", "delete", Image)
+ # Eliminate it from the list in .guiImgs
+ .guiImgs[[image]] <- NULL
+ # Reassign .guiImgs to TempEnv
+ assignTemp(".guiImgs", .guiImgs)
+ # Indicate that the image is actually deleted
+ return(invisible(TRUE))
+}
+
+"tkImgRead" <-
+function (dir, type = "gif")
+{
+ # Read all gif images from a directory into tkImage resources
+ # Check that the dir exists
+ if (!file.exists(dir) || !file.info(dir)$isdir)
+ stop("'", dir, "' does not exist, or is not a directory!")
+ # List all file of 'type' in that directory
+ if (type != "gif")
+ stop("only type = 'gif' is currently supported")
+ pattern <- "[.][gG][iI][fF]$"
+ files <- list.files(dir, pattern = pattern, full.names = TRUE)
+ if (length(files) == 0) return(invisible())
+ for (i in 1:length(files)) tkImgAdd(files[i], type = type)
+ return(invisible(files))
+}
Added: pkg/svWidgets/R/tkMenu.R
===================================================================
--- pkg/svWidgets/R/tkMenu.R (rev 0)
+++ pkg/svWidgets/R/tkMenu.R 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,296 @@
+"tkMenuItems" <-
+function (menu)
+{
+ M <- getTemp(".guiMenus")[[menu]]
+ if (is.null(M))
+ stop("unable to retrieve items for ", menu, "\n(menu ", menu,
+ " does not exist)")
+ Mitems <- M$Items
+ if (is.null(Mitems)) {
+ res <- character(0)
+ } else {
+ res <- as.character(Mitems$action)
+ }
+ if (length(res) > 0) names(res) <- Mitems$name
+ return(res)
+}
+
+"tkMenuAdd" <-
+function (menu, tearoff = FALSE)
+{
+ # Get the menu name
+ Mname <- basename(menu)
+ # Get the name of the parent
+ Pname <- dirname(menu)
+ # Look if the parent exists (must be in .guiMenus in TempEnv)
+ .guiMenus <- getTemp(".guiMenus")
+ # If .guiMenus was not there, create it
+ if (is.null(.guiMenus)) {
+ .guiMenus <- list()
+ class(.guiMenus) <- c("guiMenu", "gui", class(.guiMenus))
+ }
+ # Do not create the menu if it already exists
+ if (menu %in% names(.guiMenus))
+ stop("menu ", menu, " already exists!")
+ Parent <- .guiMenus[[Pname]]
+ if (is.null(Parent)) {
+ # If base menu is a "root", try to create the corresponding Tk top menu
+ if (regexpr("/", Pname) < 0) {
+ # Get the name of the Tk window that hosts the menu
+ TkWinName <- sub("^[$]Tk[.]", "", Pname)
+ # Look if such a Tk window is recorded in .gui.Wins
+ TkWin <- WinGet(TkWinName)
+ if (is.null(TkWin))
+ stop("menu does not exist, and the parent Tk window cannot be found!")
+ # Create the menu
+ Parent <- tkmenu(TkWin)
+ tkconfigure(TkWin, menu = Parent)
+ # Add an entry for this top menu in .guiMenus
+ .guiMenus[[Pname]] <- Parent
+ } else stop("unable to add menu\n(base menu does not exists)")
+ }
+ # Check that the name is not already used (for a menu entry, for instance)
+ items <- Parent$Items
+ if (!is.null(items) && Mname %in% items$name)
+ stop("the menu name is already used in this menu!")
+ # Now that the parent menu exists, we can create this menu
+ # Look where to place the underline (menu shortcut)
+ Under <- regexpr("&", Mname)
+ if (Under < 0) { # No '&', place the underline at first position
+ Under <- 0
+ item <- Mname
+ } else {
+ Under <- Under - 1 # Because Tk starts numbering at 0
+ item <- sub("&", "", Mname)
+ }
+ Child <- tkmenu(Parent, tearoff = tearoff)
+ tkadd(Parent, "cascade", label = item, menu = Child, underline = Under)
+ # Add an entry for this child menu in .guiMenus
+ .guiMenus[[menu]] <- Child
+ # ... and register it in the items of parent menu in .guiMenus
+ if (tearoff) options <- "tearoff = TRUE" else options <- "tearoff = FALSE"
+ entry <- data.frame(name = I(Mname), action = I("[menu]"), image = (""),
+ accel = I(""), options = I(options))
+ if (is.null(items))
+ .guiMenus[[Pname]]$Items <- entry
+ else
+ .guiMenus[[Pname]]$Items <- rbind(items, entry)
+ # Update the TempEnv version of .guiMenus
+ assignTemp(".guiMenus", .guiMenus)
+ return(invisible(menu))
+}
+
+"tkMenuAddItem" <-
+function (menu, item, action, image = "", accel = "", options = "")
+{
+ # Look if the menu exists (must be in .guiMenus in TempEnv)
+ .guiMenus <- getTemp(".guiMenus")
+ M <- .guiMenus[[menu]]
+ if (is.null(M)) {
+ # On the contrary to winMenuAddItem(), if the menu does not exist yet
+ # generate an error (but we can later change this behaviour, of course!)
+ stop("menu does not exist!")
+ }
+ # Look if the menu already exists
+ Items <- M$Items
+ if (!is.null(Items) && item %in% Items$name) {
+ # On the contrary to winMenuAddItem(), it is not allowed to add twice
+ # the same menu (would change value, but in Tk, it would add a second
+ # time the same menu)
+ stop("the menu item ", item, " already exists!")
+ }
+ # Add the entry at the end of the Tk menu (### TODO: allow other positions)
+ # First look if it is a command or a separator
+ if (regexpr("^-+$", item) > 0) { #This must be a command
+ tkadd(M, "separator")
+ action <- "[separator]"
+ options <- ""
+ } else { # This is a menu command
+ # Look for the '&', indicating where the underline should be located
+ Under <- regexpr("&", item)
+ if (Under < 0) { # No '&', place the underline at first position
+ Uopt <- ", underline = 0"
+ lbl <- item
+ } else {
+ Uopt <- paste(", underline =", Under - 1) # Tk starts numbering at 0
+ lbl <- sub("&", "", item)
+ }
+ # Do we have to add an image to the menu?
+ if (image != "") {
+ # Look if the image resource is available
+ Img <- ImgGet(image)
+ if (!is.null(Img)) {
+ Iopt <- paste(", image = '", as.character(Img), "'", sep ="")
+ } else Iopt <- ""
+ } else Iopt <- ""
+ # Do we have an accelerator defined for this menu?
+ if (accel != "") {
+ Aopt <- paste(', accelerator = "', accel, '"', sep = "")
+ # Compute the Tk accelerator and make corresponding binding
+ tkAccel <- paste("<", tolower(accel), ">", sep ="")
+ # 'ctrl+' becomes 'Control-'
+ tkAccel <- sub("ctrl[+]", "Control-", tkAccel)
+ # 'shift+' becomes 'Shift-'
+ tkAccel <- sub("shift[+]", "Shift-", tkAccel)
+ # 'alt+' becomes 'Alt-'
+ tkAccel <- sub("alt[+]", "Alt-", tkAccel)
+ # Get parent window name
+ pWin <- sub("^[$]Tk[.]([a-zA-Z0-9 _.-]+)/.*$", "\\1", menu)
+ # Create the binding
+ cmd <- paste('tkbind(WinGet("', pWin, '"), "', tkAccel,
+ '", function() tkMenuInvoke("', menu, '", "', item, '"))',
+ sep = "")
+ eval(parse(text = cmd))
+ } else Aopt <- ""
+ # Rework options
+ if (options == "") opts <- "" else opts <- paste(",", options)
+ cmd <- paste('tkadd(M, "command", label = "', lbl,
+ '", command = function() ', action, ', compound = "left"',
+ Iopt, Aopt, Uopt, opts, ')', sep = "")
+ eval(parse(text = cmd))
+ }
+ # Register this menu entry in .guiMenus
+ entry <- data.frame(name = I(item), action = I(action), image = I(image),
+ accel = I(accel), options = I(options))
+ items <- .guiMenus[[menu]]$Items
+ if (is.null(items))
+ .guiMenus[[menu]]$Items <- entry
+ else
+ .guiMenus[[menu]]$Items <- rbind(items, entry)
+ # Update the TempEnv version of .guiMenus
+ assignTemp(".guiMenus", .guiMenus)
+ return(invisible(item))
+}
+
+"tkMenuDelItem" <-
+function (menu, item)
+{
+ # Look if the menu exists (must be in .guiMenus in TempEnv)
+ .guiMenus <- getTemp(".guiMenus")
+ M <- .guiMenus[[menu]]
+ if (is.null(M)) return(invisible(FALSE))
+ # Look if the item exists
+ Items <- M$Items
+ Pos <- which(Items$name == item) - 1 # Because Tk menu indices start at 0
+ if (length(Pos) == 0) return(invisible())
+ # Check that this item is not a submenu (must use tkMenuDel() instead)
+ if (Items$action[Pos + 1] == "[menu]")
+ stop("item ", item, " is a submenu. Use tkMenuDel() instead!")
+ # Delete that entry
+ tkdelete(M, Pos)
+ # Eliminate that entry from .guiMenus
+ Items <- Items[Items$name != item, ]
+ .guiMenus[[menu]]$Items <- Items
+ # Update the TempEnv version of .guiMenus
+ assignTemp(".guiMenus", .guiMenus)
+ return(invisible(TRUE))
+}
+
+"tkMenuDel" <-
+function (menu)
+{
+ # Delete a whole menu and all submenus
+ # Look if the menu exists (must be in .gui.Menus in TempEnv)
+ .guiMenus <- getTemp(".guiMenus")
+ M <- .guiMenus[[menu]]
+ if (is.null(M)) return(invisible(FALSE))
+ # Look at all submenus to delete
+ Menus <- names(.guiMenus)
+ Mmatch <- (substr(Menus, 1, nchar(menu)) == menu)
+ dMenus <- sort(Menus[Mmatch], decreasing = TRUE) # Sort menus bottom to top
+ # Delete each menu in turn
+ for (i in 1:length(dMenus)) {
+ Pname <- dirname(dMenus[i])
+ P <- .guiMenus[[Pname]]
+ N <- basename(dMenus[i])
+ Items <- P$Items
+ Pos <- which(P$Items$name == N)
+ # If this is not a toplevel menu, Pos is Pos - 1
+ ### TODO: consider also tearoff menus that way!
+ if (regexpr("/", Pname) > 0) Pos <- Pos - 1
+ if (length(Pos) > 0) {
+ tkdelete(P, Pos)
+ .guiMenus[[Pname]]$Items <- Items[Items$name != N, ]
+ }
+ .guiMenus[[dMenus[i]]] <- NULL # Eliminate the entry
+ }
+ # Update the TempEnv version of .guiMenus
+ assignTemp(".guiMenus", .guiMenus)
+ return(invisible(TRUE))
+}
+
+"tkMenuChangeItem" <-
+function (menu, item, action = "", options = "")
+{
+ # The Tk version of MenuChangeItem()
+ # Look if the menu exists (must be in .guiMenus in TempEnv)
+ .guiMenus <- getTemp(".guiMenus")
+ M <- .guiMenus[[menu]]
+ if (is.null(M)) return(invisible(FALSE))
+ # Look if the item exists
+ Items <- M$Items
+ Pos <- which(Items$name == item) - 1 # Because Tk menu indices start at 0
+ if (length(Pos) == 0) return(invisible())
+ # Check that this item is not a submenu or a separator
+ Act <- Items$action[Pos + 1]
+ if (Act == "[separator]")
+ stop("item ", item, " is a separator; its state cannot be changed!")
+ if (Act == "[menu]")
+ stop("item ", item, " is a menu; its state cannot be changed!")
+ if (options != "") {
+ # Change the configuration of that entry
+ eval(parse(text = paste("tkentryconfigure(M, Pos, ", options, ")",
+ sep = "")))
+ }
+ # Do we need to change the action?
+ if (action != "" && action != Act) {
+ # Change the action
+ cmd <- paste('tkentryconfigure(M, Pos, command = function() ',
+ action, ')', sep = "")
+ eval(parse(text = cmd))
+ # Update .guiMenus
+ Items$action[Pos + 1] <- action
+ .guiMenus[[menu]]$Items <- Items
+ # Update the TempEnv version of .guiMenus
+ assignTemp(".guiMenus", .guiMenus)
+ return(invisible(TRUE))
+ }
+}
+
+"tkMenuStateItem" <-
+function (menu, item, active = TRUE)
+{
+ # The Tk version of MenuStateItem()
+ # Look if the menu exists (must be in .guiMenus in TempEnv)
+ .guiMenus <- getTemp(".guiMenus")
+ M <- .guiMenus[[menu]]
+ if (is.null(M)) return(invisible(FALSE)) # If menu does not exists!
+ # Look if the item exists
+ Items <- M$Items
+ Pos <- which(Items$name == item) - 1 # Because Tk menu indices start at 0
+ if (length(Pos) == 0) return(invisible())
+ # Check that this item is not a separator
+ if (Items$action[Pos + 1] == "[separator]")
+ stop("item ", item, " is a separator; its state cannot be changed!")
+ # Set state for that entry
+ State <- if (active) "normal" else "disabled"
+ tkentryconfigure(M, Pos, state = State)
+ return(invisible(active))
+}
+
+"tkMenuInvoke" <-
+function (menu, item)
+{
+ # Given a menu and an item in this menu, trigger the item action
+ # Look if the menu exists (must be in .guiMenus in TempEnv)
+ .guiMenus <- getTemp(".guiMenus")
+ M <- .guiMenus[[menu]]
+ if (is.null(M)) return(invisible(FALSE))
+ # Look if the item exists
+ Items <- M$Items
+ Pos <- which(Items$name == item) - 1 # Because Tk menu indices start at 0
+ if (length(Pos) == 0) return(invisible())
+ # Invoke this menu entry
+ tcl(M, "invoke", Pos)
+ return(invisible(TRUE))
+}
Added: pkg/svWidgets/R/tkTool.R
===================================================================
--- pkg/svWidgets/R/tkTool.R (rev 0)
+++ pkg/svWidgets/R/tkTool.R 2009-02-22 13:39:43 UTC (rev 115)
@@ -0,0 +1,253 @@
+"tkToolItems" <-
+function (toolbar)
+{
+ T <- getTemp(".guiTools")[[toolbar]]
+ if (is.null(T))
+ stop("unable to retrieve items for ", toolbar, "\n(toolbar ", toolbar, " does not exist)")
+ Titems <- T$Items
+ if (is.null(Titems)) res <- character(0) else res <- as.character(Titems$action)
+ if (length(res) > 0) names(res) <- Titems$name
+ return(res)
+}
+
+"tkToolAdd" <-
+function (toolbar, side = "top")
+{
+ # Get the toolbar name
+ Tname <- basename(toolbar)
+ # Get the name of the parent
+ Pname <- dirname(toolbar)
+ # Look if the parent exists (must be in .guiTools in TempEnv)
+ .guiTools <- getTemp(".guiTools")
+ # Do not create the toolbar if it already exists
+ if (toolbar %in% names(.guiTools))
+ stop("toolbar ", toolbar, " already exists!")
+ Parent <- .guiTools[[Pname]]
+ if (is.null(Parent)) {
+ # If base toolbar is a "root", try to create the corresponding Tk toolbar area
+ if (regexpr("/", Pname) < 0) {
+ # Get the name of the Tk window that hosts the menu
+ TkWinName <- sub("^[$]Tk[.]", "", Pname)
+ # Look if such a Tk window is recorded in .guiWins
+ TkWin <- WinGet(TkWinName)
+ if (is.null(TkWin))
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 115
More information about the Sciviews-commits
mailing list