[Sciviews-commits] r148 - in pkg/tcltk2: . R inst inst/tklibs inst/tklibs/Diagrams0.2 inst/tklibs/autoscroll1.1 inst/tklibs/ctext3.2 inst/tklibs/cursor0.2 inst/tklibs/datefield0.2 inst/tklibs/getstring0.1 inst/tklibs/history0.1 inst/tklibs/ico1.0 inst/tklibs/ipentry0.3 inst/tklibs/khim1.0 inst/tklibs/ntext0.81 inst/tklibs/snit1.0 inst/tklibs/swaplist0.2 inst/tklibs/tablelist4.10 inst/tklibs/tablelist4.10/doc inst/tklibs/tablelist4.10/scripts inst/tklibs/tooltip1.4 inst/tklibs/widget3.0 man win/src win/tklibs/winico0.6
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jul 2 23:48:04 CEST 2009
Author: phgrosjean
Date: 2009-07-02 23:48:03 +0200 (Thu, 02 Jul 2009)
New Revision: 148
Added:
pkg/tcltk2/R/tclTask.R
pkg/tcltk2/R/tcltk2-Internal.R
pkg/tcltk2/inst/tklibs/Diagrams0.2/
pkg/tcltk2/inst/tklibs/Diagrams0.2/.DS_Store
pkg/tcltk2/inst/tklibs/Diagrams0.2/ChangeLog
pkg/tcltk2/inst/tklibs/Diagrams0.2/draw_diagram.man
pkg/tcltk2/inst/tklibs/Diagrams0.2/draw_diagram.tcl
pkg/tcltk2/inst/tklibs/Diagrams0.2/example_anchor.tcl
pkg/tcltk2/inst/tklibs/Diagrams0.2/example_chemical.tcl
pkg/tcltk2/inst/tklibs/Diagrams0.2/example_circle.tcl
pkg/tcltk2/inst/tklibs/Diagrams0.2/example_fraction.tcl
pkg/tcltk2/inst/tklibs/Diagrams0.2/example_heater.tcl
pkg/tcltk2/inst/tklibs/Diagrams0.2/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/autoscroll1.1/
pkg/tcltk2/inst/tklibs/autoscroll1.1/.DS_Store
pkg/tcltk2/inst/tklibs/autoscroll1.1/ChangeLog
pkg/tcltk2/inst/tklibs/autoscroll1.1/autoscroll.man
pkg/tcltk2/inst/tklibs/autoscroll1.1/autoscroll.tcl
pkg/tcltk2/inst/tklibs/autoscroll1.1/example.tcl
pkg/tcltk2/inst/tklibs/autoscroll1.1/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/
pkg/tcltk2/inst/tklibs/ctext3.2/.DS_Store
pkg/tcltk2/inst/tklibs/ctext3.2/BUGS
pkg/tcltk2/inst/tklibs/ctext3.2/ChangeLog
pkg/tcltk2/inst/tklibs/ctext3.2/LICENSE
pkg/tcltk2/inst/tklibs/ctext3.2/README
pkg/tcltk2/inst/tklibs/ctext3.2/REGRESSION
pkg/tcltk2/inst/tklibs/ctext3.2/TODO
pkg/tcltk2/inst/tklibs/ctext3.2/ctext.man
pkg/tcltk2/inst/tklibs/ctext3.2/ctext.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/ctext_tcl.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/example.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/example_c.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/example_interactive.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/example_scroll.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/example_ws.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/function_finder.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/install.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/long_test_script
pkg/tcltk2/inst/tklibs/ctext3.2/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/ctext3.2/test.c
pkg/tcltk2/inst/tklibs/cursor0.2/
pkg/tcltk2/inst/tklibs/cursor0.2/.DS_Store
pkg/tcltk2/inst/tklibs/cursor0.2/ChangeLog
pkg/tcltk2/inst/tklibs/cursor0.2/cursor.man
pkg/tcltk2/inst/tklibs/cursor0.2/cursor.tcl
pkg/tcltk2/inst/tklibs/cursor0.2/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/datefield0.2/
pkg/tcltk2/inst/tklibs/datefield0.2/.DS_Store
pkg/tcltk2/inst/tklibs/datefield0.2/ChangeLog
pkg/tcltk2/inst/tklibs/datefield0.2/datefield.man
pkg/tcltk2/inst/tklibs/datefield0.2/datefield.tcl
pkg/tcltk2/inst/tklibs/datefield0.2/example.tcl
pkg/tcltk2/inst/tklibs/datefield0.2/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/getstring0.1/
pkg/tcltk2/inst/tklibs/getstring0.1/.DS_Store
pkg/tcltk2/inst/tklibs/getstring0.1/ChangeLog
pkg/tcltk2/inst/tklibs/getstring0.1/example.tcl
pkg/tcltk2/inst/tklibs/getstring0.1/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/getstring0.1/tk_getString.man
pkg/tcltk2/inst/tklibs/getstring0.1/tk_getString.tcl
pkg/tcltk2/inst/tklibs/history0.1/
pkg/tcltk2/inst/tklibs/history0.1/.DS_Store
pkg/tcltk2/inst/tklibs/history0.1/ChangeLog
pkg/tcltk2/inst/tklibs/history0.1/example.tcl
pkg/tcltk2/inst/tklibs/history0.1/history.tcl
pkg/tcltk2/inst/tklibs/history0.1/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/history0.1/tklib_history.man
pkg/tcltk2/inst/tklibs/ico1.0/
pkg/tcltk2/inst/tklibs/ico1.0/.DS_Store
pkg/tcltk2/inst/tklibs/ico1.0/ChangeLog
pkg/tcltk2/inst/tklibs/ico1.0/ico.man
pkg/tcltk2/inst/tklibs/ico1.0/ico.tcl
pkg/tcltk2/inst/tklibs/ico1.0/ico0.tcl
pkg/tcltk2/inst/tklibs/ico1.0/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/ipentry0.3/
pkg/tcltk2/inst/tklibs/ipentry0.3/.DS_Store
pkg/tcltk2/inst/tklibs/ipentry0.3/ChangeLog
pkg/tcltk2/inst/tklibs/ipentry0.3/ipentry.man
pkg/tcltk2/inst/tklibs/ipentry0.3/ipentry.tcl
pkg/tcltk2/inst/tklibs/ipentry0.3/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/khim1.0/
pkg/tcltk2/inst/tklibs/khim1.0/.DS_Store
pkg/tcltk2/inst/tklibs/khim1.0/ChangeLog
pkg/tcltk2/inst/tklibs/khim1.0/ROOT.msg
pkg/tcltk2/inst/tklibs/khim1.0/cs.msg
pkg/tcltk2/inst/tklibs/khim1.0/da.msg
pkg/tcltk2/inst/tklibs/khim1.0/de.msg
pkg/tcltk2/inst/tklibs/khim1.0/en.msg
pkg/tcltk2/inst/tklibs/khim1.0/es.msg
pkg/tcltk2/inst/tklibs/khim1.0/khim.man
pkg/tcltk2/inst/tklibs/khim1.0/khim.tcl
pkg/tcltk2/inst/tklibs/khim1.0/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/khim1.0/pl.msg
pkg/tcltk2/inst/tklibs/khim1.0/ru.msg
pkg/tcltk2/inst/tklibs/khim1.0/uk.msg
pkg/tcltk2/inst/tklibs/ntext0.81/
pkg/tcltk2/inst/tklibs/ntext0.81/.DS_Store
pkg/tcltk2/inst/tklibs/ntext0.81/ChangeLog
pkg/tcltk2/inst/tklibs/ntext0.81/NtextBindings.html
pkg/tcltk2/inst/tklibs/ntext0.81/TkTextBindings.html
pkg/tcltk2/inst/tklibs/ntext0.81/example.tcl
pkg/tcltk2/inst/tklibs/ntext0.81/example_bindings.tcl
pkg/tcltk2/inst/tklibs/ntext0.81/example_indent.tcl
pkg/tcltk2/inst/tklibs/ntext0.81/ntext.man
pkg/tcltk2/inst/tklibs/ntext0.81/ntext.sed
pkg/tcltk2/inst/tklibs/ntext0.81/ntext.tcl
pkg/tcltk2/inst/tklibs/ntext0.81/ntextBindings.man
pkg/tcltk2/inst/tklibs/ntext0.81/ntextIndent.man
pkg/tcltk2/inst/tklibs/ntext0.81/ntextWordBreak.man
pkg/tcltk2/inst/tklibs/ntext0.81/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/snit1.0/
pkg/tcltk2/inst/tklibs/snit1.0/.DS_Store
pkg/tcltk2/inst/tklibs/snit1.0/ChangeLog
pkg/tcltk2/inst/tklibs/snit1.0/README.txt
pkg/tcltk2/inst/tklibs/snit1.0/dictionary.txt
pkg/tcltk2/inst/tklibs/snit1.0/license.txt
pkg/tcltk2/inst/tklibs/snit1.0/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/snit1.0/roadmap.txt
pkg/tcltk2/inst/tklibs/snit1.0/snit.html
pkg/tcltk2/inst/tklibs/snit1.0/snit.man
pkg/tcltk2/inst/tklibs/snit1.0/snit.tcl
pkg/tcltk2/inst/tklibs/snit1.0/snit.test
pkg/tcltk2/inst/tklibs/snit1.0/snitfaq.html
pkg/tcltk2/inst/tklibs/snit1.0/snitfaq.man
pkg/tcltk2/inst/tklibs/swaplist0.2/
pkg/tcltk2/inst/tklibs/swaplist0.2/.DS_Store
pkg/tcltk2/inst/tklibs/swaplist0.2/ChangeLog
pkg/tcltk2/inst/tklibs/swaplist0.2/example.tcl
pkg/tcltk2/inst/tklibs/swaplist0.2/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/swaplist0.2/swaplist.man
pkg/tcltk2/inst/tklibs/swaplist0.2/swaplist.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/
pkg/tcltk2/inst/tklibs/tablelist4.10/.DS_Store
pkg/tcltk2/inst/tklibs/tablelist4.10/CHANGES.txt
pkg/tcltk2/inst/tklibs/tablelist4.10/COPYRIGHT.txt
pkg/tcltk2/inst/tklibs/tablelist4.10/ChangeLog
pkg/tcltk2/inst/tklibs/tablelist4.10/README.txt
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/.DS_Store
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/browse.png
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/bwidget.png
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/bwidget_tile.png
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/config.png
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/embeddedWindows.png
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/embeddedWindows_tile.png
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/index.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/styles.png
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelist.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistBWidget.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistBinding.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistColSort.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistCombobox.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistIwidgets.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistMentry.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistThemes.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistTile.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistTkCore.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tablelistWidget.html
pkg/tcltk2/inst/tklibs/tablelist4.10/doc/tileWidgets.png
pkg/tcltk2/inst/tklibs/tablelist4.10/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/.DS_Store
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/mwutil.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/repair.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistBind.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistBitmaps.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistConfig.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistEdit.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistMove.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistSort.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistThemes.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistUtil.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tablelistWidget.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/scripts/tclIndex
pkg/tcltk2/inst/tklibs/tablelist4.10/tablelist.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/tablelistPublic.tcl
pkg/tcltk2/inst/tklibs/tablelist4.10/tablelist_tile.tcl
pkg/tcltk2/inst/tklibs/tooltip1.4/
pkg/tcltk2/inst/tklibs/tooltip1.4/.DS_Store
pkg/tcltk2/inst/tklibs/tooltip1.4/ChangeLog
pkg/tcltk2/inst/tklibs/tooltip1.4/example.tcl
pkg/tcltk2/inst/tklibs/tooltip1.4/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/tooltip1.4/tipstack.tcl
pkg/tcltk2/inst/tklibs/tooltip1.4/tooltip.man
pkg/tcltk2/inst/tklibs/tooltip1.4/tooltip.tcl
pkg/tcltk2/inst/tklibs/widget3.0/
pkg/tcltk2/inst/tklibs/widget3.0/.DS_Store
pkg/tcltk2/inst/tklibs/widget3.0/ChangeLog
pkg/tcltk2/inst/tklibs/widget3.0/calendar.tcl
pkg/tcltk2/inst/tklibs/widget3.0/dateentry.tcl
pkg/tcltk2/inst/tklibs/widget3.0/dialog.tcl
pkg/tcltk2/inst/tklibs/widget3.0/example.R
pkg/tcltk2/inst/tklibs/widget3.0/example.tcl
pkg/tcltk2/inst/tklibs/widget3.0/mentry.tcl
pkg/tcltk2/inst/tklibs/widget3.0/panelframe.tcl
pkg/tcltk2/inst/tklibs/widget3.0/pkgIndex.tcl
pkg/tcltk2/inst/tklibs/widget3.0/ruler.tcl
pkg/tcltk2/inst/tklibs/widget3.0/scrollw.tcl
pkg/tcltk2/inst/tklibs/widget3.0/statusbar.tcl
pkg/tcltk2/inst/tklibs/widget3.0/stext.tcl
pkg/tcltk2/inst/tklibs/widget3.0/superframe.tcl
pkg/tcltk2/inst/tklibs/widget3.0/toolbar.tcl
pkg/tcltk2/inst/tklibs/widget3.0/widget.man
pkg/tcltk2/inst/tklibs/widget3.0/widget.tcl
pkg/tcltk2/inst/tklibs/widget3.0/widget_calendar.man
pkg/tcltk2/inst/tklibs/widget3.0/widget_toolbar.man
pkg/tcltk2/man/tclTask.Rd
pkg/tcltk2/test.R
Removed:
pkg/tcltk2/R/zzz.R
pkg/tcltk2/inst/tklibs/balloon1.2/
pkg/tcltk2/inst/tklibs/bwidget1.7/
pkg/tcltk2/inst/tklibs/ctext3.1/
pkg/tcltk2/inst/tklibs/cursor0.1/
pkg/tcltk2/inst/tklibs/toolbar1.0/
Modified:
pkg/tcltk2/.DS_Store
pkg/tcltk2/DESCRIPTION
pkg/tcltk2/NAMESPACE
pkg/tcltk2/NEWS
pkg/tcltk2/R/.DS_Store
pkg/tcltk2/R/tk2commands.R
pkg/tcltk2/R/tk2ico.R
pkg/tcltk2/R/tk2tip.R
pkg/tcltk2/R/tk2widgets.R
pkg/tcltk2/cleanup.win
pkg/tcltk2/inst/.DS_Store
pkg/tcltk2/man/setLanguage.Rd
pkg/tcltk2/man/tk2commands.Rd
pkg/tcltk2/man/tk2widgets.Rd
pkg/tcltk2/win/src/.DS_Store
pkg/tcltk2/win/tklibs/winico0.6/pkgIndex.tcl
Log:
Further tcltk2 editing
Modified: pkg/tcltk2/.DS_Store
===================================================================
(Binary files differ)
Modified: pkg/tcltk2/DESCRIPTION
===================================================================
--- pkg/tcltk2/DESCRIPTION 2009-06-29 20:34:15 UTC (rev 147)
+++ pkg/tcltk2/DESCRIPTION 2009-07-02 21:48:03 UTC (rev 148)
@@ -1,15 +1,16 @@
Package: tcltk2
Title: Tcl/Tk Additions
-Version: 1.0-9
-Date: 2009-06-27
+Version: 1.1-0
+Date: 2009-07-02
Depends: R (>= 2.4.0), tcltk
Suggests: utils
+SystemRequirements: Tcl/Tk (>= 8.5), Tktable (>= 2.9, optional)
Author: Philippe Grosjean <phgrosjean at sciviews.org>
-Description: A series of additional Tk widgets with style and various
- functions (under Windows: DDE exchange, access to the registry
- and icon manipulation) to supplement the tcltk package.
+Description: A series of additional Tcl commands and Tk widgets with style
+ and various functions (under Windows: DDE exchange, access to the
+ registry and icon manipulation) to supplement the tcltk package.
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
License: file LICENSE
URL: http://www.sciviews.org/SciViews-R
-Packaged: Sat Jun 27 15:18:14 2009; phgrosjean
Repository: CRAN
+Packaged: 2009-07-02 21:23:10 UTC; phgrosjean
Modified: pkg/tcltk2/NAMESPACE
===================================================================
--- pkg/tcltk2/NAMESPACE 2009-06-29 20:34:15 UTC (rev 147)
+++ pkg/tcltk2/NAMESPACE 2009-07-02 21:48:03 UTC (rev 148)
@@ -1,9 +1,17 @@
import(tcltk)
export(makeTclNames,
- tclFun,
+ tclAfter,
+ tclAfterCancel,
+ tclAfterInfo,
+ tclFun,
tclGetValue,
tclSetValue,
+ tclTaskChange,
+ tclTaskDelete,
+ tclTaskGet,
+ tclTaskRun,
+ tclTaskSchedule,
tclVarExists,
tclVarFind,
tclVarName,
@@ -47,9 +55,7 @@
tk2notetab.text,
tk2state.set,
is.tk,
- is.tile,
- tile.load,
- tile.use,
+ is.ttk,
tk2theme.elements,
tk2theme.list,
tk2theme,
@@ -86,3 +92,5 @@
tk2font.setstyle,
getLanguage,
setLanguage)
+
+S3method(print, tclTask)
\ No newline at end of file
Modified: pkg/tcltk2/NEWS
===================================================================
--- pkg/tcltk2/NEWS 2009-06-29 20:34:15 UTC (rev 147)
+++ pkg/tcltk2/NEWS 2009-07-02 21:48:03 UTC (rev 148)
@@ -1,5 +1,28 @@
= tcltk2 news
+== Version 1.1-0
+* Several Tcl packages are added, or upgraded:
+** autoscroll 1.1 (added)
+** ctext 3.2 (upgraded from 3.1)
+** cursor 0.2 (upgraded from 0.1)
+** datefiled 0.2 (added)
+** Diagrams 0.2 (added)
+** getstring 0.1 (added)
+** history 0.1 (added)
+** ico 0.1 (added, in partial replacement of Winico 0.6 )
+** ipentry 0.3 (added)
+** khim 1.0 (added)
+** ntext 0.81 (added)
+** snit 1.0 (added, and required by widget)
+** swaplist 0.2 (added)
+** tablelist 4.10 (added)
+** tooltip 1.4 (added and in replacement of the buggy balloon 1.2)
+** widget 3.0 (added)
+
+* There are new tclAfterXxx() and tclTaskXxx() functions to schedule tasks to
+ be executed later in R (using the Tcl 'after' function)
+
+
== Version 1.0-9
* tile and Tktable Tcl packages are eliminated. tcltk2 now uses ttk widgets that
come with Tk 8.5. You are supposed to install Tktable yourself (optional) if
Modified: pkg/tcltk2/R/.DS_Store
===================================================================
(Binary files differ)
Added: pkg/tcltk2/R/tclTask.R
===================================================================
--- pkg/tcltk2/R/tclTask.R (rev 0)
+++ pkg/tcltk2/R/tclTask.R 2009-07-02 21:48:03 UTC (rev 148)
@@ -0,0 +1,258 @@
+# tclTask.R - Functions to schedule task to be executed later using Tcl after
+# Copyright (c), Philippe Grosjean (phgrosjean at sciviews.org)
+# Licensed under LGPL 3 or above
+#
+# Changes:
+# - 2009-07-02: fisrt version (for tcltk2_1.1-0)
+
+"tclAfter" <-
+function (wait, fun)
+{
+ # This is the basic Tcl command, do prefer tclTaskSchedule()!
+ wait <- as.integer(wait)[1]
+ if (wait <= 0) wait <- "idle" # Schedule task on next event loop
+ # Check fun
+ if (!is.function(fun))
+ stop("'fun' must be a function")
+ # Install a new Tcl timer
+ tcl("after", wait, fun)
+}
+
+"tclAfterCancel" <-
+function (task)
+{
+ # Cancel a Tcl timer (no effect if the timer does not exist)
+ tcl("after", "cancel", as.character(task)[1])
+}
+
+"tclAfterInfo" <-
+function (task = NULL)
+{
+ # Get info about a Tcl timer, or list all current ones (using task = NULL)
+ if (is.null(task)) {
+ return(tcl("after", "info"))
+ } else {
+ # First check that task exists
+ task <- as.character(task)[1]
+ ok <- tclvalue(.Tcl(paste("catch {after info ", task, "}", sep = "")))
+ if (ok == 0) {
+ return(tcl("after", "info", task))
+ } else return(NULL)
+ }
+}
+
+"print.tclTask" <-
+function (x, ...)
+{
+ # Look when the task is run
+ if (x$wait == "idle") {
+ cat("tclTask '", x$id, "' scheduled on next event loop\n", sep = "")
+ } else {
+ cat("tclTask '", x$id, "' scheduled after ", x$wait, " ms ", sep = "")
+ # Determine how much is remaining
+ rem <- x$started + x$wait - proc.time()["elapsed"] * 1000
+ if (rem <= 0) {
+ cat("(elapsed)\n")
+ } else {
+ cat("(", as.integer(rem), " remaining)\n", sep = "")
+ }
+ }
+ # Look if it is rescheduled
+ if (isTRUE(x$redo)) {
+ cat("Rescheduled forever\n")
+ } else if (x$redo == FALSE || x$redo <= 0) {
+ cat("Not rescheduled\n")
+ } else if (x$redo == 1) {
+ cat("Rescheduled once\n")
+ } else {
+ cat("Rescheduled", x$redo, "times\n")
+ }
+ # Print the command to be executed
+ cat("runs:\n")
+ print(x$expr)
+ return(invisible(x))
+}
+
+"tclTaskSchedule" <-
+function (wait, expr, id = "task#", redo = FALSE)
+{
+ # Schedule a task to be executed after 'wait' ms
+ # If 'wait' is <= 0, schedule for execution on the next event loop
+ # Id is the task name to use (if the task already exists, it is deleted
+ # and replaced by the new definition)
+
+ wait <- as.integer(wait)[1]
+ if (wait <= 0) wait <- "idle" # Schedule task on next event loop
+
+ Tasks <- .getTclTasks()
+ TNames <- ls(Tasks, all = TRUE)
+
+ id <- as.character(id)[1]
+ # If 'id' contains '#', replace it by a number (first one available)
+ # but don't allow more than 1000 tasks with same name (to avoid bad
+ # situations with buggy code like infinite loops or so)
+ if (grepl("#", id)) {
+ for (i in 1:1000) {
+ Id <- sub("#", i, id)
+ if (!Id %in% TNames) break
+ }
+ if (Id %in% TNames)
+ stop("Too many tclTasks!")
+ } else {
+ # Delete the task if it already exists
+ if (id %in% TNames) tclTaskDelete(id)
+ Id <- id
+ }
+
+ if (!isTRUE(redo)) {
+ redo <- as.integer(redo)[1]
+ if (redo <= 0) redo <- FALSE
+ }
+
+ # Schedule the task, but don't run expr directly, but through tclTaskRun()
+ # Note: if I use tcl("after", wait, tclTaskRun(Id), R is blocked until the
+ # task is done. Here, I must provide the name of a function without args)
+ task <- .makeTclTask(id = Id, wait = wait)
+
+ # Create a tclTask object containing all info about this task
+ res <- list(task = task, id = Id, expr = substitute(expr),
+ started = proc.time()["elapsed"] * 1000, wait = wait,
+ redo = redo)
+ class(res) <- c("tclTask", class(res))
+
+ # Add this task to the list
+ Tasks[[Id]] <- res
+
+ return(invisible(res))
+}
+
+"tclTaskRun" <-
+function(id)
+{
+ # Execute the code associated with a given task and detemine if the task
+ # should be rescheduled again (repeat argument)
+ id <- as.character(id)[1]
+
+ Tasks <- .getTclTasks()
+ Task <- Tasks[[id]]
+ if (is.null(Task)) {
+ warning("tclTask '", id, "' is not found")
+ return(invisible(FALSE))
+ }
+ # Make sure to indicate that we run it once
+ if (!is.logical(Task$redo)) {
+ Task$redo <- Task$redo - 1
+ if (Task$redo < 1) Task$redo <- FALSE
+ }
+ # Update the original object too
+ Tasks[[id]] <- Task
+
+ # Run the code associate with this task
+ eval(Task$expr, envir = .GlobalEnv)
+
+ # Should we delete this task (if repeat is FALSE), or reschedule it?
+ # Note, we read Task again, in case fun() would have changed something there!
+ Task <- Tasks[[id]]
+ # Make sure the tcl timer is destroyed (in case tclTaskRun() is
+ # triggered otherwise)
+ tclTaskDelete(id)
+ if (Task$redo) {
+ # Reschedule the task
+ Task$task <- .makeTclTask(id = id, wait = Task$wait)
+ # and update information in .tclTasks
+ Tasks[[id]] <- Task
+ }
+ return(invisible(TRUE))
+}
+
+"tclTaskGet" <-
+function(id = NULL, all = FALSE)
+{
+ # If id is NULL, list all scheduled tasks, otherwise, give info about a
+ # particular scheduled task
+ if (is.null(id)) {
+ return(ls(.getTclTasks(), all = all))
+ } else {
+ # Get the data associated with a scheduled task
+ return(.getTclTasks()[[id]])
+ }
+}
+
+"tclTaskChange" <-
+function (id, expr, wait, redo)
+{
+ # Change a characteristic of a scheduled task
+ # Is there something to change?
+ if (missing(expr) && missing(wait) && missing(redo))
+ return(invisible(FALSE))
+ # Get task and change it
+ Tasks <- .getTclTasks()
+ Task <- Tasks[[id]]
+ if (is.null(Task)) {
+ warning("tclTask '", id, "' is not found")
+ return(invisible(FALSE))
+ }
+ if (!missing(expr)) Task$expr <- substitute(expr)
+ if (!missing(wait )) {
+ wait <- as.integer(wait)[1]
+ if (wait <= 0) wait <- "idle" # Schedule task on next event loop
+ Task$wait <- wait
+ }
+ if (!missing(redo)) {
+ if (!isTRUE(redo)) {
+ redo <- as.integer(redo)[1]
+ if (redo <= 0) redo <- FALSE
+ }
+ Task$redo <- redo
+ }
+ # Delete the task and recreate it with the new parameters
+ tclTaskDelete(id)
+ Task$task <- .makeTclTask(id = id, wait = Task$wait)
+
+ # Update Tasks
+ Tasks[[id]] <- Task
+
+ return(invisible(TRUE))
+}
+
+"tclTaskDelete" <-
+function (id)
+{
+ Tasks <- .getTclTasks()
+ # Remove a previously scheduled task (if id s NULL, then, remove all tasks)
+ if (is.null(id)) {
+ # Delete all current tasks
+ for (Task in ls(Tasks, all = TRUE))
+ tclAfterCancel(Tasks[[Task]]$task)
+ # Eliminate .tclTasks environment from TempEnv
+ rm(list = ".tclTasks", envir = .TempEnv())
+ } else {
+ # Delete only one task
+ Task <- Tasks[[id]]
+ if (!is.null(Task)) { # The task exists
+ tclAfterCancel(Task$task)
+ rm(list = id, envir = Tasks)
+ }
+ }
+}
+
+".getTclTasks" <-
+function ()
+{
+ # Retrieve references to all scheduled tasks
+ res <- .getTemp(".tclTasks", default = NULL)
+ if (is.null(res)) {
+ res <- new.env(parent = .TempEnv())
+ .assignTemp(".tclTasks", res)
+ }
+ return(res)
+}
+
+".makeTclTask" <-
+function (id, wait)
+{
+ run <- function ()
+ eval(parse(text = paste('tclTaskRun("', id, '")', sep = "")))
+ task <- tclAfter(wait, run)
+ return(task)
+}
Added: pkg/tcltk2/R/tcltk2-Internal.R
===================================================================
--- pkg/tcltk2/R/tcltk2-Internal.R (rev 0)
+++ pkg/tcltk2/R/tcltk2-Internal.R 2009-07-02 21:48:03 UTC (rev 148)
@@ -0,0 +1,127 @@
+# tcltk2-Internal.R - Hidden functions for tcltk2
+# Copyright (c), Philippe Grosjean (phgrosjean at sciviews.org)
+# Licensed under LGPL 3 or above
+#
+# Changes:
+# - 2009-07-02: tcltk2_1.1-0, added .Last.lib(), .TempEnv, .assignTemp() and
+# getTemp() and renamed from zzz.R to tcltk2-Internal.R
+# - 2007-01-01: first version (for tcltk2_1.0-0)
+#
+# TODO:
+# - Rework the tile stuff
+# - .onUnload() function (unload DLLs etc. but there are no DLLs any more!?)
+
+".onLoad" <-
+function(libname, pkgname) {
+ libdir <- file.path(libname, pkgname, "tklibs")
+
+ res <- addTclPath(libdir) # extend the Tcl/Tk path
+ ### TODO: add path to bin!
+ ### TODO: get windowing system with .Tcl("tk windowingsystem")
+ #Yes, .Platform$OS == "unix" in Mac. However, perhaps you're not
+ #interested in the OS type, though, but you're interested in the type
+ #of GUI. .Platform$GUI which is "AQUA" if you run R in the usual
+ #graphical UI window, but "X11" if you run R in X11 terminal or bash
+ #terminal window (and these really are different beasts GUI-wise).
+ #Further, .Platform$pkgType == "mac.binary" in CRAN releases of Mac R
+ #(but may be different if users have built R from the source).
+ #Function install.packages() uses .Platform$pkgType to detect the platform.
+
+ # Make sure that Tcl/Tk locale is the same one as current R locale
+ lang <- getLanguage()
+ if (lang != "") { # Set the same language for Tcl/Tk
+ res <- tclRequire("msgcat")
+ if (inherits(res, "tclObj")) tcl("::msgcat::mclocale", lang)
+ }
+
+ if (is.tk()) {
+ # Here is how we could install the supplementary material in Tcl
+ #tclRequire("combobox") # Version 2.3
+ #tclRequire("choosefont") # Version 0.2
+ #tclRequire("ctext") # Version 3.1
+ #tclRequire("cursor") # Version 0.1
+ #tclRequire("mclistbox") # Version 1.2
+ #Not provided any more -> tclRequire("Tktable") # Version 2.9
+
+ # The following code is not implemented as Tcl package... just source it
+ tcl("source", file.path(libdir, "notebook1.3", "notebook.tcl"))
+ tcl("source", file.path(libdir, "tree1.7", "tree.tcl"))
+
+ # Do we try to load the tile widgets? (only if Tcl./Tk < 8.5)
+ if (as.numeric(.Tcl("set tcl_version")) < 8.5) {
+# tcl("source", file.path(libdir, "fonts.tcl"))
+ # Define fonts used in Tk (note: must be done AFTER loading tile!)
+ ## Default values for system fonts are calculated by tile...
+ ## but they should be computer from the system, actually
+ ## We collect back those values calculated by tile and possibly override
+ ## them with better values
+# tk2font.setstyle(system = TRUE, default.styles = TRUE, text = TRUE)
+ ### TODO: reflect possible changes to other graphical toolkits (how?)
+ ### TODO: homogenize R console, R graph, SciTe fonts with these fonts
+ }
+ }
+ # Windows only
+ if (.Platform$OS.type == "windows") {
+ tclRequire("dde") # Version 1.2.2
+ # Not loaded automatically!
+ #tclRequire("registry") # Version 1.1.3
+ ### Don't work!? tclRequire("winico")
+ ### TODO: I cannot place the compiled dll in the right directory
+ ### => I use the default value provided at the end of package compilation!
+ #tcl("load", file.path(libdir, "winico0.6", "Winico06.dll"))
+ tcl("load", file.path(libname, pkgname, "libs", "Winico06.dll"))
+ # Also register the DDE server as TclEval|R
+ tk2dde("R")
+ }
+}
+
+### TO DO: .onUnload() that close downloaded tk items (or unload Tcl completely?)
+# Use package forget and change auto_path, ... or leave like this to avoid
+# breaking Tcl?
+
+".Last.lib" <-
+function (libpath)
+{
+ # Remove all currently scheduled tasks
+ tclTaskDelete(id = NULL)
+}
+
+".TempEnv" <-
+function ()
+{
+ pos <- match("TempEnv", search())
+ if (is.na(pos)) { # Must create it
+ TempEnv <- list()
+ attach(TempEnv, pos = length(search()) - 1)
+ rm(TempEnv)
+ pos <- match("TempEnv", search())
+ }
+ return(pos.to.env(pos))
+}
+
+".assignTemp" <-
+function (x, value, replace.existing = TRUE)
+ if (replace.existing || !exists(x, envir = .TempEnv(), mode = "any",
+ inherits = FALSE))
+ assign(x, value, envir = .TempEnv())
+
+".getTemp" <-
+function (x, default = NULL, mode = "any", item = NULL)
+{
+ if (is.null(item)) Mode <- mode else Mode <- "any"
+ if (exists(x, envir = .TempEnv(), mode = Mode, inherits = FALSE)) {
+ dat <- get(x, envir = .TempEnv(), mode = Mode, inherits = FALSE)
+ if (is.null(item)) return(dat) else {
+ item <- as.character(item)[1]
+ if (inherits(dat, "list") && item %in% names(dat)) {
+ dat <- dat[[item]]
+ if (mode != "any" && mode(dat) != mode) dat <- default
+ return(dat)
+ } else {
+ return(default)
+ }
+ }
+ } else { # Variable not found, return the default value
+ return(default)
+ }
+}
Property changes on: pkg/tcltk2/R/tcltk2-Internal.R
___________________________________________________________________
Name: svn:executable
+ *
Modified: pkg/tcltk2/R/tk2commands.R
===================================================================
--- pkg/tcltk2/R/tk2commands.R 2009-06-29 20:34:15 UTC (rev 147)
+++ pkg/tcltk2/R/tk2commands.R 2009-07-02 21:48:03 UTC (rev 148)
@@ -20,7 +20,7 @@
function(widget, items) {
# Set a list of values for a widget (e.g., combobox)
if (inherits(widget, "ttk2combobox")) {
- # Tile combobox uses -values parameter
+ # ttk::combobox uses -values parameter
tkconfigure(widget, values = as.character(items))
} else {
# Try to use the defaul method
@@ -36,7 +36,7 @@
function(widget, index = "end", ...) {
# Insert one or more items in a list
if (inherits(widget, "ttk2combobox")) {
- # Tile combobox uses -values parameter
+ # ttk::combobox uses -values parameter
Items <- as.character(unlist(list(...)))
if (length(Items) < 1) return() # Nothing to insert
List <- as.character(tcl(widget, "cget", "-values"))
@@ -63,7 +63,7 @@
function(widget, first, last = first) {
# Delete one or more items from a list
if (inherits(widget, "ttk2combobox")) {
- # Tile combobox uses -values parameter
+ # ttk::combobox uses -values parameter
List <- as.character(tcl(widget, "cget", "-values"))
if (length(List) < 2 && List == "") return(List) # The list in empty
if (last == "end") last <- length(List) else last <- last + 1
@@ -78,8 +78,8 @@
"tk2list.get" <-
function(widget, first = 0, last = "end") {
# Get the list of elements in a widget (e.g., combobox)
- if (inherits(widget, "ttk2combobox")) {
- # Tile combobox uses -values parameter
+ if (inherits(widget, "tk2combobox")) {
+ # ttk::combobox uses -values parameter
List <- as.character(tcl(widget, "cget", "-values"))
if (length(List) < 2 && List == "") return(List)
if (last == "end") last <- length(List) else last <- last + 1
@@ -92,8 +92,8 @@
"tk2list.size" <-
function(widget) {
# Get the length of the list of elements in a widget (e.g., combobox)
- if (inherits(widget, "ttk2combobox")) {
- # Tile combobox uses -values parameter
+ if (inherits(widget, "tk2combobox")) {
+ # ttk::combobox uses -values parameter
List <- as.character(tcl(widget, "cget", "-values"))
return(length(List))
} else {
@@ -105,20 +105,7 @@
function(widget, state = c("normal", "disabled", "readonly")) {
# Change the state of a widget
state <- as.character(state[1])
- # Treatment is different, depending if the widget is a tile widget, or not
- if (substring(class(widget)[1], 1, 3) == "ttk") {
- # This is a tile widget
- tkconfigure(widget, state = state)
- } else {
- # This is a plain Tk widget
- if (state == "readonly") {
- .Tcl(paste("catch {", widget$ID, " configure -editable false}", sep = ""))
- .Tcl(paste("catch {", widget$ID, " configure -state readonly}", sep = ""))
- } else {
- .Tcl(paste("catch {", widget$ID, " configure -editable true}", sep = ""))
- tkconfigure(widget, state = state)
- }
- }
+ tkconfigure(widget, state = state)
}
"tk2insert.multi" <-
@@ -134,17 +121,13 @@
}
"tk2notetraverse" <- function(nb) {
- # This function is only useful with tile widget
- if (!is.tile()) return(FALSE)
- tcl("ttk::notebook::enableTraversal", nb)
- return(TRUE)
+ res <- tcl("ttk::notebook::enableTraversal", nb)
+ return(invisible(res))
}
"tk2notetab" <-
function(nb, tab) {
- # Different treatment, depending if it is tile or nor
- if (inherits(nb, "ttk2notebook")) {
- # Tile notebook
+ if (inherits(nb, "tk2notebook")) {
# We need the tab index, so, look for it
ntab <- as.numeric(tcl(nb, "index", "end"))
if (ntab < 1) return(NULL)
@@ -165,30 +148,13 @@
class(w) <- c("ttk2notetab", "tk2container", "tkwin")
return(w)
} else return(NULL) # Tab not found!
- } else if (inherits(nb, "tk2notebook")) {
- # Plain Tk notebook
- tab <- tclvalue(.Tcl(paste("Notebook:frame", nb$ID,
- paste("{", tab, "}", sep = ""))))
- if (tab == "") {
- # This page does not exist!
- return(NULL)
- } else {
- # Create a simili tkwin object referring to this page
- w <- list()
- w$ID <- tab
- w$env <- new.env()
- w$env$num.subwin <- 0
- w$env$parent <- nb
- class(w) <- c("tk2notetab", "tk2container", "tkwin")
- return(w)
- }
- } else stop ("'nb' must be either a 'tk2notebook', or a 'ttk2notebook'")
+ } else stop ("'nb' must be a 'tk2notebook' object")
}
"tk2notetab.select" <-
function(nb, tab) {
- # Select a tab in a notebook, different depending if it is tile or not
- if (inherits(nb, "ttk2notebook")) {
+ # Select a tab in a notebook
+ if (inherits(nb, "tk2notebook")) {
# Tile notebook
# We need the tab index, so, look for it
ntab <- as.numeric(tcl(nb, "index", "end"))
@@ -203,39 +169,27 @@
tkselect(nb, tabidx)
return(invisible(TRUE))
} else return(invisible(FALSE))
- } else if (inherits(nb, "tk2notebook")) {
- ### TODO: would also like to raise a given page number!
- # Plain Tk notebook
- .Tcl(paste("Notebook:raise ", nb$ID, " {", tab[1], "}", sep = ""))
- return(invisible(tk2notetab.text(nb) == tab))
- } else stop ("'nb' must be either a 'tk2notebook', or a 'ttk2notebook'")
+ } else stop ("'nb' must be a 'tk2notebook' object")
}
"tk2notetab.text" <-
function(nb) {
- # Select a tab in a notebook, different depending if it is tile or not
- if (inherits(nb, "ttk2notebook")) {
- # Tile notebook
+ # Select a tab in a notebook
+ if (inherits(nb, "tk2notebook")) {
return(tclvalue(tcl(nb, "tab", "current", "-text")))
- } else if (inherits(nb, "tk2notebook")) {
- # Plain Tk notebook
- return(tclvalue(.Tcl(paste("Notebook:current", nb$ID))))
- } else stop ("'nb' must be either a 'tk2notebook', or a 'ttk2notebook'")
+ } else stop ("'nb' must be a 'tk2notebook' object")
}
# Themes management
"tk2theme.elements" <- function() {
- if (!is.tile()) return(NULL)
return(as.character(.Tcl("ttk::style element names")))
}
"tk2theme.list" <- function() {
- if (!is.tile()) return(NULL)
return(as.character(.Tcl("ttk::style theme names")))
}
"tk2theme" <- function(theme = NULL) {
- if (!is.tile()) return(NULL)
if (is.null(theme)) { # Get it
res <- getOption("tk2theme")
} else { # Set it to theme
@@ -275,58 +229,9 @@
return(tclvalue(.Tcl("catch { package present Tk }")) == 0)
}
-"is.tile" <-
-function() {
- # Tile, alias ttk widgets are automatically installed under Tk >= 8.5
- if (as.numeric(.Tcl("set tcl_version")) >= 8.5) return(TRUE)
- # Determine if tile is loaded, and if we want to use it
- use.tile <- getOption("tcltk2.tile")
- if (!is.null(use.tile) && !use.tile) return(FALSE)
- # Otherwise, look if the tile package is loaded
- return(tclvalue(.Tcl("catch { package present tile }")) == 0)
+"is.ttk" <-
+function ()
+{
+ res <- is.tk() && as.numeric(tcl("set", "tk_version")) >= 8.5
+ return(res)
}
-
-"tile.load" <-
-function(warn = TRUE) {
- if (!is.tk()) return(FALSE) # Impossible to load tile if tk is not loaded
- if (is.tile()) return(TRUE) # Already loaded
-
- # We must take care of fonts synchronisation and other stuff like
- # options(tcltk2.tile)
-
- # First delete all Tk* fonts created in Tcl/Tk (otherwise, loading of tile fails?!)
- tkfonts <- as.character(tkfont.names())
- tkfonts <- tkfonts[grep("^Tk", tkfonts)]
- for (font in tkfonts) tkfont.delete(font)
-
- # Try loading tile
- if (inherits(tclRequire("tile", warn = warn), "tclObj")) { # OK
- # Finalize fonts
- tk2font.setstyle(system = TRUE, default.styles = TRUE, text = TRUE)
- # Indicate that tile is loaded
- options(tcltk2.tile = TRUE)
- return(TRUE)
- } else { # Impossible to load tile (not installed on this machine?
- # We must restore Tk fonts
- # Look for a place to find it
- libs <- .libPaths()
- for (lib in libs) {
- fontfile <- file.path(lib, "tcltk2", "tklibs", "fonts.tcl")
- if (file.exists(fontfile)) {
- tcl("source", fontfile)
- break
- }
- }
- # Finalize fonts
- tk2font.setstyle(system = TRUE, default.styles = TRUE, text = TRUE)
- options(tcltk2.tile = FALSE)
- return(FALSE)
- }
-}
-
-"tile.use" <-
-function(use.it = TRUE) {
- options(tcltk2.tile = use.it)
- # Indicate also for Tcl code what we want
- if (use.it) .Tcl("set tile_use 1") else .Tcl("set tile_use 0")
-}
Modified: pkg/tcltk2/R/tk2ico.R
===================================================================
--- pkg/tcltk2/R/tk2ico.R 2009-06-29 20:34:15 UTC (rev 147)
+++ pkg/tcltk2/R/tk2ico.R 2009-07-02 21:48:03 UTC (rev 148)
@@ -5,19 +5,24 @@
# Changes:
# - 2007-01-01: fisrt version (for tcltk2_1.0-0)
+## TODO: replace all this by the ico package (tklib) and using
+## Image <- tclVar()
+## tcl("image", "create", "photo", Image, file = "myfile.gif")
+## tcl("wm", "iconphoto", tt, Image) instead of tk2ico.set
+
"tk2ico.create" <- function(iconfile) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (length(iconfile) != 1) stop("'iconfile' must be of length one!")
if (!file.exists(iconfile <- as.character(iconfile)))
stop(gettextf("File '%s' not found!", iconfile))
-
+
cmd <- paste("winico createfrom {", iconfile, "}", sep = "")
res <- try(icon <- .Tcl(cmd), silent = TRUE)
if (inherits(res, "try-error")) # Tcl error is unreadable, put another one!
stop("Error creating the icon resource; probably wrong 'iconfile'")
-
+
if (inherits(icon, "tclObj")) class(icon) <- c(class(icon), "tclIcon")
return(icon)
}
@@ -25,10 +30,10 @@
"tk2ico.destroy" <- function(icon) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (!inherits(icon, "tclIcon"))
stop("'icon' is not a \"tclIcon\" object!")
-
+
res <- tclvalue(.Tcl(paste("catch {winico delete ", icon, "}", sep = "")))
return(res == "0") # return "0" if OK, "1" otherwise
}
@@ -36,28 +41,28 @@
"tk2ico.hicon" <- function(icon) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (!inherits(icon, "tclIcon"))
stop("'icon' is not a \"tclIcon\" object!")
-
+
res <- try(hicon <- tcl("winico", "hicon", icon), silent = TRUE)
if (inherits(res, "try-error")) # Tcl error is unreadable, put another one!
stop("Error getting the icon handle for a \"tclIcon\" object!")
-
+
return(hicon)
}
"tk2ico.info" <- function(icon, convert = TRUE) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (!inherits(icon, "tclIcon"))
stop("'icon' is not a \"tclIcon\" object!")
-
+
res <- try(info <- as.character(tcl("winico", "info", icon)), silent = TRUE)
if (inherits(res, "try-error")) # Tcl error message is unreadable!
stop("Impossible to retrieve icon resource information!")
-
+
if (convert[1] == TRUE) { # Rework and transform into a data frame
info <- strsplit(info, "-")
info <- matrix(unlist(info), ncol = 8, byrow = TRUE)[, -1]
@@ -76,17 +81,17 @@
"tk2ico.load" <- function(file = "shell32.dll", res = "application") {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (length(file) != 1)
- stop("'file' must be of length one!")
+ stop("'file' must be of length one!")
if (length(res) != 1)
stop("'res' must be of length one!")
-
+
cmd <- paste("winico load ", res, " {", file, "}", sep = "")
res <- try(icon <- .Tcl(cmd), silent = TRUE)
if (inherits(res, "try-error")) # Tcl error message is unreadable!
stop("Unable to load the icon resource, 'file' or 'res' is wrong!")
-
+
if (inherits(icon, "tclObj")) class(icon) <- c(class(icon), "tclIcon")
return(icon)
}
@@ -94,13 +99,13 @@
"tk2ico.pos<-" <- function(icon, value) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (!inherits(icon, "tclIcon"))
stop("'icon' is not a \"tclIcon\" object!")
if (length(value) != 1 || !is.numeric(value))
stop("'value' must be numeric and of length one!")
value <- round(value)
-
+
res <- tclvalue(.Tcl(paste("catch {winico pos ", icon, " ", value, "}",
sep = "")))
if (res != "0") stop("Error while changing default position of the icon!")
@@ -111,7 +116,7 @@
function(win, icon, pos = NULL, type = c("all", "small", "big")) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
# win is either a tkwin object, or the HWND of a foreign window
if (!inherits(win, c("tkwin", "integer")) || length(win) < 1)
stop("'win' is not a \"tkwin\" object, or an integer (Window handle)!")
@@ -121,7 +126,7 @@
if (!is.null(pos) && (length(pos) != 1 || !is.numeric(pos)))
stop("'pos' must be numeric and of length one, or NULL!")
type <- match.arg(type)
-
+
if (type == "all") { # We search for highest quality icons
# Determine which icons are better in the resource
info <- tk2ico.info(icon, convert = TRUE)
@@ -146,7 +151,7 @@
# Compute res, a vector of two logical values, with "0" == success
res <- c((resSmall == "0"), (resBig == "0"))
names(res) <- c("small", "big")
-
+
} else {# Other type than 'all'
if (is.null(pos)) pos <- ""
res <- tclvalue(.Tcl(paste("catch {winico setwindow ", win, " ", icon,
@@ -161,24 +166,24 @@
rightmenu = NULL) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (!inherits(icon, "tclIcon"))
stop("'icon' is not a \"tclIcon\" object!")
-
+
if (length(pos) != 1 || !is.numeric(pos))
- stop("'pos' must be numeric and of length one, or NULL!")
-
- if (is.null(text)) text <- "" else
+ stop("'pos' must be numeric and of length one, or NULL!")
+
+ if (is.null(text)) text <- "" else
text <- paste (" -text {", paste(text, collapse = "\n"), "}", sep = "")
if (!inherits(leftmenu, c("tkwin", "NULL")))
stop("'leftmenu' must be a \"tkwin\" object or NULL!")
if (!inherits(rightmenu, c("tkwin", "NULL")))
- stop("'rightmenu' must be a \"tkwin\" object or NULL!")
-
+ stop("'rightmenu' must be a \"tkwin\" object or NULL!")
+
if (!is.null(leftmenu) || !is.null(rightmenu)) {
hicon <- tclvalue(tk2ico.hicon(icon))
-
+
if (is.null(leftmenu)) {
leftcmd <- ""; leftset <- ""
} else {
@@ -188,43 +193,43 @@
# ... and the appropriate name for our left-click menu
leftset <- paste('set leftmenu', hicon, ' ', leftmenu$ID, sep = "")
}
-
+
if (is.null(rightmenu)) {
rightcmd <- ""; rightset <- ""
} else {
# The command to trigger the right-click menu
rightcmd <- paste('if { $msg == "WM_RBUTTONUP" } { $::rightmenu',
- hicon, ' post $x $y }\n', sep = "")
+ hicon, ' post $x $y }\n', sep = "")
# ... and the appropriate name for our right-click menu
rightset <- paste('set rightmenu', hicon, ' ', rightmenu$ID, sep = "")
}
-
+
# Create the proc that will handle mouse clicks on our taskbar icon
cmd <- paste('catch { ', leftset, '\n', rightset, '\n',
'proc taskbarcallback', hicon, ' { hicon msg ico x y } {\n',
leftcmd, rightcmd, '}}', sep = "")
if (tclvalue(.Tcl(cmd)) != "0")
stop("Error while creating the callback for this icon!")
-
+
# Finally define the callback call
callback <- paste(' -callback "taskbarcallback', hicon, ' ', hicon,
' %m %i %X %Y"', sep = "")
} else callback <- ""
-
+
# Install the taskbar icon
res <- tclvalue(.Tcl(paste("catch {winico taskbar add ", icon, " -pos ",
round(pos), text, callback, "}", sep = "")))
-
+
return(res == "0") # "0" if success, "1" if error
}
"tk2ico.taskbar.delete" <- function(icon) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (!inherits(icon, "tclIcon"))
stop("'icon' is not a \"tclIcon\" object!")
-
+
# First delete the Tcl procs that handle our taskbar icon events
hicon <- tclvalue(tk2ico.hicon(icon))
.Tcl(paste('catch {',
@@ -232,7 +237,7 @@
'unset -nocomplain leftmenu', hicon, '\n',
'unset -nocomplain rightmenu', hicon, '\n',
'}', sep = ""))
-
+
# Then delete the taskbar icon
res <- tclvalue(.Tcl(paste("catch {winico taskbar delete ", icon, "}",
sep = "")))
@@ -249,11 +254,11 @@
if (!is.null(pos)) {
if (length(pos) != 1 || !is.numeric(pos))
stop("'pos' must be numeric and of length one, or NULL!")
- pos <- paste(" -pos", round(pos))
+ pos <- paste(" -pos", round(pos))
}
- if (is.null(text)) text <- "" else
+ if (is.null(text)) text <- "" else
text <- paste (" -text {", paste(text, collapse = "\n"), "}", sep = "")
-
+
cmd <- paste("catch {winico taskbar modify ", icon, pos, text, "}", sep = "")
return(tclvalue(.Tcl(cmd)) == "0") # "0" if OK, "1" otherwise
}
@@ -261,26 +266,26 @@
"tk2ico.text" <- function(icon) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(NULL)
-
+
if (!inherits(icon, "tclIcon"))
stop("'icon' is not a \"tclIcon\" object!")
-
+
res <- try(text <- tclvalue(tcl("winico", "text", icon)), silent = TRUE)
if (inherits(res, "try-error")) # Tcl error is unreadable, put another one!
stop("Error getting the text associated with an icon!")
-
+
return(res)
}
"tk2ico.text<-" <- function(icon, value) {
if (!is.tk()) return(NULL)
if (.Platform$OS.type != "windows") return(icon)
-
+
if (!inherits(icon, "tclIcon"))
stop("'icon' is not a \"tclIcon\" object!")
if (length(value) < 1)
stop("'value' must not be empty or NULL!")
-
+
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 148
More information about the Sciviews-commits
mailing list