gWidgetstcltk/0000755000176000001440000000000013652212707013126 5ustar ripleyusersgWidgetstcltk/NAMESPACE0000644000176000001440000001347312313710452014346 0ustar ripleyusersimport(methods) import(digest) import(tcltk) import(gWidgets) ## importFrom(gWidgets, ## "gwCat", ## "glabel", "gbutton", "gcheckbox", "gradio", "gdroplist", ## "gcheckboxgroup", "gspinbutton", "gslider", "gedit", "gtext", "gmenu", ## "gtoolbar", "gtable", "gdf", "gdfnotebook", "gtree", "gfile", ## "gfilebrowse", "gcalendar", "ggraphics", "ggraphicsnotebook", ## "gimage", "gstatusbar", "gseparator", "gcommandline", "ghelp", ## "ghelpbrowser", "ggenericwidget", "gvarbrowser", "gwindow", "ggroup", ## "gframe", "gexpandgroup", "gnotebook", "glayout", "gpanedgroup", ## "gmessage", "ginput", "gconfirm", "gbasicdialog", ## "addStockIcons","getStockIcons", ## "stockIconFromClass","stockIconFromObject", ## ".fixFontMessUp" ## ) ## importClassesFrom(gWidgets, ## "guiWidgetsToolkit", "guiWidgetsToolkitRGtk2", ## "guiWidget","guiComponent","guiContainer","guiDialog" ## ) ## importMethodsFrom(gWidgets, ## "[", ## "svalue", "svalue<-", "add", "addSpace", "addSpring", "delete", ## "dispose", "visible", "visible<-", "enabled", "enabled<-", "size", ## "size<-", "focus", "focus<-", "font", "font<-", "tag", "tag<-", "id", ## "id<-", "addhandler", "addhandlerchanged", "addhandlerkeystroke", ## "addhandlerclicked", "addhandlerdoubleclick", ## "addhandlerrightclick", "addhandlerfocus", ## "addhandlerblur", ## "addhandlerdestroy", "addhandlerexpose", "addhandlerunrealize", ## "addhandlermousemotion", ## "addhandleridle", "addpopupmenu", "add3rdmousepopupmenu", ## "adddropsource", "adddropmotion", "adddroptarget", ## "removehandler","blockhandler","unblockhandler", ## ".glabel", ".gbutton", ".gcheckbox", ".gradio", ".gdroplist", ## ".gcheckboxgroup", ".gspinbutton", ".gslider", ".gedit", ".gtext", ## ".gmenu", ".gtoolbar", ".gtable", ".gdf", ".gdfnotebook", ".gtree", ## ".gfile", ".gfilebrowse", ".gcalendar", ".ggraphics", ## ".ggraphicsnotebook", ".gimage", ".gstatusbar", ".gseparator", ## ".gcommandline", ".ghelp", ".ghelpbrowser", ".ggenericwidget", ## ".gvarbrowser", ".gwindow", ".ggroup", ".gframe", ".gexpandgroup", ## ".gnotebook", ".glayout", ".gpanedgroup", ".svalue", ".svalue<-", ## ".leftBracket", ".leftBracket<-", ".add", ".addSpace", ".addSpring", ## ".delete", ".dispose", ".visible", ".visible<-", ## ".enabled", ".size", ## ".enabled<-", ".size<-", ".focus", ".focus<-", ## ".font<-", ".tag", ".tag<-", ".id", ".id<-", ".addhandler", ".addhandlerchanged", ## ".addhandlerkeystroke", ".addhandlerclicked", ## ".addhandlerdoubleclick", ## ".addhandlerrightclick", ## ".addhandlerfocus", ## ".addhandlerblur", ## ".addhandlerdestroy", ".addhandlerexpose", ".addhandlerunrealize", ## ".addhandlermousemotion", ## ".addhandleridle", ".addpopupmenu", ".add3rdmousepopupmenu", ## ".adddropsource", ".adddropmotion", ".adddroptarget", ".gmessage", ## ".ginput", ".gconfirm", ".gbasicdialog", ## ".addStockIcons",".getStockIcons", ## ".stockIconFromClass",".stockIconFromObject", ## ".removehandler",".blockhandler",".unblockhandler", ## "update",".update", ## "length",".length", ## "dim",".dim", ## "dimnames",".dimnames", ## "dimnames<-",".dimnames<-", ## "names",".names", ## "names<-",".names<-", ## ".getToolkitWidget" ## ) ## #export("runHandlerFor") ## ## "Paste","stripWhiteSpace","rpel","str1","str2","untaintName", ## ## "stockIconFromClass","stockIconFromObject", ## ## "Timestamp","Timestamp<-", ## ## ## ## export("str2") exportMethods( "[", ".glabel", ".gbutton", ".gcheckbox", ".gradio", ".gdroplist", ".gcheckboxgroup", ".gspinbutton", ".gslider", ".gedit", ".gtext", ".gmenu", ".gtoolbar", ".gtable", ".gfile", ".gfilebrowse", ".ghtml", ".gimage", ".gstatusbar", ".gseparator", ".gvarbrowser", ".gwindow", ".ggroup", ".gframe", ".gexpandgroup", ".gnotebook", ".glayout", ".gpanedgroup", "svalue", "svalue<-", "add", "addSpace", "addSpring", "insert", "delete", "dispose", "visible", "visible<-", "defaultWidget","defaultWidget<-", "enabled", "enabled<-", "isExtant", "size", "size<-", "focus", "focus<-", "font", "font<-", "tag", "tag<-", "id", "id<-", "addhandler", "addhandlerchanged", "addhandlerkeystroke", "addhandlerclicked", "addhandlerdoubleclick", "addhandlerrightclick", "addhandlerfocus","addhandlerblur", "addhandlerdestroy", "addhandlerexpose", "addhandlerunrealize", "addhandlermousemotion", "addhandleridle", "addpopupmenu", "add3rdmousepopupmenu", "adddropsource", "adddropmotion", "adddroptarget", "removehandler","blockhandler","unblockhandler", ".svalue", ".svalue<-", ".leftBracket", ".leftBracket<-", ".add", ".addSpace", ".addSpring", ".insert", ".delete", ".dispose", ".visible", ".visible<-", ".defaultWidget",".defaultWidget<-", ".enabled", ".enabled<-", ".isExtant", ".size", ".size<-", ".focus", ".focus<-", ".font<-", ".tag", ".tag<-", ".id", ".id<-", ".addhandler", ".addhandlerchanged", ".addhandlerkeystroke", ".addhandlerclicked", ".addhandlerdoubleclick", ".addhandlerrightclick", ".addhandlerfocus",".addhandlerblur", ".addhandlerdestroy", ".addhandlerexpose", ".addhandlerunrealize", ".addhandlermousemotion", ".addhandleridle", ".addpopupmenu", ".add3rdmousepopupmenu", ".adddropsource", ".adddropmotion", ".adddroptarget", ".gmessage", ".ginput", ".gconfirm", ".gbasicdialog", ".removehandler",".blockhandler",".unblockhandler", ".svalue", "update",".update", "length",".length", "dim",".dim", "dimnames", "dimnames<-", "names",".names", "names<-",".names<-", ".gdf", ".gdfnotebook", ".gtree", ".gcalendar", ".ggraphics", ".ggraphicsnotebook", ".dimnames",".dimnames<-", ".getToolkitWidget" ) gWidgetstcltk/ChangeLog0000644000176000001440000005277511672170314014715 0ustar ripleyusers2011-12-14 john verzani * R/aaaR5classes.R: add check in is_init_msg for Entry widget that was giving issue with enabled when no initial text was given. (Thanks Yves) 2011-12-02 john verzani * R/ggroup.R: fix issue with parenting of group object that appeared in 2.14.0 (Thanks to Erich, Rich, and Patrick) 2011-12-01 john verzani * R/common.R (.addToStockIcons): bug fix, was setting in local copy of tcltkStockIcons, not global. Created new class to handle icons. (Thanks to Erich and Rich) 2011-10-26 john verzani * R/aaaR5classes.R (## f): Block recursive call to <> handler when setting value of gedit object. (Thanks Pat) 2011-10-25 john verzani * R/common.R (loadGWidgetIcons): remove assignInNamespace for 2.14.0. Thanks Erich 2011-10-14 john verzani * R/zzz.R (.onLoad): modfication to avoid loading methods package 2011-07-31 john verzani * R/tcltkFuns.R (getTopLevel): added generics to implement $, [[ and [[<- to interact with underlying object 2011-07-23 john verzani * R/zzz.R (.onLoad): changed icons for gcheckboxtable. Thanks to http://ryanfait.com/resources/custom-checkboxes-and-radio-buttons/ 2011-07-22 john verzani * R/gdialogs.R (gbasicdialog): Added do.buttons option to constructor (passed through ... of constructor). Added dispose method to delete dialog. 2011-07-20 john verzani * R/gcheckboxgrouptable.R: added (hacked) gcheckboxgroup with use.table option. Needs better images, along with button enter, but is working. * R/aaaR5classes.R: added base gComponentR5tcltk methods, factored out similar ones in child classes 2011-07-15 john verzani * R/gtree.R: fix to handler to open new values (use W not tr global) * R/gtable.R (.populateTable): clean up this function 2011-07-14 john verzani * R/gtable.R: worked on size issue of this widget. Cross my fingers... 2011-07-13 john verzani * DESCRIPTION (Version): version bump (45) * R/gcalendar.R: fixed gcalendar. It had issues when used within glayout.b * R/aaaR5classes.R: fix to gradio if items is logical * R/aaaGenerics.R: added ".add" method for tkwin objects. This allows tk widgets to be embedded. Eg.,: g = ggroup(cont=gwindow()) library(tkrplot) l = tkrplot(getToolkitWidget(g), function() hist(rnorm(100))) add(g, l) 2011-07-11 john verzani * R/gspinbutton.R: Big change. Went to R5 widget to use "command" for the handler, rather than hacking. This is an issue though -- doesn't work well with the Mac, exposing a bug that can be triggered by the following tcltk code: w <- tktoplevel() s <- tkwidget(w, "spinbox", from=0, to=10, increment=1) tkpack(s) tkconfigure(s, "command"=function(...) print("hi")) tcl(s, "set", 5L) ## clicking on spinbutton can cause continuous invoking of widget ## until focus is on spinbutton This might be fixed by 8.5.9 -- which has a ttk::spinbox, but 8.5.8 is the current version of tk for windows, ubuntu 11.04 and on my mac ;), so untested * R/gfile.R: added addhandlerchanged method. Didn't do yet ((un)blockhandler or removehandler). Use tag(obj, "entry") for that 2011-07-10 john verzani * R/aaaGenerics.R: changed default for fill for ggroup, gframe, gexpandgour -- uses fill in dirction opposite of packing 2011-07-06 john verzani * R/gwindow.R: add focus method for windows. Focusing a window raises window, focusing control gives that control the focus. * R/gimage.R: added digest call to file name to eliminate spaces (Thanks Erich) 2011-07-05 verzani * R/ghtml.R: added ghtml stub * R/gdroplist.R: fix to svalue<- so that event handlers are called. (Thanks Yves). fix to [ method-- return character(0), not NA when no selection * R/gcheckbox.R: fix to enabled<- and gcheckbox (Thanks Yves) * R/gfile.R: forgot call of tclvalue. Thanks Richie! 2011-07-03 John Verzani * R/gdroplist.R: issue with select and n=1, changed condition. Thanks Erich 2011-06-16 john verzani * R/aaaR5classes.R: fix to savlue and gradio. Thanks Richie! 2011-06-14 john verzani * R/gdroplist.R: fix to widget when single item with spaces. (Thanks Richie!) 2011-04-14 john verzani * R/gdialogs.R (onCancel): added event handler for window delete event with gbasicdialog -- should fix hang in windows (Thanks Erich) 2011-04-08 john verzani * R/gedit.R: didn't have width argument acted on. Thanks Erich! 2011-04-03 john verzani * R/gtoolbar.R: Fix to this -- had double window being created. Thanks Erich! * R/gdf.R: Fix bug with fontsize (thanks Carlos!) 2011-02-18 john verzani * R/gdroplist.R: change to how selected= argument handled. Can be a string with one of the values now. 2011-01-19 john verzani * R/gwindow.R (addHandlerDestroy): fixed issue with destroy call (the default handler). Also cleaned up addHanderUnrealize method. (Thanks again to Richie C.) * R/gedit.R: fixed up handler code to call that in R5 classes. Also tidied up gradio, gcheckboxgroup. (Thanks to Richie C. for pointing out the issue.) * R/aaaR5classes.R: fixed bug in remove_handler 2011-01-17 john verzani * R/aaaGenerics.R: worked on "add" method and its expand, fill, anchor arguments 2011-01-10 john verzani * R/gdroplist.R: fix for width if no intial items 2011-01-07 john verzani * R/aaaGenerics.R: fixed addHandlerRightClick. Thanks Marie V 2011-01-05 john verzani * R/aaaR5classes.R: can use "command" signal, not just tkbind. * R/gslider.R: using ttk::scale for themed widget. We give up the theme, but canuse the "command" binding. 2011-01-04 john verzani * R/gwindow.R: new method update to get window to naturally resize * R/glayout.R: added dim method 2011-01-02 john verzani * R/gcheckboxgroup.R: similar to gradio. Now based on R5 class * R/gradio.R: based on R5 class now, not on older. Allows one to extend/shorten length of radio group 2010-12-30 john verzani * R/gaction.R: added key.accel value. key.accel should be like "Control-a" * R/aaaGenerics.R (setenabled_ttkwidget): fixed enabled<- method * R/gexpandgroup.R: changed visible<- method to adjust height, not remove widget. Latter didn't resize gracefully. 2010-12-18 john verzani * R/gedit.R: changed backend to use a widget designed for autocompletion. 2010-11-23 john verzani * R/aaaGenerics.R: fixed isExtant 2010-11-07 john verzani * R/gcheckbox.R: call as.character on text before display -- fix bug when logical 2010-11-03 john verzani * R/aaaGenerics.R: fixed bug in addSpring. Still doesn't work horizontally * R/aaaGenerics.R: changed default anchor value to c(-1,1) or NW. This can be adjusted through through the option "gw:tcltkDefaultAnchor". 2010-11-01 john verzani * R/gslider.R (modifyLabel): added from=vector argument where values are run through sort(unique(...)) 2010-10-30 john verzani * R/gtable.R (.toCharacter.numeric): put round argument in constructor for Liviu 2010-10-20 john verzani * R/gimage.R: moved code into svalue<- method. Fix bug if no image initially specified. 2010-10-18 john verzani * R/gdf.R: fixed bug in svalue (doubled up); svalue<- implemented (index=TRUE needed) 2010-10-16 john verzani * R/gcheckbox.R: added use.togglebutton feature 2010-10-15 john verzani * R/gtable.R (.populateTable): fix to single column tables to avoid splitting on , or + * R/aaaGenerics.R: fixed focus<- method for tkwin 2010-10-05 john verzani * R/gtext.R (ladd): changed what is shown after text is added. Now moves to top, not bottom * R/aaaGenerics.R: fixed error with fill argument to add method for containers. 2010-09-18 john verzani * R/gnotebook.R: bug fix for closebuttons=TRUE * R/gpanedgroup.R: bug fix in svalue() method 2010-08-08 john verzani * R/gnotebook.R: added [ method to get children 2010-08-01 john verzani * R/gcalendar.R: added calendar selector 2010-07-26 john verzani * R/gtree.R (.treeColWidths): added svalue<- method to set by index 2010-07-25 john verzani * R/glayout.R: fix so that [ method can be used to retrieve widget at i,j 2010-07-24 john verzani * R/aaaHandlers.R: reimplemented this so that block/unblock work; others work as advertised, fix bug along the way 2010-07-16 john verzani * R/gtable.R (.computeWidths): Trying to fix size of table object 2010-07-05 john verzani * R/gedit.R: put in fix to handle NA values -- which were not handled gracefully. Use string to represent NA * R/gframe.R: was using old means to handle expand, ... arguments. Changed as this caused issues when using layouts. * R/ggroup.R: put default borderwidth to 0 -- was 10 for some reason which was too much space 2010-06-29 john verzani * R/gfile.R: bug fix; new initialdir argument (hidden) 2010-06-14 john verzani * R/gtable.R (.computeWidths): removed autoscroll call - caused issues with initial drawing of screen. Also in gtext. 2010-05-28 john verzani * R/gdroplist.R: svalue(obj, index=TRUE) <- -1 should work now (no value set) 2010-05-27 john verzani * R/gedit.R: added visible<- method 2010-05-22 john verzani * R/gdialogs.R: fix to dialogs when message includes detail (message has length 2 or more). * R/gfile.R: bug fix with hidden argument multiple 2010-05-20 john verzani * R/gradio.R: try to fix issue that handler called before variable is set. (ButtonRelease and tcl("after")). Fix to index=TRUE call 2010-05-19 john verzani * R/glabel.R: fix to svalue<- to collapse with '\n', not " ". Fix to svalue() to respect "\n". 2010-05-15 john verzani * R/gfile.R: added multiple=TRUE argument for file selection. Not yet in API, but will be * R/gtable.R (.computeWidths): fix to svalue(...,index=TRUE) Thanks Richie 2010-05-03 john verzani * R/gedit.R: removed spurious tkgrid call causing issues when combining with othter widgets. 2010-04-18 john verzani * R/gcheckboxgroup.R: put in use.table argument, ignored for now 2010-02-27 john verzani * R/gstatusbar.R: make argument not.toplevel for gstatusbar. 2009-09-09 john verzani * R/gtable.R (.computeWidths): fix for factor issue 2009-09-08 john verzani * R/gfile.R: took out hard coded value of 20 for width in gfilebrowse. Pass in through argument. 2009-08-25 john verzani * R/gslider.R: add [<- method * R/gspinbutton.R: added [<- method for gspinbutton. Value must have regular spacing 2009-06-24 john verzani * R/gcheckbox.R: fixes to this for enabled -- and gradio. * R/aaaGenerics.R: fix to enabled for nested ggroup objects 2009-06-11 john verzani * R/gtable.R (.populateTable): error calling with icon.FUN (.computeWidths): initial creation of coercing to data frame to give names. 2009-05-09 john verzani * R/gbutton.R: rewrote how icons are handled. Easier with findIcon function * R/gimage.R: rewrote as we changed the way stockicons are dealt with * R/gtable.R (.computeWidths): change to how we deal with column #0: used for icons now, rather than using for optional icon and first text label. 2009-05-07 john verzani * R/gedit.R: added typeahead to gedit 2009-05-06 john verzani * R/aaaGenerics.R (RightClick): fixed issue with Mac 2009-05-05 john verzani * R/gedit.R: removed redundant frame, handlerID * R/gdialogs.R: fixed bug in ginput * R/gframe.R: passed padding argument (from ggroup) in. * R/glabel.R: Removed unnecessary ttkframe * R/aaaGenerics.R: fixed addSpring. Fixed anchor argument for add. 2009-04-17 john verzani * R/gpanedgroup.R: fixed bug in svalue -- coerce to numeric 2009-03-07 john verzani * R/gtext.R (ladd): fixed bug with setting of spot when inserting (adding). Now goes to beginning or erd. 2009-02-07 john verzani * R/gdf.R: added new funtion if user has tktable package for Tcl installed. * R/gdialogs.R (onCancel): fixes to dialogs using tkmessagebox, ttkframe 2009-01-30 john verzani * R/gdialogs.R (onCancel): fix to basidcialog, make inherit from window not container (thanks Ben) 2009-01-28 john verzani * R/gwindow.R: put in tclServiceMode call in lieu of withdrawn, deiconify 2009-01-27 john verzani * R/gmenu.R: fix to get menu working with gbasicdialog (also other containers) 2009-01-26 john verzani * R/gwindow.R: put in some padding into contentFrame * R/gstatusbar.R: fix to ttklabel 2008-12-16 john verzani * R/gdialogs.R: added gbasicdialog for tcltk 2008-12-13 john verzani * R/aaaGenerics.R: fixed enabled method; made enabled inherited from parent in ".add" 2008-12-12 john verzani * R/gwindow.R: implemented visible<- that wasn't there 2008-12-11 john verzani * R/ggroup.R: added use.scrollwindow feature using autoscroll 2008-12-10 john verzani * R/gtext.R: added autoscroll feature, fixed tksee call for where=beginning * R/gtable.R: added autoscroll feature * R/gtree.R: added autoscroll feature * R/gexpandgroup.R: fix to pass along arguments properly 2008-12-09 john verzani * R/gnotebook.R: fixed expanding of widget * R/gwindow.R: added frame instance and redid how toolkbar and statusbars are packed in (uses grid). There was an issue with the standard getBlock(container), that forced change to getWidget(container). (Which makes sense to me anyways.) 2008-12-08 john verzani * R/gtext.R: added insert method to replace add method 2008-12-02 john verzani * R/aaaGenerics.R: fixed enabled to recurse into childComponents. Added properties childComponents, parentContainer to widgets through the ".add" methods to keep track of these items. This could allow for container traversal. 2008-11-19 john verzani * R/gdroplist.R: fixed bug with selected 2008-11-18 john verzani * R/gaction.R (.isgAction): implemente svalue<- 2008-11-16 john verzani * R/gslider.R (ttkscale): changed to use ttk::Scale * R/gframe.R: fixed issue with names<- 2008-11-15 john verzani * R/gdroplist.R: fixed svalue<- to drop dataframe to vector 2008-11-07 john verzani * R/gmenu.R: adde gaction to gmenu 2008-11-05 john verzani * R/gbutton.R: added gaction possibility for compatibility -- gaction is limited * R/gspinbutton.R: fixed sizem ethod -- no height option * R/gbutton.R: added size method here -- no height option * R/gspinbutton.R: added enabled method * R/ggraphics.R: shorten messge -- still no device 2008-10-28 john verzani * R/gdroplist.R: added width= argument (secrelty for now) to gcombobox. 2008-10-12 john verzani * R/gcheckboxgroup.R: fixed handler code to deal with ID as a list. 2008-10-09 john verzani * R/gcheckbox.R: fix to addHandlerChanged code, 2008-09-23 john verzani * R/gtable.R (icon.FUN): fixed visible<- method 2008-09-19 john verzani * R/gbutton.R: made svalue return a single string -- not a vector broken by " ". 2008-09-02 john verzani * R/gtable.R (svalue): bug with multiple=TRUE, fixed 2008-08-28 john verzani * R/gtable.R (.populateTable): removed left over debugging symbols. (.populateTable): fixed bug with more than 2 columns and extra column when just 1. 2008-08-26 john verzani * R/gtable.R (.computeWidths): fixed error when factors used 2008-08-21 john verzani * R/ggroup.R: fixed typo in svalue method 2008-08-08 john verzani * R/gfile.R: fix to initialfilename = "" 2008-08-07 john verzani * R/gtree.R: Fix to columns when a single one 2008-07-20 john verzani * R/zzz.R (.onLoad): check for version 8.5 2008-07-18 john verzani * R/gframe.R: fixed type preventing it from working 2008-05-17 jverzani * man/gWidgetstcltk-undocumented.Rd: fixed undocumented methods 2008-04-23 jverzani f * R/gdialogs.R: added parent argument to dialogs * R/glayout.R: fixed spacing argument * R/gwindow.R: fixed svalue/title code * R/gframe.R: put in svalue method to set padding * R/gcheckbox.R: fixed leftbracket to be able to retrieve text 2008-04-12 jverzani * R/gimage.R: addcheck to see if stock is in gWidgetstcltk package 2008-03-31 jverzani * R/aaaGenerics.R: added mousemotion handler - mouseover 2008-03-18 jverzani * R/aaaGenerics.R: added addHandler with export, fixed 2008-03-16 jverzani * R/aaaGenerics.R: Changed tag to use an environment instead of one big list stored in the namespace. Added e = new.env() to all constructors and replaced tag(), tag<-() * R/gfile.R: fixed filebrowse (Gabor G.) 2008-01-23 jverzani * R/gtext.R: fixed typo with wrap argument (Ron gui) 2008-01-21 jverzani * R/gtext.R: fixed bug with svalue(..., drop=TRUE) 2007-12-12 John Verzani * R/gtext.R: added setgrid=FALSE to tktext call to ensure sizing is done in pixels to be consistent with others. 2007-08-04 John Verzani * R/gtable.R: fixed filtering: keep copy of DF in allItems, update filter after obj[,] <- DF. Did not implement obj[i,j]<-val. 2007-08-03 John Verzani * R/gcheckboxgroup.R: fixed handlers for glabel (ed), gradio, gcheckbox, and gcheckboxgroup. The latter need to have a pause and the scoping wasn't correctly used 2007-08-01 John Verzani * R/gseparator.R: fixed to (not) work with gtable, before it was messing up with tkpack and tkgrid 2007-07-01 John Verzani * R/gdialogs.R (onCancel): use one function. Add space gWidgetstcltk/man/0000755000176000001440000000000012275245141013677 5ustar ripleyusersgWidgetstcltk/man/gWidgetstcltk-undocumented.Rd0000644000176000001440000013073612024764560021512 0ustar ripleyusers\name{gWidgetstcltk-undocumented} \alias{gWidgetstcltk-undocumented} \alias{runHandlerFor} \alias{str2} %% These were copied from gWidgetsRGtk2 \alias{[-methods} \alias{[,gWidgettcltk-method} \alias{[,gCheckboxtcltk-method} \alias{[,gCheckboxgrouptcltk-method} \alias{[,gCommandlinetcltk-method} \alias{[,gDroplisttcltk-method} \alias{[,gEdittcltk-method} \alias{[,gGridtcltk-method} \alias{[,gLayouttcltk-method} \alias{[,gMenutcltk-method} \alias{[,gNotebooktcltk-method} \alias{[,gRadiotcltk-method} \alias{[,tcltkDataFrame-method} \alias{[,gTabletcltk-method} \alias{[,gTableWithFiltertcltk-method} \alias{[,gToolbartcltk-method} \alias{[,gTreetcltk-method} \alias{[,gVarbrowsertcltk-method} \alias{.delete,gNotebooktcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.delete,gToolbartcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.svalue<-,gComponentR5tcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gExpandgrouptcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gExpandgrouptcltk,guiWidgetsToolkittcltk,ANY,numeric-method} \alias{.svalue<-,gNotebooktcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gRadiotcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gSlidertcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gSpinbuttontcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gStatusbartcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gTexttcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gToolbartcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gTreetcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gAddargtcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gBivariatetcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gModeltcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gTabletcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gTableWithFiltertcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gWindowtcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gFilebrowsetcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gPanedgrouptcltk,guiWidgetsToolkittcltk,ANY,ANY-method} %% %% %% -- .glabel -- %% \alias{.glabel-methods} \alias{.glabel,guiWidgetsToolkittcltk-method} %% %% -- .gbutton -- %% \alias{.gbutton-methods} \alias{.gbutton,guiWidgetsToolkittcltk-method} \alias{.gbutton,guiWidgetsToolkittcltk,ANY,ANY,ANY,ANY-method} \alias{.gbutton,guiWidgetsToolkittcltk,ANY,ANY,ANY,gActiontcltk-method} \alias{.gbutton,guiWidgetsToolkittcltk,ANY,ANY,ANY,guiComponent-method} %% %% -- .gcheckbox -- %% \alias{.gcheckbox-methods} \alias{.gcheckbox,guiWidgetsToolkittcltk-method} %% %% -- .gradio -- %% \alias{.gradio-methods} \alias{.gradio,guiWidgetsToolkittcltk-method} %% %% -- .gdroplist -- %% \alias{.gdroplist-methods} \alias{.gdroplist,guiWidgetsToolkittcltk-method} %% %% -- .gcheckboxgroup -- %% \alias{.gcheckboxgroup-methods} \alias{.gcheckboxgroup,guiWidgetsToolkittcltk-method} %% %% -- .gspinbutton -- %% \alias{.gspinbutton-methods} \alias{.gspinbutton,guiWidgetsToolkittcltk-method} %% %% -- .gslider -- %% \alias{.gslider-methods} \alias{.gslider,guiWidgetsToolkittcltk-method} %% %% -- .gedit -- %% \alias{.gedit-methods} \alias{.gedit,guiWidgetsToolkittcltk-method} %% %% -- .gtext -- %% \alias{.gtext-methods} \alias{.gtext,guiWidgetsToolkittcltk-method} %% %% -- .gmenu -- %% \alias{.gmenu-methods} \alias{.gmenu,guiWidgetsToolkittcltk-method} %% %% -- .gtoolbar -- %% \alias{.gtoolbar-methods} \alias{.gtoolbar,guiWidgetsToolkittcltk-method} %% %% -- .gtable -- %% \alias{.gtable-methods} \alias{.gtable,guiWidgetsToolkittcltk-method} %% %% -- .gdf -- %% \alias{.gdf-methods} \alias{.gdf,guiWidgetsToolkittcltk-method} %% %% -- .gdfnotebook -- %% \alias{.gdfnotebook-methods} \alias{.gdfnotebook,guiWidgetsToolkittcltk-method} %% %% -- .gtree -- %% \alias{.gtree-methods} \alias{.gtree,guiWidgetsToolkittcltk-method} %% %% -- .gfile -- %% \alias{.gfile-methods} \alias{.gfile,guiWidgetsToolkittcltk-method} %% %% -- .gfilebrowse -- %% \alias{.gfilebrowse-methods} \alias{.gfilebrowse,guiWidgetsToolkittcltk-method} %% %% -- .gcalendar -- %% \alias{.gcalendar-methods} \alias{.gcalendar,guiWidgetsToolkittcltk-method} %% %% -- .ggraphics -- %% \alias{.ggraphics-methods} \alias{.ggraphics,guiWidgetsToolkittcltk-method} %% %% -- .ggraphicsnotebook -- %% \alias{.ggraphicsnotebook-methods} \alias{.ggraphicsnotebook,guiWidgetsToolkittcltk-method} %% %% -- .gimage -- %% \alias{.gimage-methods} \alias{.gimage,guiWidgetsToolkittcltk-method} %% %% -- .gstatusbar -- %% \alias{.gstatusbar-methods} \alias{.gstatusbar,guiWidgetsToolkittcltk-method} %% %% -- .ghtml -- %% \alias{.ghtml-methods} \alias{.ghtml,guiWidgetsToolkittcltk-method} %% %% %% -- .gseparator -- %% \alias{.gseparator-methods} \alias{.gseparator,guiWidgetsToolkittcltk-method} %% %% -- .gcommandline -- %% \alias{.gcommandline-methods} \alias{.gcommandline,guiWidgetsToolkittcltk-method} %% %% -- .ghelp -- %% \alias{.ghelp-methods} \alias{.ghelp,guiWidgetsToolkittcltk-method} %% %% -- .ghelpbrowser -- %% \alias{.ghelpbrowser-methods} \alias{.ghelpbrowser,guiWidgetsToolkittcltk-method} %% %% -- .ggenericwidget -- %% \alias{.ggenericwidget-methods} \alias{.ggenericwidget,guiWidgetsToolkittcltk-method} %% %% -- .gvarbrowser -- %% \alias{.gvarbrowser-methods} \alias{.gvarbrowser,guiWidgetsToolkittcltk-method} %% %% -- .gwindow -- %% \alias{.gwindow-methods} \alias{.gwindow,guiWidgetsToolkittcltk-method} %% %% -- .ggroup -- %% \alias{.ggroup-methods} \alias{.ggroup,guiWidgetsToolkittcltk-method} %% %% -- .gframe -- %% \alias{.gframe-methods} \alias{.gframe,guiWidgetsToolkittcltk-method} %% %% -- .gexpandgroup -- %% \alias{.gexpandgroup-methods} \alias{.gexpandgroup,guiWidgetsToolkittcltk-method} %% %% -- .gnotebook -- %% \alias{.gnotebook-methods} \alias{.gnotebook,guiWidgetsToolkittcltk-method} %% %% -- .glayout -- %% \alias{.glayout-methods} \alias{.glayout,guiWidgetsToolkittcltk-method} %% %% -- .gpanedgroup -- %% \alias{.gpanedgroup-methods} \alias{.gpanedgroup,guiWidgetsToolkittcltk-method} %% %% -- .addStockIcons -- %% \alias{.addStockIcons-methods} \alias{.addStockIcons,guiWidgetsToolkittcltk-method} %% %% -- .getStockIcons -- %% \alias{.getStockIcons-methods} \alias{.getStockIcons,guiWidgetsToolkittcltk-method} %% %% -- stockIconFromClass, Object \alias{.stockIconFromClass-methods} \alias{.stockIconFromClass,guiWidgetsToolkittcltk-method} \alias{.stockIconFromObject-methods} \alias{.stockIconFromObject,guiWidgetsToolkittcltk-method} %% %% -- svalue -- %% \alias{svalue-methods} \alias{svalue,ANY-method} \alias{svalue,guiWidget-method} \alias{svalue,gWidgettcltk-method} \alias{svalue,character-method} \alias{svalue,GtkEntry-method} \alias{svalue,gSubsetbytcltk-method} \alias{svalue,GtkTreeViewColumn-method} %% %% -- .svalue -- %% \alias{.svalue-methods} \alias{.svalue,ANY-method} \alias{.svalue,character,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gActiontcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gActiontcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gButtontcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gCalendartcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gCheckboxtcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gCheckboxgrouptcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gCommandlinetcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gDroplisttcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gEdittcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,GtkEntry,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gExpandgrouptcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,GtkTreeView,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gGridtcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gGenericWidgettcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gHelptcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gImagetcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gLabeltcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gMenutcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gNotebooktcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gRadiotcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gSlidertcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gSpinbuttontcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gStatusbartcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gTexttcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gToolbartcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gTreetcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gVarbrowsertcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gAddargtcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gUnivariatetcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gUnivariateTabletcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gFileURLtcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gBivariatetcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gModeltcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gLmertcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gWindowtcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gCalendartcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gTabletcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gTableWithFiltertcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gFilebrowsetcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,gPanedgrouptcltk,ANY,ANY,guiWidgetsToolkittcltk-method} \alias{.svalue,character,guiWidgetsToolkittcltk-method} \alias{.svalue,gComponentR5tcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gButtontcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gCheckboxgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gCheckboxtcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gDroplisttcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gEdittcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gExpandgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gFilebrowsetcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gImagetcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gLabeltcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gMenutcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gPanedgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gRadiotcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gSlidertcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gSpinbuttontcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gStatusbartcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gTabletcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gTableWithFiltertcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gTexttcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gToolbartcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gTreetcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gVarbrowsertcltk,guiWidgetsToolkittcltk-method} \alias{.svalue,gWindowtcltk,guiWidgetsToolkittcltk-method} %% %% -- svalue<- -- %% \alias{svalue<--methods} \alias{svalue<-,guiWidget-method} \alias{svalue<-,gWidgettcltk-method} %% %% -- .svalue<- -- %% \alias{.svalue<--methods} \alias{.svalue<-,gActiontcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gButtontcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gCheckboxtcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gCalendartcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gCheckboxgrouptcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gCommandlinetcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gDroplisttcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gEdittcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,GtkEntry,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gExpandgrouptcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gGraphicstcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gGridtcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gGrouptcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gImagetcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gLabeltcltk,guiWidgetsToolkittcltk,ANY,ANY-method} \alias{.svalue<-,gMenutcltk,guiWidgetsToolkittcltk,ANY,list-method} \alias{.svalue<-,gMenutcltk,guiWidgetsToolkittcltk,ANY,gMenutcltk-method} \alias{.svalue<-,gMenutcltk,guiWidgetsToolkittcltk,ANY,guiWidget-method} \alias{.svalue<-,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gRadiotcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gSlidertcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gSpinbuttontcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gStatusbartcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gTexttcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gToolbartcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gAddargtcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gBivariatetcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gModeltcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gWindowtcltk,guiWidgetsToolkittcltk-method} \alias{.svalue<-,gFrametcltk,guiWidgetsToolkittcltk,ANY,ANY-method} %% %% -- .leftBracket -- %% \alias{.leftBracket-methods} \alias{.leftBracket,gComponentR5tcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gCheckboxtcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gCheckboxgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gCommandlinetcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gDroplisttcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gEdittcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gLayouttcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gMenutcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gRadiotcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,tcltkDataFrame,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gSlidertcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gTabletcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gTableWithFiltertcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gToolbartcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gTreetcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket,gVarbrowsertcltk,guiWidgetsToolkittcltk-method} %% %% -- .leftBracket<- -- %% \alias{.leftBracket<--methods} \alias{.leftBracket<-,gCheckboxtcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gComponentR5tcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gCheckboxgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gDroplisttcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gEdittcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,GtkTreeView,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gLayouttcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gMenutcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gRadiotcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gSlidertcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gSpinbuttontcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gTabletcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gTableWithFiltertcltk,guiWidgetsToolkittcltk-method} \alias{.leftBracket<-,gToolbartcltk,guiWidgetsToolkittcltk-method} %% %% -- add -- %% \alias{add-methods} \alias{add,guiWidget-method} \alias{add,gWidgettcltk-method} %% %% -- .add -- %% \alias{.add-methods} \alias{.add,guiWidget,guiWidgetsToolkittcltk,ANY-method} \alias{.add,guiWidget,guiWidgetsToolkittcltk,guiWidgetORgWidgettcltkORtcltkObject-method} \alias{.add,gBasicDialogNoParenttcltk,guiWidgetsToolkittcltk,guiWidget-method} \alias{.add,gBasicDialogNoParenttcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.add,gContainertcltk,guiWidgetsToolkittcltk,guiWidget-method} \alias{.add,gContainertcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.add,gContainertcltk,guiWidgetsToolkittcltk,tkwin-method} \alias{.add,gContainertcltk,guiWidgetsToolkittcltk,gGraphicstcltk-method} \alias{.add,gContainertcltk,guiWidgetsToolkittcltk,gMenutcltk-method} \alias{.add,gDfNotebooktcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.add,gExpandgrouptcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.add,gGrouptcltk,guiWidgetsToolkittcltk,gGraphicstcltk-method} \alias{.add,gGrouptcltk,guiWidgetsToolkittcltk,tcltkObject-method} \alias{.add,gHelptcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.add,gHelpbrowsertcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.add,gLayouttcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.add,gLayouttcltk,guiWidgetsToolkittcltk,gSeparatortcltk-method} \alias{.add,gMenutcltk,guiWidgetsToolkittcltk,guiWidget-method} \alias{.add,gMenutcltk,guiWidgetsToolkittcltk,gMenutcltk-method} \alias{.add,gMenutcltk,guiWidgetsToolkittcltk,list-method} \alias{.add,gNotebooktcltk,guiWidgetsToolkittcltk,guiWidget-method} \alias{.add,gNotebooktcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.add,gPanedgrouptcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.add,gTexttcltk,guiWidgetsToolkittcltk,character-method} \alias{.add,gTexttcltk,guiWidgetsToolkittcltk,guiWidget-method} \alias{.add,gTexttcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.add,gToolbartcltk,guiWidgetsToolkittcltk,list-method} \alias{.add,gWindowtcltk,guiWidgetsToolkittcltk,tcltkObject-method} \alias{.add,gWindowtcltk,guiWidgetsToolkittcltk,gStatusbartcltk-method} \alias{.add,gWindowtcltk,guiWidgetsToolkittcltk,gToolbartcltk-method} \alias{.add,gWindowtcltk,guiWidgetsToolkittcltk,gMenutcltk-method} \alias{.add,gWindowtcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.add,gWidgettcltk,guiWidgetsToolkittcltk,try-error-method} %% %% -- addSpace -- %% \alias{addSpace-methods} \alias{addSpace,guiWidget-method} \alias{addSpace,gWidgettcltk-method} %% %% -- .addSpace -- %% \alias{.addSpace-methods} \alias{.addSpace,gContainertcltk,guiWidgetsToolkittcltk-method} \alias{.addSpace,gExpandgrouptcltk,guiWidgetsToolkittcltk-method} %% %% -- addSpring -- %% \alias{addSpring-methods} \alias{addSpring,guiWidget-method} \alias{addSpring,gWidgettcltk-method} %% %% -- .addSpring -- %% \alias{.addSpring-methods} \alias{.addSpring,gContainertcltk,guiWidgetsToolkittcltk-method} \alias{.addSpring,gExpandgrouptcltk,guiWidgetsToolkittcltk-method} %% %% -- delete -- %% \alias{delete-methods} \alias{delete,guiWidget-method} \alias{delete,gWidgettcltk-method} %% %% -- .delete -- %% \alias{.delete-methods} \alias{.delete,gContainertcltk,guiWidgetsToolkittcltk,guiWidget-method} \alias{.delete,gContainertcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.delete,tcltkObject,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.delete,tcltkObject,guiWidgetsToolkittcltk,guiWidget-method} \alias{.delete,tcltkObject,guiWidgetsToolkittcltk,tcltkObject-method} \alias{.delete,gWidgettcltk,guiWidgetsToolkittcltk,tcltkObject-method} \alias{.delete,gMenutcltk,guiWidgetsToolkittcltk,guiWidget-method} \alias{.delete,gMenutcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.delete,gMenutcltk,guiWidgetsToolkittcltk,gMenutcltk-method} \alias{.delete,gMenutcltk,guiWidgetsToolkittcltk,list-method} \alias{.delete,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.delete,gNotebooktcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.delete,gPanedgrouptcltk,guiWidgetsToolkittcltk,gWidgettcltk-method} \alias{.delete,gToolbartcltk,guiWidgetsToolkittcltk-method} %% %% -- dispose -- %% \alias{dispose-methods} \alias{dispose,guiWidget-method} \alias{dispose,gWidgettcltk-method} \alias{dispose,gTexttcltk-method} %% %% -- .dispose -- %% \alias{.dispose-methods} \alias{.dispose,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.dispose,gBasicDialogNoParenttcltk,guiWidgetsToolkittcltk-method} \alias{.dispose,gHelptcltk,guiWidgetsToolkittcltk-method} \alias{.dispose,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.dispose,gTexttcltk,guiWidgetsToolkittcltk-method} \alias{.dispose,gWindowtcltk,guiWidgetsToolkittcltk-method} %% -- .insert -- %% \alias{.insert-methods} \alias{.insert,gTexttcltk,guiWidgetsToolkittcltk-method} %% %% %% -- visible -- %% \alias{visible-methods} \alias{visible,guiWidget-method} \alias{visible,gWidgettcltk-method} %% %% -- .visible -- %% \alias{.visible-methods} \alias{.visible,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.visible,gBasicDialogNoParenttcltk,guiWidgetsToolkittcltk-method} \alias{.visible,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.visible,gExpandgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.visible,gLayouttcltk,guiWidgetsToolkittcltk-method} \alias{.visible,tkwin,guiWidgetsToolkittcltk-method} \alias{.visible,gTabletcltk,guiWidgetsToolkittcltk-method} %% %% -- visible<- -- %% \alias{visible<--methods} \alias{visible<-,guiWidget-method} \alias{visible<-,gWidgettcltk-method} \alias{visible<-,gEdittcltk-method} %% %% -- .visible<- -- %% \alias{.visible<--methods} \alias{.visible<-,gWidgettcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.visible<-,gEdittcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.visible<-,gExpandgrouptcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.visible<-,gGraphicstcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.visible<-,gGridtcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.visible<-,gLayouttcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.visible<-,gTabletcltk,ANY-method} \alias{.visible<-,gTabletcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.visible<-,gWindowtcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.visible<-,tkwin,guiWidgetsToolkittcltk,ANY-method} %% %% -- enabled -- %% \alias{enabled-methods} \alias{enabled,guiWidget-method} \alias{enabled,gWidgettcltk-method} %% %% -- .enabled -- %% \alias{.enabled-methods} \alias{.enabled,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- enabled<- -- %% \alias{enabled<--methods} \alias{enabled<-,guiWidget-method} \alias{enabled<-,gWidgettcltk-method} %% %% -- .enabled<- -- %% \alias{.enabled<--methods} \alias{.enabled<-,gWidgettcltk,guiWidgetsToolkit-method} \alias{.enabled<-,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.enabled<-,tcltkObject,guiWidgetsToolkittcltk-method} \alias{.enabled<-,gComponentR5tcltk,guiWidgetsToolkittcltk-method} \alias{.enabled<-,gActiontcltk,guiWidgetsToolkittcltk-method} \alias{.enabled<-,gCheckboxgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.enabled<-,gCheckboxtcltk,guiWidgetsToolkittcltk-method} \alias{.enabled<-,gRadiotcltk,guiWidgetsToolkittcltk-method} \alias{.enabled<-,gSpinbuttontcltk,guiWidgetsToolkittcltk-method} %% %% -- size -- %% \alias{size-methods} \alias{size,guiWidget-method} \alias{size,gWidgettcltk-method} %% %% -- .size -- %% \alias{.size-methods} \alias{.size,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.size,gWindowtcltk,guiWidgetsToolkittcltk-method} %% %% -- size<- -- %% \alias{size<--methods} \alias{size<-,guiWidget-method} \alias{size<-,gWidgettcltk-method} %% %% -- .size<- -- %% \alias{.size<--methods} \alias{.size<-,gWidgettcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gWindowtcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gComponenttcltk,guiWidgetsToolkittcltk-method} \alias{.size<-,gComponenttcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gContainertcltk,guiWidgetsToolkittcltk-method} \alias{.size<-,gContainertcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gButtontcltk,guiWidgetsToolkittcltk-method} \alias{.size<-,gButtontcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gEdittcltk,guiWidgetsToolkittcltk-method} \alias{.size<-,gEdittcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.size<-,gGridtcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gImagetcltk,guiWidgetsToolkittcltk-method} \alias{.size<-,gImagetcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.size<-,gSeparatortcltk,guiWidgetsToolkittcltk-method} \alias{.size<-,gSeparatortcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gSpinbuttontcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gTabletcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gTableWithFiltertcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gTreetcltk,guiWidgetsToolkittcltk,ANY-method} \alias{.size<-,gVarbrowsertcltk,guiWidgetsToolkittcltk-method} %% %% -- focus -- %% \alias{focus-methods} \alias{focus,guiWidget-method} \alias{focus,gWidgettcltk-method} %% %% -- .focus -- %% \alias{.focus-methods} \alias{.focus,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.focus,gWindowtcltk,guiWidgetsToolkittcltk-method} %% %% -- focus<- -- %% \alias{focus<--methods} \alias{focus<-,guiWidget-method} \alias{focus<-,gWidgettcltk-method} \alias{focus<-,tcltkObject-method} %% %% -- .focus<- -- %% \alias{.focus<--methods} \alias{.focus<-,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.focus<-,gWindowtcltk,guiWidgetsToolkittcltk-method} \alias{.focus<-,tcltkObject,guiWidgetsToolkittcltk-method} %% %% -- defaultWidget -- %% \alias{defaultWidget-methods} \alias{defaultWidget,guiWidget-method} \alias{defaultWidget,gWidgettcltk-method} %% %% -- .defaultWidget -- %% \alias{.defaultWidget-methods} \alias{.defaultWidget,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- defaultWidget<- -- %% \alias{defaultWidget<--methods} \alias{defaultWidget<-,guiWidget-method} \alias{defaultWidget<-,gWidgettcltk-method} \alias{defaultWidget<-,tcltkObject-method} %% %% -- .defaultWidget<- -- %% \alias{.defaultWidget<--methods} \alias{.defaultWidget<-,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.defaultWidget<-,GtkWindow,guiWidgetsToolkittcltk-method} \alias{.defaultWidget<-,tcltkObject,guiWidgetsToolkittcltk-method} %% %% -- font -- %% \alias{font-methods} \alias{font,guiWidget-method} \alias{font,gWidgettcltk-method} %% %% -- .font -- %% \alias{.font-methods} \alias{.font,GtkWindow,guiWidgetsToolkittcltk-method} %% %% -- font<- -- %% \alias{font<--methods} \alias{font<-,guiWidget-method} \alias{font<-,gWidgettcltk-method} %% %% -- .font<- -- %% \alias{.font<--methods} \alias{.font<-,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.font<-,tcltkObject,guiWidgetsToolkittcltk-method} \alias{.font<-,gExpandgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.font<-,gFrametcltk,guiWidgetsToolkittcltk-method} \alias{.font<-,gTexttcltk,guiWidgetsToolkittcltk-method} %% %% -- tag -- %% \alias{tag-methods} \alias{tag,guiWidget-method} \alias{tag,gWidgettcltk-method} \alias{tag,tcltkObject-method} %% %% -- .tag -- %% \alias{.tag-methods} \alias{.tag,guiWidget,guiWidgetsToolkittcltk-method} \alias{.tag,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.tag,gActiontcltk,guiWidgetsToolkittcltk-method} \alias{.tag,tcltkObject,guiWidgetsToolkittcltk-method} %% %% -- tag<- -- %% \alias{tag<--methods} \alias{tag<-,guiWidget-method} \alias{tag<-,gWidgettcltk-method} \alias{tag<-,tcltkObject-method} %% %% -- .tag<- -- %% \alias{.tag<--methods} \alias{.tag<-,guiWidget,guiWidgetsToolkittcltk-method} \alias{.tag<-,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.tag<-,gActiontcltk,guiWidgetsToolkittcltk-method} \alias{.tag<-,tcltkObject,guiWidgetsToolkittcltk-method} %% %% -- id -- %% \alias{id-methods} \alias{id,guiWidget-method} \alias{id,gWidgettcltk-method} \alias{id,tcltkObject-method} \alias{id,ANY-method} \alias{id,GtkTreeViewColumn-method} %% %% -- .id -- %% \alias{.id-methods} \alias{.id,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.id,tcltkObject,guiWidgetsToolkittcltk-method} %% %% -- id<- -- %% \alias{id<--methods} \alias{id<-,guiWidget-method} \alias{id<-,gWidgettcltk-method} \alias{id<-,tcltkObject-method} \alias{id<-,ANY-method} \alias{id<-,GtkTreeViewColumn-method} %% %% -- .id<- -- %% \alias{.id<--methods} \alias{.id<-,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- removehandler -- %% \alias{removehandler-methods} \alias{removehandler,guiWidget-method} \alias{removehandler,gWidgettcltk-method} \alias{removehandler,tcltkObject-method} \alias{removehandler,GtkTreeViewColumn-method} %% %% -- .removehandler -- %% \alias{.removehandler-methods} \alias{.removehandler,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.removehandler,tcltkObject,guiWidgetsToolkittcltk-method} \alias{.removehandler,gComponentR5tcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandler -- %% \alias{addhandler-methods} \alias{addhandler,guiWidget-method} \alias{addhandler,gWidgettcltk-method} \alias{addhandler,tcltkObject-method} %% %% -- .addhandler -- %% \alias{.addhandler-methods} \alias{.addhandler,guiWidget,guiWidgetsToolkittcltk-method} \alias{.addhandler,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandler,tcltkObject,guiWidgetsToolkittcltk-method} %% -- blockhandler -- %% \alias{blockhandler-methods} \alias{blockhandler,guiWidget-method} \alias{blockhandler,gWidgettcltk-method} \alias{blockhandler,tcltkObject-method} \alias{blockhandler,GtkTreeViewColumn-method} %% %% -- .blockhandler -- %% \alias{.blockhandler-methods} \alias{.blockhandler,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.blockhandler,tcltkObject,guiWidgetsToolkittcltk-method} \alias{.blockhandler,gComponentR5tcltk,guiWidgetsToolkittcltk-method} %% -- unblockhandler -- %% \alias{unblockhandler-methods} \alias{unblockhandler,guiWidget-method} \alias{unblockhandler,gWidgettcltk-method} \alias{unblockhandler,tcltkObject-method} \alias{unblockhandler,GtkTreeViewColumn-method} %% %% -- .unblockhandler -- %% \alias{.unblockhandler-methods} \alias{.unblockhandler,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.unblockhandler,tcltkObject,guiWidgetsToolkittcltk-method} \alias{.unblockhandler,gComponentR5tcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerchanged -- %% \alias{addhandlerchanged-methods} \alias{addhandlerchanged,guiWidget-method} \alias{addhandlerchanged,gWidgettcltk-method} \alias{addhandlerchanged,tcltkObject-method} \alias{addhandlerchanged,ANY-method} \alias{addhandlerchanged,gSubsetbytcltk-method} \alias{addhandlerchanged,gSubsetbytcltk-method} %% %% -- .addhandlerchanged -- %% \alias{.addhandlerchanged-methods} \alias{.addhandlerchanged,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gCheckboxtcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gCheckboxgroupTabletcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gEdittcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gExpandgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gSubsetbytcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gLabeltcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gTexttcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gRadiotcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gSlidertcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gSpinbuttontcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gButtontcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gCalendartcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gCheckboxgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gDroplisttcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gFilebrowsetcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gImagetcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gTabletcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gTableWithFiltertcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerchanged,gVarbrowsertcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerkeystroke -- %% \alias{addhandlerkeystroke-methods} \alias{addhandlerkeystroke,guiWidget-method} \alias{addhandlerkeystroke,gWidgettcltk-method} \alias{addhandlerkeystroke,tcltkObject-method} %% %% -- .addhandlerkeystroke -- %% \alias{.addhandlerkeystroke-methods} \alias{.addhandlerkeystroke,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerkeystroke,gEdittcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerkeystroke,gSpinbuttontcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerkeystroke,gTexttcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerkeystroke,gTabletcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerclicked -- %% \alias{addhandlerclicked-methods} \alias{addhandlerclicked,guiWidget-method} \alias{addhandlerclicked,gWidgettcltk-method} \alias{addhandlerclicked,tcltkObject-method} %% %% -- .addhandlerclicked -- %% \alias{.addhandlerclicked-methods} \alias{.addhandlerclicked,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gButtontcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gCheckboxgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gCheckboxgroupTabletcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gDroplisttcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gGraphicstcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gImagetcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gLabeltcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gCheckboxtcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gRadiotcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gSpinbuttontcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gTabletcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerclicked,gTableWithFiltertcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerdoubleclick -- %% \alias{addhandlerdoubleclick-methods} \alias{addhandlerdoubleclick,guiWidget-method} \alias{addhandlerdoubleclick,gWidgettcltk-method} \alias{addhandlerdoubleclick,tcltkObject-method} %% %% -- .addhandlerdoubleclick -- %% \alias{.addhandlerdoubleclick-methods} \alias{.addhandlerdoubleclick,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerdoubleclick,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerdoubleclick,gTreetcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerdoubleclick,gTabletcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerdoubleclick,gTableWithFiltertcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerrightclick -- %% \alias{addhandlerrightclick-methods} \alias{addhandlerrightclick,guiWidget-method} \alias{addhandlerrightclick,gWidgettcltk-method} \alias{addhandlerrightclick,tcltkObject-method} %% %% -- .addhandlerrightclick -- %% \alias{.addhandlerrightclick-methods} \alias{.addhandlerrightclick,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerdestroy -- %% \alias{addhandlerdestroy-methods} \alias{addhandlerdestroy,guiWidget-method} \alias{addhandlerdestroy,gWidgettcltk-method} \alias{addhandlerdestroy,tcltkObject-method} %% %% -- .addhandlerdestroy -- %% \alias{.addhandlerdestroy-methods} \alias{.addhandlerdestroy,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerdestroy,gWindowtcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerexpose -- %% \alias{addhandlerexpose-methods} \alias{addhandlerexpose,guiWidget-method} \alias{addhandlerexpose,gWidgettcltk-method} \alias{addhandlerexpose,tcltkObject-method} %% %% -- .addhandlerexpose -- %% \alias{.addhandlerexpose-methods} \alias{.addhandlerexpose,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerexpose,gComponenttcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerexpose,gGraphicstcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerexpose,gNotebooktcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerunrealize -- %% \alias{addhandlerunrealize-methods} \alias{addhandlerunrealize,guiWidget-method} \alias{addhandlerunrealize,gWidgettcltk-method} \alias{addhandlerunrealize,tcltkObject-method} %% %% -- .addhandlerunrealize -- %% \alias{.addhandlerunrealize-methods} \alias{.addhandlerunrealize,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlerunrealize,gWindowtcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerblur -- %% \alias{addhandlerblur-methods} \alias{addhandlerblur,guiWidget-method} \alias{addhandlerblur,gWidgettcltk-method} \alias{addhandlerblur,tcltkObject-method} %% %% -- .addhandlerblur -- %% \alias{.addhandlerblur-methods} \alias{.addhandlerblur,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlerfocus -- %% \alias{addhandlerfocus-methods} \alias{addhandlerfocus,guiWidget-method} \alias{addhandlerfocus,gWidgettcltk-method} \alias{addhandlerfocus,tcltkObject-method} %% %% -- .addhandlerfocus -- %% \alias{.addhandlerfocus-methods} \alias{.addhandlerfocus,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandleridle -- %% \alias{addhandleridle-methods} \alias{addhandleridle,guiWidget-method} \alias{addhandleridle,gWidgettcltk-method} \alias{addhandleridle,tcltkObject-method} %% %% -- .addhandleridle -- %% \alias{.addhandleridle-methods} \alias{.addhandleridle,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- addpopupmenu -- %% \alias{addpopupmenu-methods} \alias{addpopupmenu,guiWidget-method} \alias{addpopupmenu,gWidgettcltk-method} \alias{addpopupmenu,tcltkObject-method} %% %% -- .addpopupmenu -- %% \alias{.addpopupmenu-methods} \alias{.addpopupmenu,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addpopupmenu,gButtontcltk,guiWidgetsToolkittcltk-method} \alias{.addpopupmenu,gLabeltcltk,guiWidgetsToolkittcltk-method} %% %% -- add3rdmousepopupmenu -- %% \alias{add3rdmousepopupmenu-methods} \alias{add3rdmousepopupmenu,guiWidget-method} \alias{add3rdmousepopupmenu,gWidgettcltk-method} \alias{add3rdmousepopupmenu,tcltkObject-method} %% %% -- .add3rdmousepopupmenu -- %% \alias{.add3rdmousepopupmenu-methods} \alias{.add3rdmousepopupmenu,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.add3rdmousepopupmenu,tcltkObject,guiWidgetsToolkittcltk-method} \alias{.add3rdmousepopupmenu,gLabeltcltk,guiWidgetsToolkittcltk-method} %% %% -- addhandlermousemotion -- %% \alias{addhandlermousemotion-methods} \alias{addhandlermousemotion,gWidgettcltk-method} \alias{addhandlermousemotion,tcltkObject-method} %% %% -- .add3rdmousepopupmenu -- %% \alias{.addhandlermousemotion-methods} \alias{.addhandlermousemotion,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.addhandlermousemotion,tcltkObject,guiWidgetsToolkittcltk-method} %% %% -- adddropsource -- %% \alias{adddropsource-methods} \alias{adddropsource,guiWidget-method} \alias{adddropsource,gWidgettcltk-method} \alias{adddropsource,tcltkObject-method} %% %% -- .adddropsource -- %% \alias{.adddropsource-methods} \alias{.adddropsource,tcltkObject,guiWidgetsToolkittcltk-method} \alias{.adddropsource,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- adddropmotion -- %% \alias{adddropmotion-methods} \alias{adddropmotion,guiWidget-method} \alias{adddropmotion,gWidgettcltk-method} \alias{adddropmotion,tcltkObject-method} %% %% -- .adddropmotion -- %% \alias{.adddropmotion-methods} \alias{.adddropmotion,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.adddropmotion,tcltkObject,guiWidgetsToolkittcltk-method} %% %% -- adddroptarget -- %% \alias{adddroptarget-methods} \alias{adddroptarget,guiWidget-method} \alias{adddroptarget,gWidgettcltk-method} \alias{adddroptarget,tcltkObject-method} \alias{adddroptarget,gImagetcltk,guiWidgetsToolkittcltk-method} %% %% -- .adddroptarget -- %% \alias{.adddroptarget-methods} \alias{.adddroptarget,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.adddroptarget,tcltkObject,guiWidgetsToolkittcltk-method} \alias{.adddroptarget,gLabeltcltk,guiWidgetsToolkittcltk-method} \alias{.adddroptarget,gImagetcltk,guiWidgetsToolkittcltk-method} %% %% -- .gmessage -- %% \alias{.gmessage-methods} \alias{.gmessage,guiWidgetsToolkittcltk-method} %% %% -- .ginput -- %% \alias{.ginput-methods} \alias{.ginput,guiWidgetsToolkittcltk-method} %% %% -- .gconfirm -- %% \alias{.gconfirm-methods} \alias{.gconfirm,guiWidgetsToolkittcltk-method} %% %% -- .gbasicdialog -- %% \alias{.gbasicdialog-methods} \alias{.gbasicdialog,guiWidgetsToolkittcltk-method} %% %% -- .gbasicdialognoparent -- %% \alias{.gbasicdialognoparent-methods} \alias{.gbasicdialognoparent,guiWidgetsToolkittcltk-method} %% %% -- update -- %% \alias{update-methods} \alias{update,ANY-method} \alias{update,guiWidget-method} \alias{update,gWidgettcltk-method} \alias{update,gWindowtcltk-method} \alias{update,gSubsetbytcltk-method} \alias{update,gTreetcltk-method} %% %% -- .update -- %% \alias{.update-methods} \alias{.update,gComponenttcltk,guiWidgetsToolkittcltk-method} \alias{.update,gTreetcltk,guiWidgetsToolkittcltk-method} \alias{.update,gVarbrowsertcltk,guiWidgetsToolkittcltk-method} \alias{.update,gWindowtcltk,guiWidgetsToolkittcltk-method} %% %% -- .length -- %% \alias{.length-methods} \alias{.length,ANY,ANY-method} \alias{.length,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.length,gComponentR5tcltk,guiWidgetsToolkittcltk-method} \alias{.length,gDroplisttcltk,guiWidgetsToolkittcltk-method} \alias{.length,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.length,gHelptcltk,guiWidgetsToolkittcltk-method} \alias{.length,gLayouttcltk,guiWidgetsToolkittcltk-method} \alias{.length,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.length,gRadiotcltk,guiWidgetsToolkittcltk-method} \alias{.length,gTabletcltk,guiWidgetsToolkittcltk-method} \alias{.length,gTableWithFiltertcltk,guiWidgetsToolkittcltk-method} \alias{.length,gCheckboxgrouptcltk,guiWidgetsToolkittcltk-method} %% %% -- dim -- %% \alias{dim-methods} \alias{dim,ANY-method} \alias{dim,guiWidget-method} \alias{dim,gWidgettcltk-method} %% %% -- .dim -- %% \alias{.dim-methods} \alias{.dim,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.dim,gLayouttcltk,guiWidgetsToolkittcltk-method} \alias{.dim,gTabletcltk,guiWidgetsToolkittcltk-method} \alias{.dim,gTableWithFiltertcltk,guiWidgetsToolkittcltk-method} \alias{.dim,gWidgettcltk,guiWidgetsToolkittcltk-method} %% %% -- .dimnames -- %% \alias{.dimnames-methods} \alias{.dimnames,gGridtcltk,guiWidgetsToolkittcltk-method} %% %% -- .dimnames<- -- %% \alias{.dimnames<--methods} \alias{.dimnames<-,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.dimnames<-,gDftcltk,guiWidgetsToolkittcltk-method} %% %% -- names -- %% \alias{names-methods} \alias{names,ANY-method} \alias{names,guiWidget-method} \alias{names,gWidgettcltk-method} %% %% -- .names -- %% \alias{.names-methods} \alias{.names,gExpandgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.names,gFrametcltk,guiWidgetsToolkittcltk-method} \alias{.names,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.names,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.names,gTabletcltk,guiWidgetsToolkittcltk-method} %% %% -- names<- -- %% \alias{names<--methods} \alias{names<-,ANY-method} \alias{names<-,guiWidget-method} \alias{names<-,gWidgettcltk-method} %% %% -- .names<- -- %% \alias{.names<--methods} \alias{.names<-,gExpandgrouptcltk,guiWidgetsToolkittcltk-method} \alias{.names<-,gFrametcltk,guiWidgetsToolkittcltk-method} \alias{.names<-,gGridtcltk,guiWidgetsToolkittcltk-method} \alias{.names<-,gNotebooktcltk,guiWidgetsToolkittcltk-method} \alias{.names<-,gTabletcltk,ANY-method} \alias{.names<-,gTableWithFiltertcltk,ANY-method} %% %% %% -- .getToolkitWidget -- \alias{.getToolkitWidget,gWidgettcltk,guiWidgetsToolkittcltk-method} \alias{.getToolkitWidget,gActiontcltk,guiWidgetsToolkittcltk-method} \alias{.getToolkitWidget,gWindowtcltk,guiWidgetsToolkittcltk-method} %% %% -- [ \alias{[,gComponentR5tcltk-method} %% %% -- [<- \alias{[<-,gWidgettcltk-method} \alias{[<-,gComponentR5tcltk-method} \alias{[<-,gCheckboxtcltk-method} \alias{[<-,gCheckboxgrouptcltk-method} \alias{[<-,gDroplisttcltk-method} \alias{[<-,gEdittcltk-method} \alias{[<-,GtkTreeView-method} \alias{[<-,gGridtcltk-method} \alias{[<-,gLayouttcltk-method} \alias{[<-,gMenutcltk-method} \alias{[<-,gNotebooktcltk-method} \alias{[<-,gRadiotcltk-method} \alias{[<-,gSlidertcltk-method} \alias{[<-,gSpinbuttontcltk-method} \alias{[<-,gTabletcltk-method} \alias{[<-,gTableWithFiltertcltk-method} \alias{[<-,gToolbartcltk-method} %% -- dimnames \alias{dimnames,gWidgettcltk-method} \alias{dimnames<-,gWidgettcltk-method} \alias{length,gWidgettcltk-method} \alias{length,gSubsetbytcltk-method} \alias{length,gDroplisttcltk-method} %% -- isExtant \alias{isExtant,gWidgettcltk-method} \alias{.isExtant,gWidgettcltk,guiWidgetsToolkittcltk-method} \title{Undocumented functions in gWidgetstcltk} \description{ The gWidgetstcltk package implements the gWidgets API. In gWidgets the primary constructors and methods are documented. The basic idea is that \code{function} in gWidgets calls \code{.function} in gWidgetstcltk. Hence the many functions here. } \keyword{interface}% at least one, from doc/KEYWORDS \keyword{internal}gWidgetstcltk/man/gWidgetstcltk-package.Rd0000644000176000001440000003433311607334401020400 0ustar ripleyusers\name{gWidgetstcltk-package} \alias{gWidgetstcltk-package} \alias{gWidgetstcltk} \docType{package} \title{ Toolkit implementation of gWidgets for tcltk } \description{ Port of gWidgets API to tcltk. The gWidgets API is an abstract, lightweight means to interact with GUI toolkits. In this case, the tcltk toolkit. } \details{ This file documents differences between \pkg{gWidgetstcltk} and the \pkg{gWidgets} API, which is documented both in the man pages for that package and in its vignette. The \pkg{gWidgetstcltk} package is not as complete as gWidgetsRGtk2. This is due to limitations in the base libraries implementing tcl/tk. This package was designed to work with the limited version that comes with the standard Windows installation of R. Notes on this implementation: The primary difference in this interface, as opposed to that for \pkg{RGtk2}, is that each widget requires a container when being constructed. The container is given to the \code{container} argument. The value may be the logical \code{TRUE} indicating that a new window is constructed, or a container widget. Other differences are that tcltk does not seem to have a markup language like Pango for GTK or HTML for JAVA, as such the \code{markup} argument for several widgets that is used to format text is not available. The \code{font<-} method can substitute. Until version 8.5 of tk, the basic tcltk installation did not include several widgets that appear in other toolkits. For instance a grid widget, a notebook widget, etc. This package now requires tk 8.5 to work and R 2.12-0 or newer. \cr \bold{Containers:} \cr \code{gwindow()}: The \code{width=} and \code{height=} arguments refer to the minimum window size, not the preferred default size. It is best to set \code{visible=FALSE} for the constructor and then when the GUI is layed out call \code{visible<-}. This will get the proper size for the window. Otherwse, the \code{update} method can be called to resize the window to accomodate the child widgets. The methods \code{addHandlerDestroy} and \code{addHandlerUnrealize} can only add one handler, new ones overwrite the old. These handlers can also not be removed. \cr \code{ggroup()} has the \code{expand=} \code{fill=} and \code{anchor=} arguments. If \code{expand=TRUE} the widget is allocated as much space as possible. (The default is \code{expand=FALSE}, unless the option \code{"gw:tcltkDefaultExpand"} overrides this.) When a widget has expand, then the widget may stretch to fill the expanding space (in tcltk, all widgets that have expand=TRUE are allocated evenly any additional space). The fill may be TRUE (or both), FALSE, or "x" and "y". The \code{anchor=} argument adjusts a widget left or right, up or down, within its space. Only one component works at a time for the anchor argument. In a horizontal box, only the y component can be used to move a value up or down. In a vertical box, only the x component can be used to move a value left or right. The default is c(-1,0) so that horizontal layouts are towards the middle, and vertical layouts towards the left. (This can be overridden: \code{options("gw:tcltkDefaultAnchor"=c(0,0))}, say.) The \code{use.scrollwindows} feature is now implemented. (but seems buggy) The \code{addSpring} method only works if the parent container is set to expand. \cr \code{gframe()} The \code{markup} argument is ignored. Use \code{font<-} to give the title markup. \cr \code{gexpandgroup()} Works as expected, although sizing issues may frustrate. \code{gdfnotebook()} Works with the addition of ttknotebook. The \code{add} method, which is used to add pages, is called when the notebook is given as a container during the construction of a widget. Hence, to add a page something like this is done: \preformatted{ nb <- gnotebook(cont=gwindow("Notebook example")) gbutton("Page 1", cont=nb, label = "tab1") glabel("Page 2", cont=nb, label = "tab2") gedit("Page 3", cont=nb, label = "tab3") } \code{glayout()} has two additional arguments: \code{expand=TRUE} is like \code{expand=} for \code{ggroup()}, in that the attached widget expands to fill the possible space in the container. If this isn't given the \code{anchor=} argument can be used to adjust the location of the widget withing the cell. A value of c(-1,1) is the lower left, c(-1,1) the upper left (the default), c(1,-1) the lower right, and c(1,1) the upper right. The value 0 for either is also possible. \cr \code{gpanedgroup()} The constructor is called with no widgets. To add a widget to the paned group the paned group is passed as a container, as in \preformatted{ pg <- gpanedgroup(container=gwindow("example"), horizontal = FALSE) b1 = gbutton("button 1", container=pg) b2 = gbutton("button 2", container=pg) } The paned window can be adjusted manually or using the \code{svalue} method. The \code{svalue} method uses the current window size. If the widget is not realized, the method will not work as expected, so call this after showing the GUI. The \code{delete} method can be used to delete a widget. It may be added back with the \code{add} method. \cr \bold{The basic widgets or components:} (These are also known as controls) \cr \code{gbutton()} mostly works. The button won't resize to take up all the possible space for a widget, even if \code{expand=TRUE} is given. \code{gcalendar()} is a hack. \cr \code{gcheckbox()} works as advertised, \code{use.togglebutton} implemented. \cr \code{gcheckboxgroup()} works as advertised, except the \code{use.table} argument is ignored. One can now resize the list. \cr \code{gcombobox()} Works as expected, although no icons or tooltips are available. \cr \code{gdf()} is implemented if the user has installed the \code{tktable} package in Tcl. This is an additional download from \url{tktable.sourceforge.net}. Most of the code comes second hand from \pkg{tcltk2}'s \code{dfedit} function. \cr \code{gedit()}: The widget does not resize automatically. Set the width with \code{width=} at time of construction or with \code{size<-}. There is now type ahead support, although the pop-down menu only pops down, so don't use near the bottom of a screen ;) The hidden argument \code{init_msg} can be used to place an initial message for the event there is no text in the box. \cr \code{gfilebrowse()} works. \cr \code{ggraphics()} Not implemented. The \pkg{tkrplot} package could be used in some way, but this does not provide a fully embeddable graphics device. The \pkg{tkrplot} package provides a means to create interactive graphics with \pkg{tcltk}. This is not a device, so ins't directly supported. However, a \code{ggroup} object can be used as a parent container. Just call \code{getToolkitWidget} on the object first: \cr \preformatted{ g <- ggroup(cont=gwindow()) l <- tkrplot(getToolkitWidget(g), function() hist(rnorm(100))) add(g, l) } \code{ghelp()} Works as advertised. Uses a popup menu instead of a notebook, as gWidgetsRGtk2. Best to just use \pkg{helpr} though. \cr \code{gimage()} Only works with gif and pnm files, as the underlying tcltk widget only uses these by default. \cr \code{glabel()} No markup available. Use \code{font<-} instead. \cr \code{gmenu()} adds only to the top window, not any container. This is a tcltk limitation. Use a popupmenu instead. Under Mac OS X, menus display in the top menu bar area, not in the parent window. \cr \code{gtoolbar()} A hack made from a \code{ggroup} object that packs in \code{gbutton} instances. The buttons take up alot of screen real estate, on the default Aqua them of OS X the buttons are rounded, so the toolbar looks odd, ... \cr \code{gaction()} is implemented for buttons, menubars and toolbars. The \code{key.accel} component is now implemented but one must pass in a parent argument (The binding is to the top-level window containing the parent). \cr \code{gradio()} has an extra argument \code{coerce.with=}, as otherwise it would treat everything as a character vector. It tries to guess when instantiated, if not explicitly given. One can now resize the number of items to select from. \cr \code{gseparator()} works as expected but must be in a container with \code{expand=TRUE}. \code{gslider()} now works with non-integer steps. If first argument \code{from} is a vector it will slide over those values after sorting. This uses a themed widget which might be buggy under some styles. \cr \code{gspinbutton()} Works as expected. The change handler responds to clicks of the arrows or to the return key in the text area. Unless one has a new Tk version, this is a non-themed widget and can look a bit odd.\cr \code{gstatusbar()} A hack. Just a \code{ggroup()} instance in disguise. By default it must have a gwindow instance for a parent container. If the hidden argument \code{not.toplevel=TRUE} is specified, a \code{ggroup} container may be used. \cr \code{gtable()} This is built on the underlying tree widget. It is not ideal, but avoids needing to have a separate library (eg. Tktable) installed. If the hidden argument \code{round} is passed to the constructor, this will be passed to the \code{format} function's \code{digits} argument when formatting numeric values for display. \cr Sizing is an issue. There may be a bug in the widget regarding horizontal scrolling (for Mac OS X anyways, where this is being developed), or more likely something is just coded wrong. There is some Tk code for "autoscrolling" that works (with an idiosyncrasy) so that the initial size of the widget is correct, but only when this size is set via arguments \code{width} and \code{height} passed to the constructor -- not with the \code{size<-} method. This feature is not on by default, as when it is used any widgets on the right of the table are not shown in the initial window, and are only exposed by resizing the window. If you want to try it, pass in the hidden argument \code{do.autoscroll=TRUE}. However, the \code{size<-} method has another use. It can also take a list for value. This list has optional components \code{width}, \code{height}, \code{columnWidths} (to specify each column width individually), and \code{noRowsVisible} (to specify height by number of rows, not pixels). \cr \code{gtext()} The \code{size<-} method can be used to resize the widget. The initial default size is quite large. This method guesses at the converstion from pixels to characters (width) and lines of text (height) used by the underlying widget. The \code{svalue()} method returns all the text unless some text is selected by the mouse and : \code{index=TRUE} in which case the indices of the selected text are returned or \code{drop=TRUE} in which case only the selected text is returned. \cr \code{gtree()} Implemented using ttktreeview. It is slow however, so use on smaller trees only. Has same issues with scrollbars as \code{gtable}. \cr \bold{Compound components:} \cr \code{gcommandline()} is implemented, but could definitely be improved. \cr \code{ghelpbrowser()} just calls \code{ghelp} \cr \code{ggenericwidget()} Some kinks need ironing out when the main variable is a formula. \cr \code{gdfnotebook()} Not implemented.\cr \code{ggraphicsnotebook()} No \code{ggraphics} so no notebook. \cr \code{gvarbrowser()} Uses a tree to show heirarchical structure of workspace. Does not poll to update workspace. It does reread workspace when Filter by: value is changed. \cr \bold{Dialogs:} (These are modal, hence they have no methods (basically).) \cr \code{gfile()} works as advertised. \cr \code{galert()} works.\cr \code{gmessage()} works. \cr \code{gconfirm()} works. \cr \code{ginput()} works. \cr \code{gbasicdialog()} is implemented. It it is a container. When the \code{visible(obj,TRUE)} command is issued, the container is shown and made modal. \preformatted{ dlg <- gbasicdialog("A modal dialog", handler=function(h,...) print("hi")) l = glabel("some widget in the dialog", cont=dlg) visible(dlg, set=TRUE) } \bold{Handlers:} \cr Handlers were rewritten so that one can have more than one handler per signal. The \code{blockHandler}, \code{unblockHandler} and \code{removeHandler} methods are now working. Handler code different for those widgets which use an R5 backend and those which don't, but the end user shouldn't notice. (Well, if you do let me know!)\cr The \code{addHandlerBlur} method should be called when a widget loses focuses, but here is called whenever a widget loses focus \emph{and} whenever the mouse leaves the widget. This can mean the handler is called twice. If you don'l like that, you can add the callback through \code{addHandler(obj, signal, handler)} where \code{signal} is \code{} or \code{}. \cr \code{adddroptarget()}, \code{adddropsource()}, and \code{adddropmotion} work for tcltk widgets. The cursor changes to a funny looking cursor, but nothing resembling a drag and drop cursor. One was chosen from the standard cursors. Dragging from other applications is not supported. } \author{ John Verzani. Several code segments were inspired by the examples of Wettenhall and the Dalgaard article referenced below. The drag and drop code was modified from code at \url{http://wiki.tcl.tk/416}. Icons were "borrowed" from several places: the scigraphica project, KDE, and elsewhere. Maintainer: John Verzani } \references{ Peter Dalgaard's RNews article on the tcltk pagkage \url{http://cran.r-project.org/doc/Rnews/Rnews_2001-3.pdf}; Several examples on \url{http://bioinf.wehi.edu.au/~wettenhall/RTclTkExamples/}; The PERL documentation was useful: \url{http://search.cpan.org/~ni-s/Tk-804.027/}, although this is for the most part a translation of the TK documentation. For a package somewhat similar in intent see Bowman, Crawford, Alexander, and Bowman's \pkg{rpanel} package: \url{http://www.jstatsoft.org/v17/i09/v17i09.pdf} or the \pkg{tkWidgets} package of Zhang \url{www.bioconductor.org}. The \pkg{fgui} package provides a similar functionality as \code{ggenericwidget} in a standalone package. } \keyword{ package } \examples{ \dontrun{ ## options(guiToolkit="tcltk") ## select CRAN miror example setMirror = function(URL) { repos = getOption("repos") repos["CRAN"] = gsub("/$", "", URL) options(repos = repos) } win = gwindow("Select a CRAN mirror") tbl = gtable(utils:::getCRANmirrors(), container=win, chosencol=4, handler = function(h,...) { URL = svalue(h$obj) setMirror(URL) dispose(win) }) ## } } gWidgetstcltk/DESCRIPTION0000644000176000001440000000130013652212707014626 0ustar ripleyusersPackage: gWidgetstcltk Version: 0.0-55.1 Title: Toolkit implementation of gWidgets for tcltk package Author: John Verzani Maintainer: ORPHANED Depends: R (>= 2.14.0), methods, gWidgets(>= 0.0.51), tcltk(>= 2.7.0), digest Suggests: Description: Port of the gWidgets API to the tcltk package. Requires Tk 8.5 or greater. License: GPL (>= 2) URL: http://gwidgets.r-forge.r-project.org/ LazyLoad: yes Packaged: 2020-04-29 05:48:22 UTC; ripley NeedsCompilation: no Repository: CRAN Date/Publication: 2020-04-29 05:51:03 UTC X-CRAN-Original-Maintainer: John Verzani X-CRAN-Comment: Orphaned on 2020-04-29 as requires orphaned package 'gWidgets' by the same non-maintainer. gWidgetstcltk/tests/0000755000176000001440000000000012275245141014266 5ustar ripleyusersgWidgetstcltk/tests/runRUnit.R0000644000176000001440000000160111764467566016220 0ustar ripleyusers## Run test suite through RUnit if installed ## ## RUnit is better at testing non-interactive features ## We add RUnit tests to the gWidgets/tests directory in files ## names test.XXX containing functions test-XXX <- function() {} library(gWidgets) options(guiToolkit="tcltk") doRequire <- function(i) do.call(sprintf("%s","require"), list(i)) if(doRequire("RUnit")) { testsuite.gWidgets <- defineTestSuite("gWidgets", dirs = system.file("tests",package="gWidgets"), testFileRegexp = "^test-.+\\.R", testFuncRegexp = "^test.+", rngKind = "Marsaglia-Multicarry", rngNormalKind = "Kinderman-Ramage") testResult <- runTestSuite(testsuite.gWidgets) printTextProtocol(testResult) } gWidgetstcltk/tests/RunTests.R0000644000176000001440000000056011764467556016223 0ustar ripleyusersrequire(gWidgets) require(tcltk) options("guiToolkit"="tcltk") if(as.numeric(.Tcl("info tclversion")) >= 8.5) { ## run tests only if we can files <- list.files(system.file("tests",package="gWidgets"), pattern = "\\.R$", full.names = TRUE) for(unitTest in files) { print(unitTest) source(unitTest) } } gWidgetstcltk/NEWS0000644000176000001440000001724412102501631013617 0ustar ripleyusersDear Emacs, please make this -*-Text-*- mode! NEWS for gWidgetstcltk Changes for 0.0-54 ------------------- * gfile has character value for filter argument to simplify specification * fix svalue<- method of gslider Changes for 0.0-53 ------------------- * add tag method for gaction. * fix dnd table to gedit. (prompted by stackoverflow answer). (Still a little off, as you need to select first, then drag) * replace gdf with tablelist, not tktable widget. Seems better and requires no external installation, as it is pure Tcl. Changes for 0.0-50 ------------------- Changes for 0.0-49 ------------------- * Bug fix for enabled<- method for gedit when initial text is "". (Thanks Yves) Changes for 0.0-48 ------------------- * fixed bug with user-defined icons (Thanks Erich) * fixed bug where inner frame in gwindow rendered separately (Thanks Erich, Rich and Patrick) Changes for 0.0-47 ------------------- * bug fix for svalue<- for gedit. (Thanks Pat) * bug fix of using wrong idiom to store data in a namespace (Thanks Erich) Changes for 0.0-46 ------------------- * minor bug fix to fix environment issue, get past check Changes for 0.0-45 ------------------- * Requires gWidgets 0.0-46 * Fixed reference class fields to accomodate changes to upcoming 2.14.0 * Added generics so that $, [[ and [[<- work with underlying toolkit object * added use.table option to gcheckboxgroup * focus<- for gwindow (for Erich) * added do.buttons options for gbasicdialog * improved [ method for glayout (Returns widget, list of widgets (if 1-d slice) or matrix of widgets. Changes for 0.0-44 ------------------- * new add method for adding tkrplot objects * bug fixes for gfile (Thanks Richie, Yves) * bug fixes for gcomobobox (Thanks Erich, Yves) * added stub for ghtml Changes for 0.0-43 ------------------- * change to selected= argument of gcomobobx. Will allow item value in addition to index. * Bug fixes, (Thanks Erich, Carlos) * new method editable<-. Used by gedit to allow selection but no changing of the text. Changes for 0.0-42 ------------------- * fix to add method of box containers and the expand, fill, anchor arguments Changes for 0.0-41 ------------------- * doc fixes Changes for 0.0-40 ------------------- * gcheckboxgroup now uses backend R5 class * gradio cannow use [<- to lengthen/shorten radio button count * gedit new [<- for auto complete * Added new R5 classes * change behavior of default anchoring of children into parent. This can be adjusted through the option "gw:tcltkDefaultAnchor". * added extra functionality for gslider. Need not be integer valued now. * bug fix for add method and fill argument * Added calendar selector to gcalendar * add [ method for gnotebook, kill [<- (wasn't working, isn't right) Changes for 0.0-39 ------------------- * added [ method to glayout for extraction * fix to handler code. Adds blockHandler, unblockHandler and fixes bugs. Just gradio and gcheckboxgroup have only 1 handler per widget, others can have multiple. Handler code is not as general as tcltk itself. Changes for 0.0-38 ------------------- * minor fixes for ggroup, gframe to get traitr to work * visible<- method for gedit fixed Changes for 0.0-37 ------------------- * Fixes to gfile (bug fix when spaces are in filename, keeps track in "initialdir". This may be passed in, or is remembered between invocations through an option. Changes for 0.0-36 ------------------- * added visible<- method for gedit. If FALSE will mask characters Changes for 0.0-35 ------------------- * fix to gradio's addHandlerChanged and svalue methods. Changes for 0.0-34 ------------------- * Bug fix to svalue method for gtable when index=TRUE CHanges for 0.0-33 ------------------- * fix to slant value in font to pass R CMD check CHanges for 0.0-32 ------------------- * font fixes for gtext, and font<- Changes for 0.0-31 ------------------- * added method isExtant * added hidden argument not.toplevel to gstatusbar to relax restriction on container being gwindow instance Changes for 0.0-30 ------------------- * bug fix for gtable Changes for 0.0-29 ------------------- * added [<- method for gspinbutton, gslider * minor fix for gfilebrowse and width argument Changes for 0.0-28 ------------------- * fixed enable<- to recurse, and for gradio, gcheckbox * Changes to stock icons in gtable, gimage, gbutton. * fix to add method for ggroup -- handlers anchor better with expand=TRUE * Numerous small bug fixes. Changes for 0.0-27 ------------------- * fixes to gdf() for Enter, Tab binding Changes for 0.0-26 ------------------- * added gdf() constructor if user has tktable package installed for tcl * fixes to gmessasge gconfirm to use tkmessagebox Changes for 0.0-25 ------------------- * fixed inheritance for gbasicdialog so that size<- method works as expected Changes for 0.0-24 ------------------- * fix to gmenu to get working with gbasicdialog Changes for 0.0-23 ------------------- * minor fix to DESCRIPTION Changes for 0.0-22 ------------------- * added gbasicdialog. Three step process: create ocntainer, add widget, call visible with set=TRUE. * fixes to gtable -- working on column width issues, but still not great * fixed several issues with how containers are used, some were not expanding properly: gnotebook, gexpandgroup * changed layout of gexpandgroup so that group is always below the label and trigger icon, instead of adjacent. Code was cleaned up. * changed how statusbars and toolbars are handled by gwindow. Also use ttkframe within gwindow to offer theme support to window. * added use.scrollwindow argument for ggroup. Not quite perfect, as the frame doesn't scroll to follow recently added children. * new(ish) constructor gformlayout coming from gWidgets * new(ish) gaction for menus, toolbars, buttons. This is now recommened means to implement menus and toolbars * new galert dialog. This is like gmessage only non obtrusive. Can be improved. * added autoscroll bar feature to gtree, gtable, gtext. Changes for 0.0-20 ------------------- * fixed handler code in gcheckbox, gcheckboxgrioup Changes for 0.0-19 ------------------- * fixed bug with gtable and multiple selection Changes for 0.0-18 ------------------- * fixed another issue with gtable: debugging info, extra columns, error if more than 2 columns Changes for 0.0-17 ------------------- * fixed issues with gtable (factors converted to character, widths) Changes for 0.0-16 ------------------- * fixed ggroup bug in svalue method Changes for 0.0-15 ------------------- * fix bug in gfile regarding initialfilename * fix to eliminate extra column in gtree if single column Changes for 0.0-14 ------------------- * fix to gtree Changes for 0.0-13 ------------------- * added test for version 8.5. Changes for 0.0-11 ------------------- * fixed typo in gframe * changes to pass R CMD check on R-devel (again!) Changes for 0.0-9 ------------------- * changes to pass R CMD check on R-devel Changes for 0.0-9 ------------------- * added tests directory to run tests from gWidgets package * fixed documentation to avoid warnings Changes for 0.0-8 ------------------- * new uses ttk (tile) libraries. (Hence R 2.7.0) * implemented parent argument for gwindow. This can be used to specify a gwindow parent or a location by x,y coordinates. * added parent argument for dialogs * replaced hacked versions of gcombobox, gnotebook, gexpandgroup, gframe, ... with ttk versions * added gtable widget based on ttktreeview replacing one based on itemlist * added gtree widget using ttktreeview * exported addHandler for binding events not covered by gWidgets API * fixed tag to use an environment not one big list. * fixed gfilebrowse error * fixed wrap argument for gtext gWidgetstcltk/R/0000755000176000001440000000000012362772220013325 5ustar ripleyusersgWidgetstcltk/R/gmenu.R0000644000176000001440000002320011554450767014573 0ustar ripleyuserssetClass("gMenutcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setClass("gMenuItemtcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## menulist is a list of lists with named components. Each named sub ## is a submenu. a leaf consistis of handler= (required), lab ## put menu in group, ## a menubar is a map from a list into a menubar ## constructor setMethod(".gmenu", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, menulist, popup = FALSE, action = NULL, container=NULL, ...) { force(toolkit) if(is(container,"logical") && container) container = gwindow() ## if(popup) tt <- getWidget(container) else tt = getTopParent(getWidget(container)) topMenu <- tkmenu(tt, tearoff=FALSE) mapListToMenuBar(menulist, topMenu) ## unlike RGtk2 use removeall to make changes obj = new("gMenutcltk", block=topMenu, widget=topMenu, toolkit=toolkit,ID=getNewID(), e = new.env()) tag(obj, "menulist") <- menulist if(!popup) add(container, obj,...) invisible(obj) }) ### methods setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gMenutcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { tag(obj, "menulist") }) ## three cases for value: list, gMenutcltk, guiWidget push down ## make a menubar, then replace current -- isn't working for popup case setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gMenutcltk", value="list"), function(obj, toolkit, index=NULL, ..., value) { menulist = value # value is a list if(!is.list(menulist)) stop("value is not a menubar or a list") mb = obj@widget removeAllItems(mb) mapListToMenuBar(menulist, mb) parentWidget = mb$getParent() parentWidget$validate() ## store for later? tag(obj,"menulist") <- menulist return(obj) }) ## get list, and then call previous setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gMenutcltk", value="gMenutcltk"), function(obj, toolkit, index=NULL, ..., value) { .svalue(obj,toolkit, index, ...) <- svalue(value) return(obj) }) ## call previous after getting list setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gMenutcltk", value="guiWidget"), function(obj, toolkit, index=NULL, ..., value) { .svalue(obj,toolkit,index, ...) <- svalue(value@widget) return(obj) }) ## this is for adding a menu to a menu setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gMenutcltk", value="guiWidget"), function(obj, toolkit, value, ...) { .add(obj, toolkit, value@widget) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gMenutcltk", value="gMenutcltk"), function(obj, toolkit, value, ...) { orig.list = svalue(obj) add.list = svalue(value) new.list = c(orig.list, add.list) svalue(obj) <- new.list }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gMenutcltk", value="list"), function(obj, toolkit, value, ...) { mb = getWidget(obj) mapListToMenuBar(value, mb) }) ## This is for adding a gmenu to a container. ## We want this to be a top-level window to be DOM familiar ## in RGtk2, this isn't imposed. setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gWindowtcltk", value="gMenutcltk"), function(obj, toolkit, value, ...) { tkconfigure(getBlock(obj), menu=getBlock(value)) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gContainertcltk", value="gMenutcltk"), function(obj, toolkit, value, ...) { cont <- getBlock(obj) toplevel <- tkwinfo("toplevel", cont) tkconfigure(toplevel, menu=getBlock(value)) ## tkconfigure(cont, menu=getBlock(value)) }) ## "wdget" is either a gMenu, list or just names to delete setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk", obj="gMenutcltk", widget="guiWidget"), function(obj, toolkit, widget, ...) { .delete(obj,toolkit,widget@widget,...) }) setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk", obj="gMenutcltk", widget="gWidgettcltk"), function(obj, toolkit, widget, ...) { .delete(obj,toolkit,widget@widget, ...) }) setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk", obj="gMenutcltk", widget="gMenutcltk"), function(obj, toolkit, widget, ...) { .delete(obj,toolkit,svalue(widget), ...) }) setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk", obj="gMenutcltk", widget="list"), function(obj, toolkit, widget, ...) { lst = widget # else assume its a character cur.list = svalue(obj) for(i in lst) { ## we delete *last* entry with this name, hence this awkwardness theNames = names(cur.list) if(i %in% theNames) { j = max(which(i == theNames)) if(!is.null(cur.list[[j]])) cur.list[[j]] <- NULL } } ## now update menubar svalue(obj) <- cur.list }) ## give vector notation setMethod("[", signature(x="gMenutcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gMenutcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { lst = svalue(x) if(missing(i)) return(lst) else return(lst[i]) }) setReplaceMethod("[", signature(x="gMenutcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gMenutcltk"), function(x, toolkit, i, j, ..., value) { lst = svalue(obj) theNames = names(lst) if(is.character(i)) i = max(which(i %in% theNames)) lst[[i]] <- value[[1]] theNames[i] = names(value) names(lst) = theNames svalue(obj) <- lst return(obj) }) ################################################## ## helper functions makeSubMenu = function(lst, label, parentMenu) { subMenu = tkmenu(parentMenu, tearoff = FALSE) tkadd(parentMenu,"cascade",label=label, menu = subMenu) lapply(names(lst),function(i) { tmp <- lst[[i]] label <- i if(.isgSeparator(tmp)) tmp <- list(separator=TRUE) if(.isgAction(tmp)) { tmp <- getToolkitWidget(tmp) label <- tmp$label } f <- function() { l <- force(tmp) h <- list() h$action = l$action l$handler(h) } ## is it a gaction? if(!is.list(tmp)) return() if(!is.null(tmp$handler)) { item <- tkadd(subMenu,"command",label=label,command = f) if(.isgAction(lst[[i]])) { if(is(lst[[i]],"gActiontcltk")) e <- lst[[i]]@e else e <- lst[[i]]@widget@e l <- e$menuitems l[[length(l) + 1]] <- subMenu e$menuitems <- l } } else if(!is.null(tmp$separator)) { tkadd(subMenu,"separator") } else { ## a submenu makeSubMenu(tmp, label, subMenu) } } ) } ## some helper functions for this .isLeaf = function(lst) { if(.isgAction(lst) || (is.list(lst) & (!is.null(lst$handler) | !is.null(lst$separator))) ) { return(TRUE) } else { return(FALSE) } } mapListToMenuBar = function(menulist, topMenu) { ## determine if a top-level menu # if(is.null(menulist[[1]]$handler)) { if(!.isLeaf(menulist[[1]])) { lapply(names(menulist), function(i) makeSubMenu(menulist[[i]],label=i,topMenu)) } else { ## toplevel lapply(names(menulist), function(i) { label <- if(!is.null(menulist$label)) menulist$label else i tkadd(topMenu,"command",label=label, command = function() { l = force(menulist[[i]]) if(.isgAction(l)) l <- getToolkitWidget(l) h = list() h$action = l$action l$handler(h) }) }) } } removeAllItems = function(topMenu) { tkdelete(topMenu,0,"end") } gWidgetstcltk/R/gseparator.R0000644000176000001440000000535011466317136015627 0ustar ripleyusers################################################## ## add a separator to a container. Needs the container ## inspired by ## http://search.cpan.org/src/WGDAVIS/Tk-Separator-0.50/Separator.pm setClass("gSeparatortcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## should this return object? setMethod(".gseparator", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, horizontal = TRUE, container = NULL, ...) { force(toolkit) ## if null, we return a stub. Useful for gmenu, gtoolbar if(is.null(container)) { gp <- ttkframe(.TkRoot) # empty obj <- new("gSeparatortcltk", block=gp, widget=gp, toolkit=toolkit, ID=getNewID(), e = new.env()) return(obj) } if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } theArgs = list(...) if(!is.null(theArgs$col)) col = theArgs$col else col = "black" tt <- getWidget(container) ## gp <- ttkframe(tt) if(horizontal) orient <- "horizontal" else orient <- "vertical" sep <- ttkseparator(tt, orient=orient) ## if(horizontal) ## tkpack(sep)#, expand=TRUE, fill="x") ## else ## tkpack(sep)#, expand=TRUE, fill="y") obj = new("gSeparatortcltk", block=sep, widget=sep, toolkit=toolkit, ID=getNewID(), e = new.env()) ## add gp to container. Fixe expand argument to be TRUE # theArgs$expand = TRUE theArgs$obj <- container theArgs$value <- obj do.call("add", theArgs) # add(container, obj, ...) invisible(obj) }) ## no size method setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gSeparatortcltk"), function(obj, toolkit, ..., value) { gwCat("No size<- method for separators") return(obj) }) ## setMethod(".add", ## signature(toolkit="guiWidgetsToolkittcltk", obj="gLayouttcltk", ## value="gSeparatortcltk"), ## function(obj, toolkit, value, ...) { ## }) .isgSeparator <- function(obj) { (is(obj,"guiComponent") && is(obj@widget,"gSeparatortcltk") ) || is(obj,"gSeparatortcltk") } gWidgetstcltk/R/gtoolbar.R0000644000176000001440000001633711646163632015300 0ustar ripleyusers## gtoolbar, similar to gmenu ## need to incorporate delete/add methods as in imenu setClass("gToolbartcltk", representation = representation("gComponenttcltk", style="character"), contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## turn a list into a uimgr object setMethod(".gtoolbar", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, toolbarlist, style = c("both","icons","text","both-horiz"), action=NULL, container=NULL, ...) { force(toolkit) if(is(container,"logical") && container) container <- gwindow("Toolbar") if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } style = match.arg(style) tkstyle <- c("both"="top", "icons"="image", "text"="text", "both-horiz"="left") ## container must be a gwindow toplevel <- getTopLevel(container) if(!(is(toplevel,"gWindowtcltk") || is(toplevel@widget,"gWindowtcltk"))) { message(gettext("gtoolbar: container must be gwindow instance\n")) } ## tt <- getBlock(container) tt <- tag(toplevel, "tb") gp <- ttkframe(tt) tb <- ttkframe(gp) tkpack(tb, side="left",anchor="w", expand=TRUE, fill="x") obj <- new("gToolbartcltk",block=gp, widget=tb, toolkit=toolkit, ID=getNewID(),e = new.env(), style=style) tag(obj,"toolbarlist") <- toolbarlist add(container, obj, ...) .mapListToToolBar(tb, toolbarlist, tkstyle[style]) invisible(obj) }) ## helpers .addToolbarButton <- function(tb, style, label=NULL, icon=NULL,handler=NULL, action=NULL) { ## get icon if(!is.null(icon)) { file <- findTkIcon(icon) icon <- tcl("image","create","photo",file=file) ## make a button with icon b <- ttkbutton(tb, image=icon, text=label, compound=style) } else { b <- ttkbutton(tb, text=label) } ## add in handler handler = force(handler) # need to force so scoping works in this call if(!is.null(handler)) { tkbind(b,"", function(...) { h = list(obj=b, action=action) handler(h,...) }) } ## slaves <- tclvalue(tcl("grid","slaves",tb)) ## slaves <- unlist(strsplit(slaves," ")) ## n <- length(slaves) ## tkgrid(b, row=0, column=n, sticky="ns") tkpack(b, side="left",anchor="w",expand=TRUE,fill="y") return(b) } .mapListToToolBar = function(tb, lst, style) { ## list is simple compared to menubar for(i in names(lst)) { tmp <- lst[[i]] label <- i if(.isgSeparator(tmp)) tmp <- list(separator=TRUE) ## is it a gaction? if(.isgAction(tmp)) { tmp <- getToolkitWidget(tmp) label <- tmp$label } if(!is.null(tmp$separator)) { ## add separator gseparator(horizontal=FALSE, container=tb) } else if(!is.null(tmp$handler)) { ## how to decide there are no text parts? b <- .addToolbarButton(tb, style, label, tmp$icon, tmp$handler, tmp$action) if(.isgAction(lst[[i]])) { if(is(lst[[i]],"gActiontcltk")) e <- lst[[i]]@e else e <- lst[[i]]@widget@e l <- e$toolbaritems l[[length(l) + 1]] <- b e$toolbaritems <- l } } } } ### methods setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gToolbartcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { tag(obj, "toolbarlist") }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gToolbartcltk"), function(obj, toolkit, index=NULL, ..., value) { if(!is.list(value)) stop("A toolbar requires a list to define it.") toolbar = obj@widget ## delete from toolbar n = length(tag(obj,"toolbarlist")) ## how to delete from group gwCat(gettext("No method to delete toolbar components\n")) .mapListToToolBar(toolbar, value, obj@style) tag(obj,"toolbarlist") <- value ## all done return(obj) }) ## returns list, or part of list setMethod("[", signature(x="gToolbartcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gToolbartcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { lst = tag(x,"toolbarlist") if(missing(i)) return(lst) else return(lst[[i]]) }) setReplaceMethod("[", signature(x="gToolbartcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gToolbartcltk"), function(x, toolkit, i, j, ..., value) { if(!is.list(value)) stop("assignment must be a list defining a (part) of a toolbar.") lst = tag(x,"toolbarlist") if(missing(i)) lst = value else lst[[i]] = value svalue(x) <- lst return(x) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gToolbartcltk", value="list"), function(obj, toolkit, value, ...) { svalue(obj) <- c(svalue(obj), value) }) ## (from gmenu) setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk",obj="gToolbartcltk"), function(obj, toolkit, widget, ...) { ## widget can be gToolBar or a list if(is.character(widget)) { lst = widget # else assume its a character } else if(is(widget,"gComponenttcltk")) { lst = svalue(widget) lst = names(lst) } else if(is.list(widget)) { lst = names(widget) } else { warning("Must be either a vector of names, a list, or a gToolbar instance") return() } cur.list = svalue(obj) for(i in lst) { ## we delete *last* entry with this name, hence this awkwardness theNames = names(cur.list) if(i %in% theNames) { j = max(which(i == theNames)) if(!is.null(cur.list[[j]])) cur.list[[j]] <- NULL } } ## now update toolbar svalue(obj) <- cur.list }) ### no method to set style, use tag(obj,"style")<-"theStyle" instead gWidgetstcltk/R/gtree.R0000644000176000001440000004231512275235054014565 0ustar ripleyuserssetClass("gTreetcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## map a list to a tree setMethod(".gtree", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, offspring = NULL, hasOffspring = NULL, # for defining offspring. FUN # of children only. offspring.data = NULL, col.types = NULL, # data frame with logical icon.FUN = NULL, # return stock name --called # on offspring, returns a # vector of length nrow chosencol = 1, multiple = FALSE, handler = NULL, action=NULL, container=NULL, ... ) { force(toolkit) theArgs <- list(...) if(is.null(offspring)) { message(gettext("Need to have specified an offspring function\n")) return(NA) } ## allow multiple if asked if(as.logical(multiple)) selectmode <- "extended" else selectmode <- "browse" ## get base offspring os <- offspring(c(), offspring.data) if(!inherits(os,"data.frame")) os <- as.data.frame(os) ## icons icons <- rep("", nrow(os)) if(!is.null(icon.FUN)) icons <- icon.FUN(os) ## fix icons - allow for stock or file or "" or null or NA ## are icons "", NA, filename or stockname? icons <- sapply(icons,function(i) { findTkIcon(i) }) ## need os, hasChild, icons, size: d, n, m l <- .treeGetOffspring(os, hasOffspring) os <- l$children whichHaveOffspring <- l$offspring d <- dim(os); m <- d[1]; n <- d[2] ## make tree view and ## pack into scrolled window if(is.logical(container) && container) container <- gwindow(visible=TRUE) tt <- getWidget(container) gp <- ttkframe(tt, width=20*n) # default width xscr <- ttkscrollbar(gp, orient="horizontal", command=function(...)tkxview(tr,...)) yscr <- ttkscrollbar(gp, command=function(...)tkyview(tr,...)) if(n >= 2) tr <- ttktreeview(gp, columns = 2:n, ## this works, but the above is ##cleaner. It gives one extra column ##when n = 1 ## columns = as.tclObj(columns, drop=FALSE), ## but the following fails -- extra columns ## columns = columns, displaycolumns="#all", selectmode=selectmode, xscrollcommand=function(...)tkset(xscr,...), yscrollcommand=function(...)tkset(yscr,...)) else # no columns argument tr <- ttktreeview(gp, displaycolumns="#all", selectmode=selectmode, xscrollcommand=function(...)tkset(xscr,...), yscrollcommand=function(...)tkset(yscr,...)) tkgrid(tr,row=0,column=0, sticky="news") tkgrid(yscr,row=0,column=1, sticky="ns") tkgrid(xscr, row=1, column=0, sticky="ew") ## see tkFAQ 10.1 -- makes for automatic resizing tkgrid.columnconfigure(gp, 0, weight=1) tkgrid.rowconfigure(gp, 0, weight=1) tkpack(gp, expand=TRUE, fill="both") ## call in autoscroll if requested -- has issues with sizing if(getWithDefault(theArgs$do.autoscroll, TRUE) && windowingsystem() != "aqua") { tcl("autoscroll::autoscroll", xscr) tcl("autoscroll::autoscroll", yscr) } ## turn on alternating shading if more than 1 column ## XXX obj <- new("gTreetcltk", block=gp, widget=tr, ID=getNewID(), e = new.env(), toolkit=toolkit) tag(obj,"offspring") <- offspring tag(obj,"offspring.data") <- offspring.data tag(obj,"icon.FUN") <- icon.FUN ## warn if chosencol not = 1 if(chosencol != 1) { gwCat(gettext("In gWidgetstcltk, chosencol is always the first column\n")) } tag(obj,"chosencol") <- chosencol tag(obj,"multiple") <- multiple ## put in children, .treeAddOffspring(tr, parent="", os, whichHaveOffspring, icons) ## now add a handler to row-exapnd ## Tree view open handler. No need to delete on close, as we ## delete children on open. tkbind(tr, "<>",function(W, x,y) { sel <- unlist(strsplit(tclvalue(tcl(W,"selection"))," "))[1] ## check if children, if not return children <- unlist(strsplit(tclvalue(tcl(W,"children",sel))," ")) if(length(children) == 0) return() lapply(children, function(i) tcl(W,"delete",i)) ## add in children path <- .treeGetPath(W) os <- offspring(path, tag(obj, "offspring.data")) ## icons icons <- rep("", nrow(os)) if(!is.null(icon.FUN)) icons <- icon.FUN(os) ## fix icons - allow for stock or file or "" or null or NA ## are icons "", NA, filename or stockname? icons <- sapply(icons,function(i) { findTkIcon(i) }) l <- .treeGetOffspring(os, hasOffspring) os <- l$children whichHaveOffspring <- l$offspring .treeAddOffspring(W, parent=sel, os, whichHaveOffspring, icons=icons) }) if(!is.null(handler)) { id <- addhandlerdoubleclick(obj,handler,action) tag(obj, "handler.id") <- id } ## attach to container if (!is.null(container)) { if(is.logical(container) && container == TRUE) container = gwindow(visible=TRUE) add(container, obj,...) } return(obj) }) ## Some helper functions .treeAddOffspring <- function(tr, parent="",os, hasChild, icons) { d <- dim(os); m <- d[1]; n <- d[2] if(m == 0) return() ## coerce to a character matrix, but worry about single row data frames os <- as.data.frame(lapply(os,as.character),stringsAsFactors=FALSE) os <- as.matrix(os) nms <- colnames(os) # os is a matrix now! ## widths and column headings if(parent == "" && n > 1) { ## column headings tcl(tr,"heading","#0", text="") lapply(2:n, function(j) { width <- max(nchar(c(nms[j],os[,j,drop=TRUE]))) * 8 + 15 tcl(tr,"column",j, "-width",width) # was -2?? tcl(tr,"heading",j,text=nms[j]) }) } else if(parent == "" && n == 1) { tcl(tr,"heading","#0", text=nms[1]) tcl(tr,"column","#0", "-width", max(nchar(c(nms[1],os[,1,drop=TRUE]))) * 8 + 15) # tcl(tr,"column",0,"-width",0) } lapply(1:m, function(i) { if(n > 1) { values <- os[i,2:n,drop=TRUE] } else { values<- NA } icon <- tcl("image","create","photo",file=icons[i]) ## need to use 16 by 16 icons if(length(values) > 1 || !is.na(values)) { tpath <- tcl(tr,"insert",parent,"end",text=os[i,1],image=icon, values = values) } else { # no values tpath <- tcl(tr,"insert",parent,"end",text=os[i,1],image=icon) } ## add offspring if(!is.na(hasChild[i]) && as.logical(hasChild[i])) { tcl(tr,"insert",tclvalue(tpath),"end", text="") } }) } ## for svalue .treeGetPath <- function(tr) { ## return path from selection sel <- unlist(strsplit(tclvalue(tcl(tr,"selection"))," ")) if(is.null(sel)) return(c()) path <- tclvalue(tcl(tr,"item",sel,"-text")) parent <- tclvalue(tcl(tr,"parent",sel)) while(parent != "") { path <- c(tclvalue(tcl(tr,"item",parent,"-text")),path) parent <- tclvalue(tcl(tr,"parent",parent)) } return(path) } .treeGetSelectedValue <- function(tr) { ## return path from selection sel <- unlist(strsplit(tclvalue(tcl(tr,"selection"))," ")) if(length(sel) == 0) return(NA) sapply(sel, function(i) tclvalue(tcl(tr,"item",i,"-text"))) } ## Take the data frame and massage it to return ## icons if asked, and figure out offspring .treeGetOffspring <- function(children, hasOffspring) { ## do we expand? ## how to determine if offspring are needed? ## default to hasOffspring, then second column, then default to FALSE if(!is.null(hasOffspring)) { offspring <- hasOffspring(children) } else { ## if second column is logical, we use that if(dim(children)[2] > 2 && is.logical(children[,2])) { offspring <- children[,2] children <- children[,-2, drop=FALSE] } else { offspring <- rep(FALSE, nrow(children)) } } return(list(children=children, offspring=offspring)) } ## number of columns .treeNoColumns <- function(tr) { colnames <- tclvalue(tcl(tr,"cget","-columns")) colnames <- unlist(strsplit(colnames," ")) length(colnames) + 1 # 1 for key } ## width of columns .treeColWidths <- function(tr) { n <- .treeNoColumns(tr) widths <- sapply(2:n , function(j) { tclvalue(tcl(tr, "column", j - 2, "-width")) }) widths <- c(tclvalue(tcl(tr, "column", "#0", "-width")), widths) return(as.numeric(widths)) } ## help out with gtree .treeByReturnVector = function(df, FUN,...) { tmp = by(df, factor(1:nrow(df)), FUN) sapply(tmp, function(x) x) } ## has different arguments, but we mask this with ... ## this has offspringdata as first argument setMethod(".update", signature(toolkit="guiWidgetsToolkittcltk",object="gTreetcltk"), function(object,toolkit,...) { obj <- object # rename, object from update generic tr <- getWidget(obj) theArgs <- list(...) offspring <- tag(obj,"offspring") hasOffspring <- tag(obj,"hasOffspring") icon.FUN <- tag(obj,"icon.FUN") offspring.data <- theArgs$offspring.data if(is.null(offspring.data)) { if(length(theArgs) > 1) offspring.data <- theArgs[[1]] else offspring.data <- NULL } ## what should now be in this part of the tree os <- offspring(c(), offspring.data) ## icons icons <- rep("", nrow(os)) if(!is.null(icon.FUN)) icons <- icon.FUN(os) ## fix icons - allow for stock or file or "" or null or NA ## are icons "", NA, filename or stockname? icons <- sapply(icons,function(i) { findTkIcon(i) }) l <- .treeGetOffspring(os, hasOffspring) os <- l$children whichHaveOffspring <- l$offspring d <- dim(os); m <- d[1]; n <- d[2] ## delete what is there children <- unlist(strsplit(tclvalue(tcl(tr,"children",""))," ")) if(length(children) > 0) lapply(children, function(i) tcl(tr,"delete",i)) ## add children .treeAddOffspring(tr, parent="", os, whichHaveOffspring, icons=icons) invisible() }) ## index returns the indices setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gTreetcltk"), function(obj, toolkit, index=NULL, drop=NULL,...) { tr <- getWidget(obj) index <- getWithDefault(index, FALSE) if(index) { sel <- unlist(strsplit(tclvalue(tcl(tr,"selection"))," ")) if(length(sel) == 0) return(NULL) vals <- lapply(sel, function(i) { ind <- numeric(0) parent <- i while(parent != "") { ind <- c(as.numeric(tcl(tr, "index", parent)) + 1, ind) parent <- tclvalue(tcl(tr, "parent", parent)) } ind }) if(length(vals) == 1) vals <- vals[[1]] return(vals) } else { ## give key whichCol <- tag(obj,"chosencol") if(whichCol != 1) gwCat(gettext(" svalue only returns first column with gWidgetstcltk\n")) ## possible multiple selection ## return path from selection sel <- unlist(strsplit(tclvalue(tcl(tr,"selection"))," ")) if(length(sel) == 0) return(NULL) vals <- sapply(sel, function(i) tclvalue(tcl(tr,"item",i,"-text"))) ## strip off names attr(vals,"names") <- rep(NULL,length(vals)) return(vals) } }) ##' set selection by index ##' ##' @param value a numeric path, or list of numeric paths specifying the selection setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gTreetcltk"), function(obj, toolkit, index=NULL, ..., value) { index <- getWithDefault(index, TRUE) if(!index) { gwCat(gettext("Need to have index=TRUE (or NULL)")) return(obj) } if(is.atomic(value)) value <- list(value) ## 0-based value <- lapply(value, function(i) i) tr <- getWidget(obj) selected <- as.character(tcl(tr, "selection")) lapply(selected, function(sel) tcl(tr, "selection", "toggle", sel)) lapply(value, function(path) { parent <- "" for(i in path) { parent <- as.character(tcl(tr, "children", parent))[i] tcl(tr, "see", parent) } tcl(tr, "selection", "add", parent) }) return(obj) }) ### need to figure this out ## return the path in values setMethod("[", signature(x="gTreetcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, guiToolkit("tcltk"), i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gTreetcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { tr <- getWidget(x) ## return path from selection sel <- unlist(strsplit(tclvalue(tcl(tr,"selection"))," ")) if(is.null(sel)) return(c()) path <- tclvalue(tcl(tr,"item",sel,"-text")) parent <- tclvalue(tcl(tr,"parent",sel)) while(parent != "") { path <- c(tclvalue(tcl(tr,"item",parent,"-text")),path) parent <- tclvalue(tcl(tr,"parent",parent)) } if(missing(i)) return(path) else return(path[i]) }) ### methods ## row-activated in gtable gives double click setMethod(".addhandlerdoubleclick", signature(toolkit="guiWidgetsToolkittcltk",obj="gTreetcltk"), function(obj, toolkit, handler, action=NULL, ...) { addhandler(obj, "",handler,action) }) setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gTreetcltk"), function(obj, toolkit, ..., value) { tr <- getWidget(obj) n <- .treeNoColumns(tr) widths <- .treeColWidths(tr) curWidth <- sum(widths) widths <- floor((1+widths) * value[1]/curWidth) ## set width sapply(2:n, function(j) { tcl(tr, "column", j - 2, width=widths[j], stretch=TRUE, anchor="w") }) tcl(tr,"column","#0","-width", widths[1]) ## set height height <- value[2] tcl(tr,"configure", height = floor(height/16)) return(obj) }) gWidgetstcltk/R/glabel.R0000644000176000001440000001015111406426756014704 0ustar ripleyuserssetClass("gLabeltcltk", contains="gComponenttcltk", representation = representation("gComponenttcltk", markup="logical"), prototype=prototype(new("gComponenttcltk")) ) ## constructor setMethod(".glabel", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text= "", markup = FALSE, editable = FALSE, handler = NULL, action = NULL, container = NULL, ... ) { force(toolkit) if(markup) { gwCat(gettext("In gWidgetstcltk there is no markup language. Use font()<- instead.\n")) } if(is(container,"logical") && container) container = gwindow() if(!(is(container,"guiWidget") || is(container,"gWidgettcltk"))) { warning("Container is not correct. No NULL containers possible\n" ) return() } tt <- getWidget(container) label <- ttklabel(tt, text="") obj <- new("gLabeltcltk", block=label, widget=label, markup=markup, toolkit=toolkit,ID=getNewID(), e = new.env()) ## add text svalue(obj) <- text ## add to container add(container, obj, ...) if(editable) { handler <- function(h,...) { val = ginput(message="Change label value:",text=svalue(h$obj), title="Change text for label", icon="question") if(!is.na(val)) svalue(obj) <- val } } if(!is.null(handler)) { id <- addhandlerclicked(obj, handler=handler,action=action) } invisible(obj) }) ### methods setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gLabeltcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { val = tclvalue(tkcget(getWidget(obj),"-text")) # respects "\n" if(length(val) == 0) val="" return(val) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gLabeltcltk"), function(obj, toolkit, index=NULL, ..., value) { txt <- paste(as.character(value), collapse="\n") tkconfigure(obj@widget, text=txt) return(obj) }) setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gLabeltcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerclicked(obj, toolkit, handler, action, ...) }) ################################################## ## internal function -- used by gvariables in gcommandline setGeneric("gaddlabel", function(obj, text="", markup=FALSE, pos=1, container=NULL, ...) standardGeneric("gaddlabel")) setMethod("gaddlabel", signature("guiWidget"), function(obj, text="", markup=FALSE, pos=1, container=NULL, ...) gaddlabel(obj@widget, text, markup, pos, container, ...) ) setMethod("gaddlabel", signature("gWidgettcltk"), function(obj, text="", markup=FALSE, pos=1, container=NULL, ...) { ## wrap widget into a new package with label if(pos %in% c(2,4)) { group = ggroup(horizontal=TRUE,container=container, toolkit=obj@toolkit) } else { group = ggroup(horizontal=FALSE,container=container, toolkit=obj@toolkit) } if(pos %in% 2:3) { glabel(text, markup=markup, container=group, toolkit=obj@toolkit) add(group, obj,expand=TRUE) } else { add(group, obj,expand=TRUE) glabel(text, markup=markup, container=group, toolkit=obj@toolkit) } ## group is returned. No methods added here, just a new package return(group) }) gWidgetstcltk/R/aaaR5classes.R0000644000176000001440000012715412350163650015767 0ustar ripleyusers## A widget framework for tcltk. Mostly just for fun, but useful for 3 widgets so far. ## This provides some R reference classes for working with tcltk widgets. A few new ones are used within gWidgetstcltk ## Namely: gradio and gcheckboxgroup, as we can now extend and lengthen the number of options ## and gedit for the autocompletion code ################################################## ## Class structures setRefClass("TcltkWidget", fields=list( widget="ANY", # main widget value = "ANY", # main value of widget ## handler stuff handlers = "list", # list of handlers handler_args = "character", # list of substitution values handler_id = "numeric", # count of ids block_all_handlers= "logical", # flag to block all handlers blocked_handlers = "character" # all blocked handlers ), methods=list( init_widget = function(parent, ...) { "Initialize widget" NULL }, initialize=function(parent, ...) { "Set up widget any other necessary values. Should be subclassed." handlers <<- list() handler_args <<- character() handler_id <<- 0 block_all_handlers <<- FALSE ## now initialize widget init_widget(parent, ...) .self }, get_widget=function() { "Return widget" widget }, set_widget=function(widget) { "Set widget" widget <<- widget }, ################################################## ## handler methods new_handler_id = function(signal) { "Create a new handler id. An id is a list with a unique id and the signal" handler_id <<- handler_id + 1 list(signal=signal, id=as.character(handler_id)) }, ## ## run_handlers = function(h) { ##' run handlers ##' @param h list passing in signal, user.data percent subs. values ##' @note much hackery to environment of handler to get percent substitutions passed in ##' also pass in reference to \code{.self} and \code{user.data} "Run handlers for a given signal" if(block_all_handlers || !is_enabled()) return() lapply(handlers[[h$signal]], function(i) { if(!i$id %in% blocked_handlers) { FUN <- i$handler e <- environment(FUN) for(j in names(formals(FUN))) e[[j]] <- h[[j]] if(!exists(".self", e)) e[[".self"]] <- .self e[["user.data"]] <- i$user.data environment(FUN) <- e formals(FUN) <- alist() FUN() } }) }, ## ## bind_handler = function(signal) { ##' @param signal signal o find handlers for ##' @param return id ##' @note hackery to get substitution variables passed along "Bind run_handlers for give signal." if(signal == "command") tkconfigure(widget, command=make_f(signal)) else tkbind(widget, signal, make_f(signal)) }, ## ## make_f = function(signal) { ##' Make a function for the handler. Involves hackery to get signature correct f <- function() { h <- list() for(i in handler_args) h[[i]] <- if(exists(i)) get(i) else NULL h[['signal']] <- signal run_handlers(h) } if(length(handler_args)) { ## do an eval/parse hack. Not sure how else to work with alist. txt <- paste("alist","(", paste(c(handler_args), "=", sep="", collapse=","), ")", sep="") formals(f) <- eval(parse(text=txt)) } f }, add_handler = function(signal, handler, user.data=NULL) { ##' add a handler for a given signal ##' @param signal signal for tkbind ##' @param handler function. Percent substitution values used. Also user.data passed in ##' if given as an argument ##' @param user.data will be passed into handler if it includes \code{user.data} argument ##' @note much hackery to get percent substitutions passed to handlers. Handler has ##' \code{.self} reference and \code{user.data} if argument present ##' @return returns an id "Add a handler to the list" l <- handlers if(is.null(l[[signal]])) l[[signal]] <- list() id <- new_handler_id(signal) l[[signal]][[id$id]] <- list(handler=handler, user.data=user.data, id=id$id) handlers <<- l handler_args <<- unique(c(handler_args, setdiff(names(formals(handler)), "user.data"))) bind_handler(signal) id }, ## ## remove_handler = function(id) { ##' remove a handler by id ##' @param id an id returned by add_handler method "Remove a handler by its id" l <- handlers[[id$signal]] l[[id$id]] <- NULL handlers[[id$signal]] <<- l if(length(l) == 0) tkbind(widget, id$signal, "") }, ## ## block_handler = function(id) { ##' block a handler by id (or all handlers) ##' @param id an id to identify which handler to block. If missing all handlers will be blocked "block a handler by its id or all handlers" if(missing(id)) block_all_handlers <<- TRUE else blocked_handlers <<- unique(c(blocked_handlers, id$id)) }, ## ## unblock_handler = function(id) { ##' unblock an handler by id (or all handlers) ##' @param id an id to identify which handler to unblock. If missing all handlers are unblocked "Unblock handler by id, or all handlers" if(missing(id)) { block_all_handlers <<- FALSE blocked_handlers <<- character(0) } else { blocked_handlers <<- setdiff(blocked_handlers, id$id) } }, ################################################## ## API for widgets. These are state properties get_value = function() { ##' Return primary value of widget. Possibly coerced in subclasses ##' @return value "Return value of widget" value }, set_value = function(value, index=TRUE) { ##' set the main value for the widget ##' @param value value to be set ##' @note subclass should update the widget, this just updates value field "Set value for widget. Updates value field. Subclass should update widget's value" value <<- value }, is_enabled = function() { ##' Is the widget enabled (or disabled) "Is widget enabled (as opposed to disabled)" as.logical(tcl(widget, "instate", "!disabled")) }, set_enabled = function(value) { ##' set the enabled status of widget ##' @param value if TRUE enable widget, if FALSE disable (not sensitive to user input) "Set enabled or disabled as per value (logical)" tcl(widget, "state", ifelse(value, "!disabled", "disabled")) invisible() }, is_focus = function() { ##' does the widget have the focus ##' @return logical "Does widget have focus?" as.logical(tcl(widget, "instate", "focus")) }, set_focus = function(value=TRUE) { ##' set focus ##' @param value if TRUE set focus on widget if(value) tcl(widget, "state", "focus") invisible() }, is_readonly = function() { ##' is widget readonly? "Is widget read only?" as.logical(tcl(widget, "instate", "readonly")) }, set_readonly = function(value=TRUE) { ##' set widget as readonly (not editable) ##' @note readonly mya vary for some widgets "Set widget as readonly. That is not editable." if(value) tcl(widget, "state", "readonly") invisible() } ) ) setRefClass("Button", contains=c("TcltkWidget"), methods= list( ## subclass overrides init_widget = function(parent, text="", ...) { widget <<- ttkbutton(parent, ...) set_value(text) }, set_value = function(value) { tkconfigure(widget, text=value) callSuper(value) }, ## new API set_image = function(image, compound="left") { if(!tclObj_exists(image)) { ## a stock icon image <- "XXX get icon name from stock icons" } tkconfigure(widget, "image"=image, compound=compound) } ) ) setRefClass("TcltkWidgetWithTclvariable", contains=c("TcltkWidget"), fields=list( v = "tclVar", coerce_with="function" ), methods=list( initialize=function(...) { coerce_with <<- as.character callSuper(...) }, set_coerce_with = function(f) { "Set function to coerce value with function(value) {...}" if(is.character(f)) f <- get(f, inherits=TRUE) coerce_with <<- f }, get_value=function() { coerce_with(tclvalue(v)) }, set_value=function(value) { "Set value" a <- v # avoid local assignment warning tclvalue(a) <- value } ) ) ## simple label setRefClass("Label", contains=c("TcltkWidgetWithTclvariable"), methods=list( init_widget = function(parent, text="") { ##' @param parent parent widget ##' @param text text for label or tclVariable if(is.character(text)) v <<- tclVar(text) else v <<- text widget <<- ttklabel(parent, textvariable=v) }, set_value = function(value) { .value <- paste(value, collapse="\n") callSuper(.value) } ) ) ## A check button setRefClass("CheckButton", contains=c("TcltkWidgetWithTclvariable"), methods=list( init_widget=function(parent, text, checked=FALSE, image, compound="none") { v <<- tclVar(as.numeric(checked)) widget <<- ttkcheckbutton(parent, variable=v) set_label(text) if(!missing(image)) set_image(image, compound) set_coerce_with(function(x) as.logical(as.numeric(x))) }, set_label=function(value) { tkconfigure(widget, text=value) }, set_image=function(image, compound) { # if(tclObj_exists(image)) tkconfigure(widget, image=image, compound=compound) } ##, ## make_f = function(signal) { ## ##' Make a function for the handler. Involves hackery to get signature correct ## f <- function() { ## h <- list() ## for(i in handler_args) h[[i]] <- get(i) ## h[['signal']] <- signal ## ##tcl("after", 150, function(...) { ## run_handlers(h) ## ##}) ## } ## if(length(handler_args)) { ## ## do an eval/parse hack. Not sure how else to work with alist. ## txt <- paste("alist","(", ## paste(c(handler_args), "=", sep="", collapse=","), ## ")", sep="") ## formals(f) <- eval(parse(text=txt)) ## } ## f ## } ), ) ## entry with type ahead ##' configuration property. (tkconfigure(widget, foreground="gray")?? setRefClass("Entry", contains=c("TcltkWidgetWithTclvariable"), fields=list( m="tkwin", l="tkwin", lindex = "numeric", # index of selection widget no.wds = "numeric", # track number of possible wds to choose from words = "character", max.words = "numeric", # maximum words in a display init_msg = "character" # an initial message ), methods=list( init_widget = function(parent, text="", coerce.with, max.words=20, words) { ##' @param parent parent widget ##' @param text text for label or tclVariable if(is.character(text)) v <<- tclVar(text) else v <<- text widget <<- ttkentry(parent, textvariable=v) if(!missing(coerce.with)) set_coerce_with(coerce.with) ## popup stuff tclServiceMode(FALSE) m <<- tktoplevel() tkwm.transient(m, parent) tkwm.overrideredirect(m, TRUE) tkwm.withdraw(m) tclServiceMode(TRUE) l <<- tktext(m); tkpack(l) lindex <<- 0 # index of selected max.words <<- max.words if(!missing(words)) set_words(words) ## set_init_msg("") addBindings() }, set_words = function(words) { words <<- unique(as.character(words)) }, set_value = function(value) { old_value <- tclvalue(v) if(old_value == init_msg) tkconfigure(widget, foreground="black") v_local <- v tclvalue(v_local) <- value lindex <<- 0 tcl(widget, "icursor", "end") if(old_value != tclvalue(v)) tcl("event","generate", widget, "<>") callSuper(value) }, ## find match in word list findMatch = function(x) { ind <- grepl(sprintf("^%s", tolower(x)), tolower(words)) words[ind] }, showWordList = function(str) { ##' show the word list ##' @param str a string. If ##' missing do nothing, otherwise match against ##' string to generate word list. Popup menu ##' depending on length char.height <- 16 ## or compute from font metrics wds <- findMatch(str) if(length(wds) == 0) { no.wds <<- 0 hideWordList() return() } ## compute max.height -- number of words that can be shown screenheight <- as.numeric(tkwinfo("screenheight", widget)) y <- as.numeric(tclvalue(tkwinfo("rooty",widget))) max_words <- min(max.words, floor((screenheight - y)/char.height)) if(length(wds) > max_words) wds <- c(wds[1:max_words], "...") tkdelete(l, "0.0", "end") tkinsert(l, "end", paste(wds, collapse="\n")) lindex <<- 1; no.wds <<- length(wds) ## set geometry x <- as.numeric(tclvalue(tkwinfo("rootx", widget))) y <- as.numeric(tclvalue(tkwinfo("rooty",widget))) geo <- as.character(tkwinfo("geometry",widget)) geo <- as.numeric(strsplit(geo, "[x+]")[[1]]) tkwm.geometry(m, sprintf("%sx%s+%s+%s", geo[1], 10 + char.height*length(wds), x, y + geo[2])) ## popup tcl("wm","attributes", m, "topmost"=TRUE) tcl("wm","attributes", m, "alpha"=0.8) tkwm.deiconify(m) tcl("raise", m) highlightWordList() }, ## hide the word list hideWordList = function() { tcl("wm","attributes", m, "topmost"=FALSE) # not working! tkwm.withdraw(m) }, ## highlight word on lindex highlightWordList = function() { if(lindex > 0) { tktag.remove(l, "selectedWord", "0.0", "end") tktag.add(l,"selectedWord",sprintf("%s.0", lindex), sprintf("%s.end", lindex)) tktag.configure(l, "selectedWord", font="bold") } }, no_items = function() { length(no.wds) }, ## get current word. From lineindex if applicable, or from entry widget itself getCurrentWord = function() { if(no.wds > 0) if(lindex > 0) { tclvalue(tkget(l, sprintf("%s.0", lindex), sprintf("%s.end", lindex))) } else { "" } else tclvalue(v) }, ##' initial message code get_value = function() { "Get the text value" if(!is_init_msg()) as.character(tclvalue(v)) else "" }, set_text = function(text, hide=TRUE) { "Set text into widget" if(hide) hide_init_msg() set_value(text) }, set_init_msg=function(txt) { "Set the initial message" init_msg <<- txt }, is_init_msg=function() { "Is the init text showing?" if(nchar(init_msg) == 0) FALSE else as.character(tclvalue(v)) == init_msg }, hide_init_msg= function() { "Hide the initial text" if(is_init_msg()) { tkconfigure(widget, foreground="black") set_text("", hide=FALSE) } }, show_init_msg=function() { "Show the intial text" tkconfigure(widget, foreground="gray") set_text(init_msg, hide=FALSE) }, ##' Add bindings to entry box addBindings = function() { add_handler("", function(W, K) { ## set out virtual event, as otherwise we can;t have addHandlerKeystroke tcl("event","generate", .self$widget, "<>", "data"=K) ## Main bindings if(nchar(K) == 1 || K == "BackSpace") { ## single letter, popup menu val <- tclvalue(tcl(W, "get")) showWordList(val) } else if(K == "Down") { ## down arrow. Open if empty, but also scroll down list if(nchar(val <- getCurrentWord()) == 0) { showWordList(".") lindex <<- 0 } lindex <<- min(lindex + 1, no.wds) highlightWordList() } else if(K == "Up") { ## move up list lindex <<- max(lindex - 1, 1) highlightWordList() } else if(K == "Return") { ## get value and put into e widget hideWordList() if(lindex > 0) { set_value(getCurrentWord()) } else { tcl("event","generate", .self$widget, "<>") } } else if(K == "Escape") { ## close the word list hideWordList() lindex <<- 0 } }) ## show or hide, depending add_handler("", showWordList) tkbind(tcl("winfo", "toplevel", widget), "", hideWordList) tkbind(widget,"", hideWordList) add_handler("", hide_init_msg) add_handler("", hideWordList) add_handler("", function() { if(nchar(get_value()) == 0 && nchar(init_msg) > 0) show_init_msg() }) add_handler("", hideWordList) tkbind(l, "", function(x, y) { tmp <- as.character(tcl(l, "index", sprintf("@%s,%s", x, y))) lindex <<- as.numeric(strsplit(tmp, "\\.")[[1]][1]) highlightWordList() }) ## bind to text widget tkbind(l, "", function(x,y) { wd <- getCurrentWord() hideWordList() if(wd != "...") { set_value(getCurrentWord()) } }) ## we don't want focus on l tkbind(l, "", function() { tkfocus(widget) }) } ) ) ## A class for widget with items (radio buttons, checkbuttons) setRefClass("TcltkWidgetWithItems", contains=c("TcltkWidget"), fields=list( items = "ANY", # hold items button_items = "list" # item instances ), methods=list( ### Handlers are important bind_handler=function(signal) { ##' override. We bind to button items }, run_handlers=function() { ##' override. Handlers run by button item }, add_handler=function(signal, handler, user.data=NULL) { ##' add handler to each item ##' @return id of handler. A list. ## stash handler into list callSuper(signal, handler, user.data) ## add handler to each button item id <- lapply(button_items, function(i) { list(widget=i, id=i$add_handler(signal, handler, user.data)) }) return(id) }, remove_handler=function(id) { ##' @return NULL if(missing(id)) { lapply(button_items, function(i) i$remove_handler()) } else { lapply(id, function(i) { (i$widget)$remove_handler(i$id) }) } invisible() }, block_handler=function(id) { ##' @return NULL if(missing(id)) { lapply(button_items, function(i) i$block_handler()) } else { lapply(id, function(i) { (i$widget)$block_handler(i$id) }) } invisible() }, unblock_handler=function(id) { ##' @return NULL if(missing(id)) { lapply(button_items, function(i) i$unblock_handler()) } else { lapply(id, function(i) { (i$widget)$unblock_handler(i$id) }) } invisible() }, transfer_handlers=function() { ##' @return NULL "Copy handlers onto child items" lapply(button_items, function(i) { i$handlers <- handlers i$handler_args <- handler_args for(signal in names(handlers)) # signal i$bind_handler(signal) }) invisible() }, ################################################## get_items = function(drop=TRUE) { ##' @param drop if TRUE just items, else items and images as a data frame (if present) "Get items to select from. Drops images by default." if(drop) items[,1, drop=TRUE] else items # a data frame }, no_items = function() { "Number of items" length(get_items()) }, make_new_item = function(i, has_image, compound) { ##' @param i index from item list ##' @param has_image logical indicating if an image is specified ##' @param compound if an image, how is it shown "Make a new item. Called from set_items" ## OVerride in subclasses }, set_items = function(new_items, compound) { ##' @param new_items a vector of data frame (character, images) ##' @param compound if images, then specifies how. "Set new items for object" if(!is.data.frame(new_items)) { new_items <- data.frame(new_items, stringsAsFactors=FALSE) items <<- new_items has_image <- FALSE } else { items <<- new_items has_image <- TRUE } ## clear any children tclServiceMode(FALSE) lapply(as.character(tkwinfo("children", widget)), function(window_id) { tkpack.forget(window_id) }) ## add in button items button_items <<- lapply(seq_len(no_items()), function(i) { new_item <- make_new_item(i, has_image, compound) tkpack(new_item$get_widget(), side=orientation, anchor="nw") new_item }) transfer_handlers() tclServiceMode(TRUE) }, ## set_enabled=function(value) { callSuper(value) lapply(button_items, function(i) i$set_enabled(value)) invisible() } ) ) ## Radio button group setRefClass("RadioButton", contains=c("TcltkWidgetWithItems"), fields=list( orientation="character", # which orientation for packing state_variable="tclVar" # holds state ), methods=list( init_widget = function(parent, items, selected=1, horizontal=TRUE, compound="none") { ##' @param items a vector of items or a data frame with columns items and images (names) ##' @param compound if images specified, how to configure widget <<- ttkframe(parent) selected <- max(1, min(as.integer(selected), length(items))) orientation <<- ifelse(horizontal, "left", "top") # pack arguments for side state_variable <<- tclVar(ifelse(is.null(dim(items)), items[selected], items[selected,1])) set_items(items, compound) }, get_index = function() { "Get selected value by index" as.integer(which(get_items() %in% as.character(get_value()))) }, set_index = function(i) { "Set selected value by index" i <- as.integer(i) tmp <- get_items() if(i < 1 || i > length(tmp)) i <- 1 # default set_value(tmp[i]) }, get_value = function(index=FALSE) { "Get selected value" if(index) return(get_index()) as.character(tclvalue(state_variable)) }, set_value = function(value, index=FALSE) { "Set selected value by label" if(index) return(set_index(value)) if(value %in% get_items()) { state_variable_local <- state_variable tclvalue(state_variable_local) <- value } if(is_enabled()) tcl(button_items[[get_index()]]$get_widget(), "invoke") }, make_new_item=function(i, has_image, compound) { "Make a new item. Pass in image information" if(!has_image) new_item <- getRefClass("RadioButtonItem")$new(parent=widget, state_variable=state_variable, text=items[i,1]) else new_item <- getRefClass("RadioButtonItem")$new(parent=widget, state_variable=state_variable, text=items[i,1], image=items[i,2], compound) new_item }, set_items = function(new_items, compound="none") { ##' @param new_items character vector or data frame ##' @param compound "Set items for radio button group, configure handlers, set state, and add to frame" ## ## store selected in case we are replacing if(!is(items, "uninitializedField")) { selected <- get_index() } else { selected <- NULL } callSuper(new_items, compound) if(!is.null(selected)) set_index(selected) } )) setRefClass("RadioButtonItem", contains=c("TcltkWidget"), fields=list( state_variable="tclVar" ), methods=list( init_widget = function(parent, state_variable, text, image, compound="none") { ##' @param parent parent container ##' @param state_variable tclvariable holding the state ##' @param text value for the widget ##' @param image optional image ##' @param compound how to configure image if present widget <<- ttkradiobutton(parent, variable=state_variable) state_variable <<- state_variable set_label(text) if(!missing(image) && tclObj_exists(image)) set_image(image, compound) }, is_checked=function() { "Is this item the checked one?" as.character(tclvalue(state_variable)) == get_label() }, set_checked=function() { "Set this item as the checked one" state_variable_local <- state_variable tclvalue(state_variable_local) <- get_label() }, get_label=function() { "Get label text" as.character(tkcget(widget, "-text")) }, set_label=function(text) { "Set label text" tkconfigure(widget, value=text, text=text) }, set_image=function(image, compound="none") { "Configure image for radio button" tkconfigure(widget, image=image, compound=compound) } ##, ## make_f = function(signal) { ## ##' Make a function for the handler. Involves hackery to get signature correct ## f <- function() { ## h <- list() ## for(i in handler_args) h[[i]] <- get(i) ## h[['signal']] <- signal ## ##tcl("after", 150, function(...) { ## if(.self$is_checked()) ## run_handlers(h) ## ##}) ## } ## if(length(handler_args)) { ## ## do an eval/parse hack. Not sure how else to work with alist. ## txt <- paste("alist","(", ## paste(c(handler_args), "=", sep="", collapse=","), ## ")", sep="") ## formals(f) <- eval(parse(text=txt)) ## } ## f ## } ) ) ## checkbuttongroup setRefClass("CheckButtonGroup", contains=c("TcltkWidgetWithItems"), fields=list( orientation="character" ), methods=list( init_widget = function(parent, items, selected=FALSE, horizontal=TRUE, compound="none") { ##' @param items a vector of items or a data frame with columns items and images (names) ##' @param compound if images specified, how to configure widget <<- ttkframe(parent) orientation <<- ifelse(horizontal, "left", "top") # pack arguments for side set_items(items, compound) set_value(selected) }, make_new_item = function(i, has_image, compound) { "Make a new item. Pass in image information" if(!has_image) new_item <- getRefClass("CheckButton")$new(parent=widget, checked=FALSE, text=items[i,1]) else new_item <- getRefClass("CheckButton")$new(parent=widget, checked=FALSE, text=items[i,1], image=items[i,2], compound) new_item }, get_value=function(index=FALSE) { ind <- get_index() if(index) return(ind) get_items()[ind] }, set_value=function(value, index=FALSE) { ##' @param value vector of values from items if(index) return(set_index(value)) if(is.logical(value)) { .value <- rep(value, length.out=no_items()) ind <- which(.value) } else { ind <- which(get_items() %in% value) } set_index(ind) }, get_index=function() { ## return indices of logical which(sapply(button_items, function(i) i$get_value())) }, set_index=function(ind) { lapply(seq_len(no_items()), function(i) { if(i %in% ind) ## invoke calls command **and** changes state so we set_value after tcl(button_items[[i]]$get_widget(), "invoke") button_items[[i]]$set_value(i %in% ind) }) invisible() } ) ) ##' spinbutton class. Spinbutton is not a themed widget! setRefClass("SpinButton", contains=c("TcltkWidget"), methods= list( ## subclass overrides init_widget = function(parent, from=0, to=100, by=1, ...) { ## ttk spinbox new as of 8.5.9 out <- try(tkwidget(parent, "ttk::spinbox", from=from, to=to, increment=by), silent=TRUE) if(inherits(out, "try-error")) out <- tkwidget(parent, "spinbox", from=from, to=to, increment=by) widget <<- out }, get_value = function() { "Return specified value" as.numeric(tcl(widget,"get")) }, set_value = function(value, index=FALSE, notify=FALSE) { "set spinner values" tcl(widget,"set", as.numeric(value)) if(notify) { message("notify handler") } }, set_items = function(items) { "Set items to select from. A regular sequence" ## check that value is a regular sequence if(length(items) <=1) { warning("Can only assign a vector with equal steps, as produced by seq") return(obj) } if(length(items) > 2 && !all.equal(diff(diff(items)), rep(0, length(items) - 2))) { warning("Can only assign a vector with equal steps, as produced by seq") return(obj) } ## get current value, increment curValue <- get_value() inc <- head(diff(items), n=1) tkconfigure(widget, from=min(items), to=max(items), increment=inc) tcl(widget, "set", curValue) }, ## override the default for this, spinbox is old widget is_enabled = function() { as.character(tkcget(widget, "-state")) == "normal" } ) ) ## This gets folded into the gComponentR5tcltk class, so we cna define generic methods for these: ### methods for gComponentR5tcltk. Most are shared, but we have them hard coded. setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gComponentR5tcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { r5_widget <- obj@R5widget index <- getWithDefault(index, FALSE) if(index) { return(r5_widget$get_value(index=TRUE)) } else { val <- r5_widget$get_value() if(.hasSlot(obj, "coercewith") && !is.null(obj@coercewith)) return(obj@coercewith(val)) else return(val) } }) ## toggles state to be T or F setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gComponentR5tcltk"), function(obj, toolkit, index=NULL, ..., value) { r5_widget <- obj@R5widget index <- getWithDefault(index, FALSE) r5_widget$set_value(value, index=index) return(obj) }) setMethod("[", signature(x="gComponentR5tcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gComponentR5tcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { r5_widget <- x@R5widget items <- r5_widget$get_items() if(missing(i)) items else items[i] }) setReplaceMethod("[", signature(x="gComponentR5tcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gComponentR5tcltk"), function(x, toolkit, i, j, ..., value) { r5_widget <- x@R5widget if(!missing(i)) { items <- r5_widget$get_items() items[i] <- value value <- items } r5_widget$set_items(value) return(x) }) setMethod(".length", signature(toolkit="guiWidgetsToolkittcltk",x="gComponentR5tcltk"), function(x,toolkit) { r5_widget <- x@R5widget r5_widget$no_items() }) ## inherited enabled isn't workgin setReplaceMethod(".enabled", signature(toolkit="guiWidgetsToolkittcltk",obj="gComponentR5tcltk"), function(obj, toolkit, ..., value) { r5_widget <- obj@R5widget r5_widget$set_enabled(value) return(obj) }) ## ################################################## ## w <- tktoplevel() ## b <- getRefClass("Button")$new(parent=w, text="boom chica boom") ## tkpack(b$get_widget()) ## l <- getRefClass("Label")$new(parent=w, text="huh") ## tkpack(l$get_widget()) ## e <- getRefClass("Entry")$new(parent=w, text="", coerce.with=as.character) ## e$set_words(state.name) ## tkpack(e$get_widget()) ## id <- e$add_handler("<>", handler=function(W, user.data) { ## print(user.data) ## print(.self$get_value()) ## }, user.data="x") ## rb <- getRefClass("RadioButton")$new(parent=w, items=state.name[1:3], horizontal=TRUE) ## tkpack(rb$get_widget()) ## rb$add_handler("command", handler=function(user.data) { ## print(user.data$get_value()) ## }, user.data=rb) ## cbg <- getRefClass("CheckButtonGroup")$new(parent=w, horizontal=FALSE, items=state.name[1:3]) ## tkpack(cbg$get_widget()) ## id <- cbg$add_handler(command", handler=function(user.data) { ## print(user.data$get_value()) ## }, user.data=cbg) ## f <- "~/Downloads/dumb.gif" ## nm <- make_tcl_image("dump",f) ## cb <- getRefClass("CheckButton")$new(parent=w, text="test", image=nm, compound="left") ## tkpack(cb$get_widget()) ## items <- data.frame(a=state.name[1:3], b=c(nm,nm,nm), stringsAsFactors=FALSE) ## rb1 <- getRefClass("CheckButtonGroup")$new(parent=w, items=items, horizontal=TRUE, compound="left") ## tkpack(rb1$get_widget()) gWidgetstcltk/R/gcalendar.R0000644000176000001440000001306611646163451015402 0ustar ripleyusers## add calendar widget: shoule I have gcalendar, gcalendarbrowser? ## no handler function, can add to entry object with addhandler setClass("gCalendartcltk", representation = representation("gComponenttcltk", format="character"), contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setMethod(".gcalendar", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="", format="%Y-%m-%d", handler = NULL, action=NULL, container=NULL,...) { force(toolkit) theArgs <- list(...) if(format != "%Y-%m-%d") { message(gettext("The format argument is not employed. Pass in coercion function through the coerce.with argument if year-month-day is not desired."), "\n") format <- "%Y-%m-%d" } ## No initial date ## if(text == "" && format != "") ## text <- format(Sys.Date(), format) g <- ggroup(container=container, ...) e <- gedit(text, container=g, width=11, expand=TRUE) b <- gbutton("date", container=g) obj <- new("gCalendartcltk", block= getBlock(g), widget = getWidget(e), format=format, toolkit=toolkit, ID=getNewID(), e = new.env()) addHandlerClicked(b, action=obj, handler=function(h,...) { text <- svalue(obj) year <- as.numeric(format(as.Date(text, tag(obj, "format")), format="%Y")) month <- as.numeric(format(as.Date(text, tag(obj, "format")), format="%m")) makeCalendar(obj, year, month) }) if(!is.null(theArgs$coerce.with)) coerce.with <- theArgs$coerce.with else coerce.with <- function(x, ...) { as.Date(x, format=format) } theArgs <- list(...) tag(obj, "..entry") <- e tag(obj,"format") <- format tag(obj,"coerce.with") <- coerce.with return(obj) # drop down to tcltk widget }) setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gCalendartcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { svalue(tag(obj, "..entry")) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gCalendartcltk"), function(obj, toolkit, index=NULL, ..., value) { widget <-tag(obj, "..entry") svalue(widget) <- value }) ## helper makeCalendar <- function(widget, year, month) { toplevel <- tktoplevel() f <- ttkframe(toplevel, padding=c(3,3,12,12)) tkpack(f, expand=TRUE, fill="both", side="top") cframe <- ttkframe(f) calframe <- ttkframe(f) tkpack(cframe, fill="x", side="top") tkpack(calframe, expand=TRUE, anchor="n") year <- year; month <- month # function local ##' from chron with slight change to arguments day.of.week <- function (year, month, day) { ix <- year + trunc((month - 14)/12) jx <- (trunc((13 * (month + 10 - (month + 10)%/%13 * 12) - 1)/5) + day + 77 + (5 * (ix - (ix%/%100) * 100))%/%4 + ix%/%400 - (ix%/%100) * 2) jx%%7 } ## is this a valid date validDate <- function(year, month, day) !is.na(as.Date(sprintf("%s-%s-%s", year, month, day), format="%Y-%m-%d")) ## how many days in a month days.in.month <- function(year, month) { for(i in c(31, 30, 29, 28)) { if(validDate(year, month, i)) return(i) } } ## 0-based week of month week.of.month <- function(year, month, day) { first.day <- day.of.week(year, month, 1) (first.day + day - 1) %/% 7 } makeMonth <- function(w, year, month) { ## add headers days <- c("S","M","T","W","Th","F","S") lapply(1:7, function(i) { l <- ttklabel(w, text=days[i]) # color tkgrid(l, row=0, column=i-1, sticky="") }) ## add days lapply(1:days.in.month(year, month), function(day) { l <- ttklabel(w, text=day) ## bind to each day ## might be more efficient to bind to toplevel and intercept tkbind(l, "", function(W) { day <- tclvalue(tkcget(W,"-text")) svalue(widget) <- sprintf("%s-%s-%s", year, month, day) tkdestroy(toplevel) }) tkgrid(l, row=1 + week.of.month(year, month, day), column=day.of.week(year, month, day), sticky="e") }) } ## controls prevb <- ttklabel(cframe, text="<") nextb <- ttklabel(cframe, text=">") curmo <- ttklabel(cframe) tkpack(prevb, side="left", anchor="w") tkpack(curmo, side="left", anchor="center", expand=TRUE) tkpack(nextb, side="left", anchor="e") setMonth <- function() { tkpack("forget", calframe) calframe <<- ttkframe(f); tkpack(calframe) makeMonth(calframe, year, month) tkconfigure(curmo, text=sprintf("%s %s", month.abb[month], year)) } setMonth() # initial calendar tkbind(prevb, "", function() { if(month > 1) { month <<- month - 1 } else { month <<- 12; year <<- year - 1 } setMonth() }) tkbind(nextb, "", function() { if(month < 12) { month <<- month + 1 } else { month <<- 1; year <<- year + 1 } setMonth() }) } gWidgetstcltk/R/zzz.R0000644000176000001440000000377612362772220014322 0ustar ripleyusers.onLoad <- function(libname,pkgname,...) { ## methods isn't loaded yet, so we try calling through :: oldClasses <- c("tkwin", "tclVar", "tclObj") methods::setClass("tcltkObject") lapply(oldClasses, function(i) { methods::setOldClass(i) methods::setIs(i,"tcltkObject") }) } tcltkStockIcons <- TcltkStockIcons$new() .onAttach <- function(...) { ## version check if(as.numeric(.Tcl("info tclversion")) < 8.5) { packageStartupMessage("\n\n *** gWidgetstcltk needs tcl/tk version 8.5 or newer ***\n\n") } ## some configuration .Tcl("option add *tearOff 0") # disable tearoff menus ## read in tklibs (from tcltk2 pacakge) f <- system.file("tklibs", "tablelist5.6", package="gWidgetstcltk") if(file.exists(f)) addTclPath(f) tclRequire("tablelist") sapply(c("tablelistConfig.tcl", "tablelistBind.tcl", "tablelistBind.tcl", "tablelistUtil.tcl", "tablelistEdit.tcl"), function(i) { f <- system.file("tklibs", "tablelist5.6", "scripts", i, package="gWidgets2tcltk") if(file.exists(f)) tcl("source", f) }) f <- system.file("tklibs", "tooltip1.4", package="gWidgetstcltk") if(file.exists(f)) addTclPath(f) try(tclRequire("tooltip"), silent=TRUE) f <- system.file("tklibs", "autoscroll.tcl", package="gWidgetstcltk") if(file.exists(f)) tcl("source", f) ## ## read in tklibs (from tcltk2 pacakge) ## addTclPath(system.file("tklibs", package="gWidgetstcltk")) ## tclRequire("tooltip") ## tclRequire("autoscroll") ## Icons tcltkStockIcons$load_gWidgets_icons() ## use.table options ## images from http://ryanfait.com/resources/custom-checkboxes-and-radio-buttons/. Thanks f <- system.file("images", "checkbutton-off.gif", package="gWidgetstcltk") if(file.exists(f)) tkimage.create("photo", "::image::off", file=f) f <- system.file("images", "checkbutton-on.gif", package="gWidgetstcltk") if(file.exists(f)) tkimage.create("photo", "::image::on", file=f) } gWidgetstcltk/R/gfile.R0000644000176000001440000001610212041063550014527 0ustar ripleyusers## file chooser dialog: creates gfile and gfilebrowser setMethod(".gfile", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="", type=c("open","save","selectdir"), initialfilename = NULL, filter = list( "All files"=list( patterns=c("*") ), "R files"=list( patterns=c("*.R","*.Rdata") ), "text files"=list( mime.types=c("text/plain") ) ), handler = NULL, action = NULL, # ... ) { force(toolkit) args = list(...) ## this will be in the API, for now we pass in through ... multiple <- getWithDefault(args$multiple, FALSE) ## pass in initial dir information, or get from filename, or get from option, or setwd initialdir <- args$initialdir if(is.null(initialdir) && !is.null(initialfilename)) initialdir <- dirname(initialfilename) if(is.null(initialdir)) initialdir <- getOption("gWidgetstcltk::gfile_initialdir") ## may still be NULL that is okay options("gWidgetstcltk::gfile_initialdir"=initialdir) # store type = match.arg(type) ## different things depending on type if(type == "open") { theFilter = "" if(!is.null(filter)) { ## turn named character vector into list of patterns if(is.character(filter)) { filter <- sapply(names(filter), function(nm) { list(patterns=paste(".", filter[nm], sep="")) }, simplify=FALSE) filter[['All files']]$patterns = "*" } for(i in names(filter)) { pats = filter[[i]]$patterns if(!is.null(pats)) { theFilter = paste(theFilter,"{{", i,"} ", if(length(pats) > 1) paste("{",paste(filter[[i]]$patterns,collapse=" "), "}} ", sep="",collapse="") else paste(pats,"} ",sep="",collapse=""), sep="",collapse="") } } } else { theFilter = "{{All files} *}" } l <- list(title=text, filetypes=theFilter, multiple=multiple) if(!is.null(initialfilename)) l$initialfile=initialfilename if(!is.null(initialdir)) l$initialdir=initialdir val <- do.call("tkgetOpenFile", l) if(multiple) { val <- as.character(val) # empty = character(0) if(length(val) == 0) val <- NA } else { val <- tclvalue(val) # empty="" if(val == "") val <- NA } ## save initialdir information if(!is.na(val[1]) && nchar(val[1]) > 0) options("gWidgetstcltk::gfile_initialdir"=dirname(val[1])) } else if(type == "save") { l <- list(title=text) l$initialfile <- initialfilename val <- do.call(tkgetSaveFile, l) val <- tclvalue(val) } else if(type == "selectdir") { val <- tkchooseDirectory() val <- tclvalue(val) } if (length(val) > 1 || nchar(val) > 0) { h = list(obj = NULL, action=action, file=val) if(!is.null(handler)) handler(h) ## how to return filename? return(val) } else { ## cancel return(NA) } }) ################################################## ## gfilebrowser is not modal, like gfile setClass("gFilebrowsetcltk", contains="gEdittcltk", prototype=prototype(new("gEdittcltk")) ) ## create a browse button -- put value into text box setMethod(".gfilebrowse", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="Select a file...", type="open", quote=TRUE, container=NULL, ...) { if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } group = ggroup(horizontal=TRUE, container=container) entry = gedit(text=text, container=group, ...) browseButton = gbutton("browse",container=group) args <- list(...) filter <- args$filter initialfilename <- args$initialfilename file.cb = function(h,...) { ## called when button is clicked ## in this h is gFile object, not gBrowse object gfile(text=text, type = type, handler = function(h,...) svalue(entry) <- h$file, quote = TRUE, filter=filter, initialfilename=initialfilename ) } addhandlerclicked(browseButton,handler=file.cb) ## put entry as widget to pick up gEdit methods obj = new("gFilebrowsetcltk", # block=group, widget=entry@widget@widget, toolkit=toolkit,ID=getNewID()) block=group, widget=entry@widget, toolkit=toolkit,ID=getNewID(),e = new.env()) tag(obj,"entry") <- entry invisible(obj) }) setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gFilebrowsetcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { entry <- tag(obj,"entry") svalue(entry,index,drop,...) }) ## svalue<- setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk", obj="gFilebrowsetcltk"), function(obj, toolkit, index=NULL, ..., value) { entry <- tag(obj,"entry") svalue(entry, index, ...) <- value return(obj) }) ## Pass down to entry -- id must good for entry though XXX could be fixed setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gFilebrowsetcltk"), function(obj, toolkit, handler, action=NULL, ...) { entry <- tag(obj, "entry") addHandlerChanged(entry, handler, action, ...) }) gWidgetstcltk/R/aabClasses.R0000644000176000001440000000202311406426756015516 0ustar ripleyusers### these classes need to be defined before their subclasses. Alphabetical doesn't cut ### is so they go here. ## for coerce.with setClassUnion("NULLorFunction",c("NULL","function")) ### this must come after aaaGenerics, as there gComponenttcltk is defined setClass("gEdittcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setClass("gGrouptcltk", representation = representation("gContainertcltk", horizontal="logical"), contains="gContainertcltk", prototype=prototype(new("gContainertcltk")) ) setClass("gWindowtcltk", representation = representation("gContainertcltk"), ## horizontal="logical"), contains="gContainertcltk", prototype=prototype(new("gContainertcltk")) ) setClass("gNotebooktcltk", representation = representation("gContainertcltk", closebuttons="logical", dontCloseThese="numeric"), contains="gContainertcltk" ) gWidgetstcltk/R/gtable.R0000644000176000001440000007057611646163615014733 0ustar ripleyusers## TODO: ## * issue with 1 col, space in values ## * use colnames to decide width ## ## NEED to make icons use #0 column, start with column 1 for others ## adjust ## table for selecting values from a data frame ## uses tree to show table setClass("gTabletcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## some helper functions .allChildren <- function(obj) { unlist(strsplit(tclvalue(tcl(getWidget(obj),"children",""))," ")) } ## covert a dta frame into a character based on .toCharacter <- function(x,width=NULL,...) UseMethod(".toCharacter") .toCharacter.default <- function(x,width=NULL,...) as.character(x) .toCharacter.integer <- function(x,width=NULL,...) { if(missing(width)) width <- max(nchar(as.character(x))) + 2 format(x, justify="right", digits=width) } .toCharacter.numeric <- function(x,width=NULL,...) { if(missing(width)) width <- max(nchar(as.character(x))) + 2 format(x,trim=FALSE, digits=width, justify="right") } .toCharacter.factor <- function(x,width=NULL,...) { if(missing(width)) width <- max(nchar(as.character(x))) + 2 .toCharacter(as.character(x),width,...) } .toCharacter.logical <- function(x,width=NULL,...) { if(is.null(width)) width <- 7 width <- max(7, width) format(as.character(x), justify="centre", width=width) } .toCharacter.data.frame <- function(x,width=NULL,...) { ##sapply(x, .toCharacter, width=width, ...) nms <- names(x) df <- as.data.frame(lapply(x,function(i) .toCharacter(i, width)), stringsAsFactors=FALSE) names(df) <- nms return(as.matrix(df)) } .toCharacter.matrix <- function(x, width=NULL, ...) { .toCharacter(as.data.frame(x), width, ...) } ## pass in argument ## function(x, width, ...) toCharacter <- getWithDefault(options("gw_toCharacter"), .toCharacter) ##' ##' ##' load table from data frame ##' ##' @param tr treeview widget ##' @param items data frame ##' @param visible which rows are visible, recyled ##' @param icons do we have icons? ##' @param fresh no clue ##' @return NULL .populateTable <- function(tr, items, visible=TRUE, icons=NULL, fresh=TRUE) { ## we load things row by row -- not by column like others ## we leave text value empty, saving spot for icon. ## How to adjust width? ## a matrix # items <- sapply(items, as.character) items <- .toCharacter(items) m <- nrow(items); n <- ncol(items) ## Compute widths for each column based on size widths <- widthOfChar * .computeWidths(items) for(j in seq_len(n)) tcl(tr,"column", j , width=widths[j], stretch=FALSE) ## set up headers nms <- colnames(items) for(j in seq_len(n)) tcl(tr,"heading", j, text=nms[j]) tcl(tr, "column", n, stretch=TRUE) ## icon column tcl(tr,"column","#0",width=ifelse(is.null(icons), 0L, 32L), stretch=FALSE) # if(fresh) # tcl(tr,"column",0,width=1, stretch=FALSE) # override below if needed ## add values ## deal with visible visible <- rep(visible, length=m) items <- items[visible,,drop=FALSE] ## add values row by row. If only one column, we need to esscape if(n == 1) items[,1] <- paste("{", items[,1], "}", sep="") ## if icons, we create if(!is.null(icons)) { icons <- sapply(icons,findIcon) if(length(icons) < m) icons <- c(icons, rep("", m - length(icons))) } ## add in values row by row lapply(seq_len(m), function(i) { values <- items[i,] if(is.null(icons)) tcl(tr,"insert","","end", values = values) else tcl(tr,"insert","","end", values = values, image=icons[i]) }) } ## set anchor of columns for justification .setAnchors <- function(tr, items) { anchorStyle <- function(x) UseMethod("anchorStyle") anchorStyle.default <- function(x) "center" anchorStyle.numeric <- function(x) "e" anchorStyle.character <- function(x) "w" ## set anchorStyle for(j in 1:ncol(items)) tcl(tr,"column", j , anchor=anchorStyle(items[,j,drop=TRUE])) } ## clear the children. Should also remove row count .clearColumns <- function(tr) { vals <- tcl(tr,"children","") tcl(tr,"delete", vals) } ## compute widths needed from data.frame .computeWidths <- function(d) { d <- as.data.frame(d) nms <- names(d) n <- dim(d)[2] sapply(1:n, function(j) max(10,sapply(c(nms[j],as.character(d[,j,drop=TRUE])), nchar))) } ## constructor for selecting values from a data set -- not meant for editing setMethod(".gtable", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, items, multiple = FALSE, chosencol = 1, # for drag and drop, value icon.FUN = NULL, filter.column = NULL, filter.labels = NULL, filter.FUN = NULL, # two args gtable instance, filter.labels element handler = NULL, action = NULL, container = NULL, ...) { ## NOT IMPLEMENTED ## * sorting force(toolkit) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } theArgs = list(...) ## we want a data frame for items if(missing(items)) items <- data.frame(x=c(""),stringsAsFactors=FALSE) ## coerce items to a data frame if(!(inherits(items,"matrix") || inherits(items,"data.frame"))) items <- data.frame(items=items, stringsAsFactors=FALSE) d <- dim(items); m <- d[1]; n <- d[2] ## if filtering we call a different constructor ## we are filtering if filter.FUN or filter.column is ## not null *UNLESS* filter.FUN = "manual" if((!is.null(filter.FUN) && is.function(filter.FUN )) || (is.null(filter.FUN) && !is.null(filter.column))) { obj <- .gtableWithFilter(toolkit, items, multiple, chosencol, icon.FUN, filter.column, filter.labels, filter.FUN, handler, action, container,...) return(obj) } ## selectmode selectmode = if(multiple) "extended" else "browse" ########## ## setup widget ## Big hack here to get this working with scrollbars inside a glayout container ## we have double nesting. Later we turn off propogation, as otherwise the treeview size ## is used, not the encolosing frame and scrollbars are always shown tt <- getWidget(container) gp1 <- ttkframe(tt) gp <- ttkframe(gp1) tkpack(gp, expand=TRUE, fill="both") xscr <- ttkscrollbar(gp, orient="horizontal", command=function(...) tkxview(tr,...)) yscr <- ttkscrollbar(gp, orient="vertical", command=function(...) tkyview(tr,...)) tr <- ttktreeview(gp, columns = 1:n, displaycolumns=if(is.null(icon.FUN)) 1:n else "#all", show = ifelse(is.null(icon.FUN), "headings", c("tree headings")), selectmode = selectmode, xscrollcommand=function(...) tkset(xscr,...), yscrollcommand=function(...) tkset(yscr,...) ) ## pack into grid ## see tkFAQ 10.1 -- makes for automatic resizing tkgrid(tr, row=0, column=0, sticky="news") tkgrid(yscr, row=0, column=1, sticky="ns") tkgrid(xscr, row=1, column=0, sticky="ew") tkgrid.columnconfigure(gp, 0, weight=1) tkgrid.rowconfigure(gp, 0, weight=1) ## call in autoscroll do.autoscroll <- getWithDefault(theArgs$do.autoscroll, TRUE) if(do.autoscroll && windowingsystem() != "aqua") { tcl("autoscroll::autoscroll", xscr) tcl("autoscroll::autoscroll", yscr) } ## ###################### obj = new("gTabletcltk",block=gp1,widget=tr, toolkit=toolkit,ID=getNewID(), e = new.env()) tag(obj,"icon.FUN") <- icon.FUN tag(obj,"chosencol") <- chosencol tag(obj,"color") = if(!is.null(theArgs$color)) theArgs$color else "gray90" tag(obj,"colnamesColor") = if(!is.null(theArgs$colnamesColor)) theArgs$colnamesColor else "red" tag(obj,"visible") <- NULL tag(obj, "round") <- getWithDefault(theArgs$round, NULL) ## font -- fixed unless overridden # tkconfigure(tr, font="courier") # fixed ## add handler if (!is.null(handler)) { id = addhandlerchanged(obj,handler,action) } ## load data last to get size after adding tag(obj,"items") <- items icons <- if(is.null(icon.FUN)) NULL else icon.FUN(items) ## scrollable widgets need a width and height set. width <- getWithDefault(theArgs$width, 500) height <- getWithDefault(theArgs$height, 300) .populateTable(tr, items, visible=TRUE, icons) .setAnchors(tr, items) size(obj) <- c(width, height) ## add to container -- do after populating so widths are set add(container, obj,...) tcl("pack","propagate", gp1, FALSE) tkconfigure(gp1, width=width) tkconfigure(gp1, height=height) return(obj) }) ## incorporate chosenval here setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gTabletcltk"), function(obj, toolkit, index=NULL, drop=NULL,...) { widget = getWidget(obj) sel <- unlist(strsplit(tclvalue(tcl(widget,"selection"))," ")) if(length(sel) == 0) { return(NA) # check proper return } theChildren <- .allChildren(widget) indices <- sapply(sel, function(i) match(i, theChildren)) ##which(sel == theChildren) inds <- which(visible(obj))[indices] if(!is.null(index) && index == TRUE) { return(inds) # oops, had index } ## Now a value if(missing(drop) || is.null(drop)) drop <- TRUE # default is to drop unless asked not to chosencol <- tag(obj,"chosencol") if(drop) return(obj[inds, chosencol, drop=drop]) else return(obj[inds, ]) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gTabletcltk"), function(obj, toolkit, index=NULL, ..., value) { widget <- getWidget(obj) theChildren <- .allChildren(widget) if(!is.null(index) && index) { ## set by index tcl(widget,"selection","set",theChildren[value]) } else { ## set value if present ## need to update this for our hack to handle data frames items <- tag(obj,"items") m <- match(value,items[,tag(obj,"chosencol"),drop=TRUE]) if(!is.na(m)) { # NA is nomatch tcl(widget,"selection","set",theChildren[m]) } } return(obj) }) ## get values setMethod("[", signature(x="gTabletcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gTabletcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { items <- tag(x,"items") if(missing(j)) j <- 1:ncol(items) return(items[i,j, drop=drop]) }) ## XXX -- harder one ## do [,]; [i,], [,j] (no new row, column); [i,j] no new value ## replace values setReplaceMethod("[", signature(x="gTabletcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gTabletcltk"), function(x, toolkit, i, j, ..., value) { widget <- getWidget(x) items <- tag(x,"items") icon.FUN <- tag(x,"icon.FUN") if(is.null(icon.FUN)) icon.FUN <- function(x) NULL theArgs <- list(...) if(is.null(theArgs$doVisible)) tag(x,"visible") <- NULL ## what to do ## main case [,] -- populate if(missing(i) && missing(j)) { ## replace entire thing .clearColumns(widget) items <- as.data.frame(value, stringsAsFactors=FALSE) tag(x,"items") <- items .populateTable(widget, items, visible(x), icon.FUN(items)) return(x) } d <- dim(x) ## error check if(missing(i)) { if(max(j) > dim(x)[2]) { message(gettext("Can't add columns. Use [,]<-\n")) return(x) } i <- 1:d[1] } else if(missing(j)) { if(max(i) > dim(x)[1]) { message(gettext("Can't add rows. Use [,]<-\n")) return(x) } j <- 1:d[2] } ## size is okay items[i,j] <- value tag(x,"items") <- items # set citems <- .toCharacter(items, tag(x, "round")) allChildren <- .allChildren(widget) ## add row by row (i) for(ind in 1:length(i)) { ## add one at a time, don't redo icon ## might be able to speed up (value=unlist(citems[ind]) ## This doesn't redo icons! lapply(1:length(j), function(k) { vals <- citems[ind,j[k],drop=FALSE] tcl(widget,"set",allChildren[ind], j[k], unlist(vals)) }) } return(x) }) ## dim setMethod(".dim", signature(toolkit="guiWidgetsToolkittcltk",x="gTabletcltk"), function(x, toolkit) { dim(tag(x,"items")) }) ## length setMethod(".length", signature(toolkit="guiWidgetsToolkittcltk",x="gTabletcltk"), function(x, toolkit) { length(tag(x,"items")) }) setMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="gTabletcltk"), function(obj, toolkit, set=TRUE, ...) { visible <- tag(obj,"visible") if(is.null(visible)) visible <- rep(TRUE, dim(obj)[1]) return(visible) }) setReplaceMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="gTabletcltk"), function(obj,toolkit, ..., value) { d <- dim(obj) value <- rep(value, length=d[1]) # recycle! tag(obj,"visible") <- value ## now redraw obj[,,doVisible=TRUE] <- tag(obj,"items") return(obj) }) setMethod(".names", signature(toolkit="guiWidgetsToolkittcltk",x="gTabletcltk"), function(x, toolkit) { widget <- getWidget(x) d <- dim(x); n <- d[2] nms <- sapply(1:n,function(j) tclvalue(tcl(widget,"heading",j,"-text"))) unlist(nms) }) setReplaceMethod(".names", signature(x="gTabletcltk"), function(x,toolkit, value) { widget <- getWidget(x) d <- dim(x); n <- d[2] if(length(value) != n) { message(gettext("names<- must match length\n")) return(x) } lapply(1:n,function(j) tcl(widget,"heading",j,"text"=value[j])) return(x) }) ##' set size ##' ##' Width setting is hacked in if value is a list, ##' we convert to pixel size so this should be related to the number of characters ##' @param value either a numeric vector with 1 or 2 values to set ##' width [height] or A list with components width, height, columnWidths, and noRowsShown setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gTabletcltk"), function(obj, toolkit, ..., value) { if(is.list(value) && !is.null(value$columnWidths)) { ## do column widths widths <- value$columnWidths widths <- rep(widths, length.out=dim(obj)[2]) lapply(seq_along(widths[-length(widths)]), function(j) { tcl(getWidget(obj), "column", j, width=widths[j], stretch=TRUE) # -1? }) } if(is.list(value) && !is.null(value$noRowsShown)) { tkconfigure(getBlock(obj), height = value$noRowsShown * 16) # XXX compute font size } ## set basic size of widget block if(is.list(value)) { width <- value$width # possibly NULL height <- value$height # possibly NULL } else { ## a vector c(width, height) width <- value[1] height <- ifelse(length(value) > 1, value[2], NULL) } ## try to avoid size issue. ## set width -- value in pixels block <- getBlock(obj) if(!is.null(width) || !is.null(height)) { ## stop propogation after changing size tcl("grid","propagate",block, FALSE) if(!is.null(width)) tkconfigure(block, width=width) if(!is.null(height)) tkconfigure(block, height=height) } return(obj) }) ## handlers setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gTabletcltk"), function(obj, toolkit, handler, action=NULL, ...) { addhandlerdoubleclick(obj, handler, action,...) }) ## when a selection is changed setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gTabletcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj,toolkit,signal="<>", handler, action,...) }) ## pretty print table .prettyPrintTable = function(x, do.names = TRUE, justify="left") { ## the columns, a matrix if(is.matrix(x)) x = as.data.frame(x, stringsAsFactors = FALSE) y = sapply(x, function(i) format(i, justify=justify)) if(do.names) { n = names(x) y = rbind(n,y) for(j in 1:ncol(y)) y[,j] = format(y[,j], justify=justify) } z = sapply(1:nrow(y), function(i) paste(y[i,],sep="", collapse=" ")) return(z) } ################################################## ################################################## ### for filtering ## table for selecting values ## most methods in gdf.R inherited from gGrid class setClass("gTableWithFiltertcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setGeneric(".gtableWithFilter", function(toolkit, items, multiple = FALSE, chosencol = 1, # for drag and drop, value icon.FUN = NULL, filter.column = NULL, filter.labels = NULL, filter.FUN = NULL, # two args gtable instance, filter.labels element handler = NULL, action = NULL, container = NULL, ...) standardGeneric(".gtableWithFilter") ) setMethod(".gtableWithFilter", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, items, multiple = FALSE, chosencol = 1, # for drag and drop, value icon.FUN = NULL, filter.column = NULL, filter.labels = NULL, filter.FUN = NULL, # two args gtable instance, filter.labels element handler = NULL, action = NULL, container = NULL, ...) { ## we only get here *if* we are filtering g = ggroup(horizontal=FALSE, container=container, ...) fg = ggroup(container=g) filterByLabel = glabel("Filter by:", container=fg) filterPopup = gdroplist(c(""), container=fg) tbl = gtable(items, multiple=multiple, chosencol=chosencol, container=g, expand=TRUE) ## make an object to return obj = new("gTableWithFiltertcltk",block=g,widget=tbl, toolkit=toolkit,ID=getNewID()) tag(obj, "allItems") <- items tag(obj, "tbl") <- tbl tag(obj, "filterPopup") <- filterPopup tag(obj, "filterByLabel") <- filterByLabel ## one of filter.column or filter.fun is non-NULL if(is.null(filter.FUN)) { ## define filter.FUN filter.FUN = function(DF, filterBy) { if(filterBy == "") return(rep(TRUE,nrow(DF))) inds = as.character(DF[,filter.column]) == filterBy } ## set up droplist filterPopup[] <- c("",sort(unique(as.character(items[,filter.column])))) svalue(filterByLabel) <- paste("Filter by",names(items)[filter.column],"==",sep=" ", collapse=" ") } else { ## set up droplist filterPopup[] <- c("",filter.labels) } tag(obj,"filter.FUN") <- filter.FUN ## get obj from scoping addHandlerChanged(filterPopup,action=obj, handler=function(h,...) { DF = tag(obj, "allItems") tbl = tag(obj,"tbl") filter.fun = tag(obj,"filter.FUN") fval = svalue(h$obj) # popup inds = filter.FUN(DF, fval) ## update tbl obj[,] <- DF[inds,,drop=FALSE] ## but keep allItems tag(obj,"allItems") <- DF }) ## add handler to gtable object, but pass in override for methods if(!is.null(handler)) ID= addhandlerchanged(tbl,handler,action,actualobj=obj,...) return(obj) }) setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gTableWithFiltertcltk"), function(obj, toolkit, index=NULL, drop=NULL,...) { if(!is.null(index) && index) { gwCat("The index refers to the visible data value, not the entire data frame\n") } return(svalue(obj@widget, toolkit=toolkit, index=index, drop=drop, ...)) }) ## refers to visible setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gTableWithFiltertcltk"), function(obj, toolkit, index=NULL, ..., value) { tbl = tag(obj,"tbl") svalue(tbl, toolkit=toolkit, index=index, ...) <- value return(obj) }) ## retrieve values setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gTableWithFiltertcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { tbl = tag(x,"tbl") # dot function .leftBracket(tbl, toolkit, i, j, ..., drop=drop) }) setMethod("[", signature(x="gTableWithFiltertcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) ## replace values setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gTableWithFiltertcltk"), function(x, toolkit, i, j, ..., value) { if(!missing(i) || !missing(j)) { gwCat(gettext("[<- only replaces the entire object. Try obj[,]<-value\n")) return(x) } ## underlying gtable object tbl = tag(x,"tbl") ## We have to a) update allItems, b) update table tag(x, "allItems") <- value ## tbl needs to be filtered DF = value fval = svalue(tag(x, "filterPopup")) if(fval == "") { tbl[,] <- DF } else { filter.FUN = tag(x,"filter.FUN") inds = filter.FUN(DF, fval) tbl[,] <- DF[inds,,drop=FALSE] } return(x) }) setReplaceMethod("[", signature(x="gTableWithFiltertcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) ## dim setMethod(".dim", signature(toolkit="guiWidgetsToolkittcltk",x="gTableWithFiltertcltk"), function(x, toolkit) { tbl = tag(x,"tbl") return(dim(tbl)) }) ## length setMethod(".length", signature(toolkit="guiWidgetsToolkittcltk",x="gTableWithFiltertcltk"), function(x, toolkit) { tbl = tag(x,"tbl") return(length(tbl)) }) ## size<- work on tr setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gTableWithFiltertcltk"), function(obj, toolkit, ..., value) { tbl = tag(obj,"tbl") size(tbl) <- value return(obj) }) ## handlers ## changed is double click event setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gTableWithFiltertcltk"), function(obj, toolkit, handler, action=NULL, ...) { tbl = tag(obj,"tbl") .addhandlerdoubleclick(tbl, toolkit, handler, action,actualobj=obj) }) ## same as changed setMethod(".addhandlerdoubleclick", signature(toolkit="guiWidgetsToolkittcltk",obj="gTableWithFiltertcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerchanged(obj, toolkit, handler, action,...) }) ## when a selection is changed setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gTableWithFiltertcltk"), function(obj, toolkit, handler, action=NULL, ...) { tbl = tag(obj,"tbl") .addHandler(tbl,toolkit,signal="<>", handler, action, actualobj=obj) }) gWidgetstcltk/R/common.R0000644000176000001440000004301511666053511014744 0ustar ripleyusers## Common functions #Paste = function(x,...) paste(x,...,sep="",collapse="") ## CONSTANTS widthOfChar <- ceiling(as.numeric(tclvalue(tcl("font","measure","TkTextFont","0")))) heightOfChar <- as.numeric(as.character(tcl("font","metrics","TkTextFont"))[6]) xyToAnchor = function(anchor) { m = rbind( c("nw","n","ne"), c("w","center","e"), c("sw","s","se") ) anchor = m[2 - anchor[2],2 + anchor[1]] return(anchor) } isMac <- function() { as.character(tcl("tk","windowingsystem")) == "aqua" } DEBUG = function(...) { if(0) message(paste(...,sep=" ",collapse=" "),"\n") } ## paste() helpers Paste = function(..., sep="", collapse="") { x = unlist(list(...)) x = x[!is.na(x)] x = x[x != "NA"] paste(x, sep=sep, collapse=collapse) } PasteWithComma = function(...) { args = unlist(list(...)) args = args[!is.na(args)] paste(args, sep="", collapse=", ") } ## from regex man page stripWhiteSpace = function(str) { sub('[[:space:]]+$', '', str) ## from ?gsub sub('^[[:space:]]+', '', str) ## from ?gsub return(str) } quoteIfNeeded = function(str) { if(length(grep('^\\".*\\"$', str, perl=TRUE)) > 0 || length(grep("^\\'.*\\'$", str, perl=TRUE)) > 0 ) return(str) else return(paste('"',str,'"',sep="",collapse="")) } ## ReadParseEvaL -- saves typing rpel = function(STRING, envir=.GlobalEnv) { eval(parse(text=STRING), envir=envir) } showErrorMessage = function() { # leave here for scoping on command message = Paste("Error:", "\n\t",geterrmessage()) gmessage(message,icon="error") stop() } ## Push and Pop -- for convenience Push = function(v,d) c(v,d) Pop = function(v) ifelse(length(v) > 1, v[-length(v)], NA) ### is functions is.rJavaObject = function(obj) { is(obj,"rJavaObject") } is.guiWidget = function(obj) { is(obj,"guiWidget") } is.gWidget = function(obj) { is(obj,"gWidgetrJava") } is.gWindow = function(obj) { is(obj,"gWindowrJava") } is.gComponent = function(obj) { is(obj,"gComponentrJava") } is.gContainer = function(obj) { is(obj,"gContainer") } is.gImage = function(obj) { is(obj,"gImagerJava") } is.gLabel = function(obj) { is(obj,"gLabelrJava") } is.gMenu = function(obj) { is(obj,"gMenurJava") } is.gEditDataFrame=function(obj) { stop("deprecated, use is.gGrid") } is.gGrid = function(obj) { is(obj,"gGridrJava") } is.invalid = function(obj) { while(!is.rJavaObject(obj)) obj = obj@block ifelse("" %in% class(obj), TRUE, FALSE) } ## used to check output is.empty = function(obj) { if(is.null(obj) || is.na(obj) || obj == "") { return(TRUE) } else { return(FALSE) } } ## for showing only possible values is.dataframelike = function(obj) { if(is.data.frame(obj) || is.matrix(obj) || is.numeric(obj) || is.logical(obj) || is.factor(obj)) { return(TRUE) } else { return(FALSE) } } ## ## check if a gtkTreeViewCOlumn, make no GTK language ## is.gdataframecolumn = function(obj) { ## if(class(obj)[1] == "GtkTreeViewColumn") ## return(TRUE) ## else ## return(FALSE) ## } ## Function to convert back and forth between R classes and GObject classes RtoGObjectConversion = function(obj) { if("gComponent" %in% class(obj)) return("GObject") if(is.list(obj)) return("GObject") Klasse = class(obj)[1] # silly name? switch(Klasse, "integer"="gint", "numeric"="gdouble", "gtk"="GObject", "logical" = "gboolean", "gchararray" ) } ### these are used by gvarbrowser ## This is from browseEnv in base ## what type of object is thixs and a size str1 <- function(obj) { md <- mode(obj) lg <- length(obj) objdim <- dim(obj) if (length(objdim) == 0) dim.field <- paste("length:", lg) else { dim.field <- "dim:" for (i in 1:length(objdim)) dim.field <- paste(dim.field, objdim[i]) if (is.matrix(obj)) md <- "matrix" } obj.class <- oldClass(obj) if (!is.null(obj.class)) { md <- obj.class[1] if (inherits(obj, "factor")) dim.field <- paste("levels:", length(levels(obj))) } list( type = md, dim.field = dim.field) } ## what type of object is thixs and a size str2 <- function(obj) { md <- mode(obj) if (is.matrix(obj)) md <- "matrix" obj.class <- oldClass(obj) if (!is.null(obj.class)) { md <- obj.class[1] } return(md) } .datasets = c( "numeric","logical","factor","character", "data.frame","matrix","list", "table","xtabs", "nfnGroupedData","nffGroupedData","nmGroupedData" ) .models = c("lm","glm","lqs","aov","anova", "lme","lmList","gls", "ar","arma","arima0","fGARCH","fAPARCH" ) .ts = c("ts", "mts", "timeSeries", "its", "zoo") .functions=c("function") .plots = c("recordedplot") knownTypes = list( "data sets and models"=c(.datasets, .models, .ts), "data sets"= .datasets, "model objects" = .models, "time series objects" = .ts, "functions"=.functions, "saved plots" = .plots, "all" = NULL ) ## untaint a variable name so that $ can be used untaintName = function(objName) { if (length(grep(" |\\+|\\-|\\*|\\/\\(|\\[|\\:",objName)) > 0) { objName=Paste("\"",objName,"\"") } return(objName) } ## try to stip off data frame stuff in fron to DND target findDataParent = function(x) { child = sub(".*]]","",x) child = sub(".*\\$","",child) parent = sub(Paste(child,"$"),"",x) parent = sub("\\$$","",parent) return(list(child=child,parent=parent)) } ## basically repeat findDataParent until no parent findRootObject = function(x) { x = sub("\\[\\[.*","",x) x = sub("\\$.*","", x) return(x) } ## get does not work with name$component, this gets around that ## returns NULL if not available getObjectFromString = function(STRING="", envir=.GlobalEnv) { tmp = try(get(STRING, envir), silent = TRUE) if(!inherits(tmp, "try-error")) return(tmp) tmp = try(rpel(STRING,envir), silent=TRUE) if(!inherits(tmp, "try-error")) return(tmp) ## out of chances return(NULL) } ## get the names of the object, if available (datastores) getNamesofObject = function(STRING="") { ## if empty string, get variables in .GlobalEnv if(length(STRING) == 0 || STRING == "") { ## return objects of certain type objects = getObjectsWithType(root=NULL, filter=knownTypes[['data sets']]) return(unlist(objects$Name)) } obj = getObjectFromString(STRING) if(!is.null(obj)) { if(is.list(obj)) { return(names(obj)) } else if(is.matrix(obj)) { return(colnames(obj)) } else{ return(NULL) } } else { return(NULL) } } ## a function to get objects and their types ## filter is a vector of classes getObjectsWithType = function(root=NULL, filter = NULL, envir=.GlobalEnv) { if(is.null(root)) { objects = ls(envir=envir) } else { STRING = Paste("with(",root,",ls())") objects = try(rpel(STRING,envir=envir), silent=TRUE) } ## if empty send back if(length(objects) == 0) return( data.frame(Name=c(""),Type=c(""), stringsAsFactors=FALSE)) ## proceed ## objects is character vector of components of root. badnames = grep("[[<-]|\\*",objects) if(length(badnames) > 0) objects = objects[-badnames] objectsWithRoot = sapply(objects,function(i) makeObjectName(root,i)) type = sapply(objectsWithRoot, function(i) { STRING = Paste("str2(",i,")") rpel(STRING, envir=envir) }) objects = data.frame(Name=objects,Type=type, stringsAsFactors=FALSE) ## filter if(!is.null(filter)) objects = objects[type %in% filter,] return(objects) } ## Find the name of the object by pasting toghther the pieces ## better to do name$name, but value may be a numeric makeObjectName = function(root,value) { if(is.null(root)) return(untaintName(value)) ## now decide between $ and [[]] if(value == make.names(value)) { return(Paste(root,"$",untaintName(value))) } else { return(Paste(root,"[['",value,"']]")) } } ###### ## send a file to csv mode for editing "browseDataAsCSV" <- function(x) { x = try(as.data.frame(x)) if(inherits(x,"try-error")) { stop("Can not coerce data into a data frame") } tmpfile = paste(tempfile(),".csv",sep="",collapse="") write.csv(x,file=tmpfile) browseURL(paste("file://",tmpfile,sep="",collapse="")) } ## help out with gtree byReturnVector = function(df, FUN,...) { tmp = by(df, factor(1:nrow(df)), FUN) sapply(tmp, function(x) x) } hack.as.data.frame = function(items) { ## check rectangular, or coerce to rectangules if(!(is.data.frame(items) || is.matrix(items) || is.vector(items))) { warning("Needs rectangular data, either a vector, matrix or data.frame") return(NA) } ## coerce to data frame if(is.vector(items)) { itemsName = deparse(substitute(items)) items = data.frame(I(items)) names(items) = itemsName } if(is.matrix(items)) { items = hack.as.data.frame.matrix(items) # fun in common.R } return(items) } ## no easy way to not convert character vectors. This is a hack. hack.as.data.frame.matrix = function (x, row.names = NULL, optional = FALSE) { d <- dim(x) nrows <- d[1] ir <- seq(length = nrows) ncols <- d[2] ic <- seq(length = ncols) dn <- dimnames(x) if (missing(row.names)) row.names <- dn[[1]] collabs <- dn[[2]] if (any(empty <- nchar(collabs) == 0)) collabs[empty] <- paste("V", ic, sep = "")[empty] value <- vector("list", ncols) if (mode(x) == "character") { for (i in ic) value[[i]] <- as.character(x[, i]) } else { for (i in ic) value[[i]] <- as.vector(x[, i]) } if (length(row.names) != nrows) row.names <- if (optional) character(nrows) else as.character(ir) if (length(collabs) == ncols) names(value) <- collabs else if (!optional) names(value) <- paste("V", ic, sep = "") attr(value, "row.names") <- row.names class(value) <- "data.frame" value } ################################################## ## timestamp function for objects made with pmg ## Modified from R mailing list, value is comment. Need <- to act in ## OO manner comment needs to be a character vector. If a list were ## okay (say serialize()) then this could be different "Timestamp<-" <- function(obj,value) { currentStamp = Timestamp(obj) currentStamp = c(currentStamp, timestamp=as.character(Sys.time()),comment=value) comment(obj) <- currentStamp return(obj) } Timestamp = function(obj,k=1) { currentComment= comment(obj) allStamps =comment(obj)[names(comment(obj)) %in% "timestamp"] n = length(allStamps) if(n > 0) return(allStamps[(max(1,n+1-k)):n]) else return(NA) } ################################################# ## functions to deal with icons ## class to icon translation -- return stock name ## with prefix ## This is called on package load ## no chance that icons aren't yet there ##tcltkStockIcons <- new.env() TcltkStockIcons <- setRefClass("TcltkStockIcons", fields=list( l="list" ), methods=list( initialize=function(...) { initFields(l=list()) callSuper(...) }, load_gWidgets_icons=function() { dir <- system.file("images", package = "gWidgets") x <- list.files(dir, pattern="gif$", full.names=TRUE) nms <- basename(x) nms <- gsub("\\.gif$","",nms) add_icons(nms, x) }, add_icons=function(nms, x) { for(i in seq_along(nms)) { nm <- nms[i]; f <- x[i] iconName <- paste("::stockicon::",nm, sep="") out <- try(tcl("image","create","photo", iconName, file=f), silent=TRUE) if(!inherits(out,"try-error")) l[[nm]] <<- f } }, has_icon=function(stockname) { stockname <- as.character(stockname) out <- is.null(stockname) || nchar(stockname) == 0 || stockname == "" || is.null(l[[stockname, exact=TRUE]]) !out }, find_icon=function(stockname) { "REturn tcltk icon name" if(has_icon(stockname)) val <- paste("::stockicon::", stockname, sep="") else val <- "" return(val) }, find_icon_file=function(stockname) { "Return icon file:" if(has_icon(stockname)) l[[stockname, exact=TRUE]] else NULL }, show=function(...) cat("icon object\n") )) findIcon <- function(stockname) tcltkStockIcons$find_icon(stockname) #assignInNamespace("tcltkStockIcons", list(), ns="gWidgetstcltk") ## return string for tk functions based on stock icon nmae ## eg: findIcon("quit") -> "::stockicon::quit.gif" else "" ## findIcon <- function(stockname) { ## stockname <- as.character(stockname) ## if(is.null(stockname) || nchar(stockname) == 0 || stockname == "") ## return("") ## tcltkStockIcons <- getStockIcons() ## if(!is.null(tcltkStockIcons[[stockname, exact=TRUE]])) { ## iconName <- paste("::stockicon::", stockname, sep="") ## return(iconName) ## } else { ## return("") ## } ## } ## loadGWidgetIcons <- function() { ## ## tcltkStockIcons <- getFromNamespace("tcltkStockIcons", ns="gWidgetstcltk") ## dir <- system.file("images", package = "gWidgets") ## x <- list.files(dir, pattern="gif$", full.names=TRUE) ## nms <- basename(x) ## nms <- gsub("\\.gif$","",nms) ## lapply(1:length(x), function(i) { ## iconName <- paste("::stockicon::",nms[i], sep="") ## out <- try(tcl("image","create","photo", ## iconName, ## file=x[i]), silent=TRUE) ## if(!inherits(out,"try-error")) ## assign(nms[i], x[i], tcltkStockIcons) ## #tcltkStockIcons[[nms[i]]] <- x[i] ## }) ## ## assignInNamespace("tcltkStockIcons", tcltkStockIcons, ns="gWidgetstcltk") ## } ##allIcons = getStockIcons() ## find the stock icons. This includes those added bia loadGWidgetIcons() setMethod(".getStockIcons", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit) { tcltkStockIcons$l ## as.list(tcltkStockIcons) ##getFromNamespace("tcltkStockIcons", ns="gWidgetstcltk") }) ## add stock icons from files setMethod(".addStockIcons", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, iconNames, iconFiles, ...) { tcltkStockIcons$add_icons(iconNames, iconFiles) # .addToStockIcons(iconNames, iconFiles) }) ## .addToStockIcons <- function(iconNames, iconFiles) { ## ## for each: check if there, create, add to hash, store hash ## tcltkStockIcons <- getStockIcons() ## m <- cbind(iconNames, iconFiles) ## for(i in 1:nrow(m)) { ## if(!is.null(tcltkStockIcons[[i, exact=TRUE]])) { ## iconName <- paste("::stockicon::",m[i,1], sep="") ## out <- try(tcl("image","create","photo", ## iconName, ## file=m[i,2]), silent=TRUE) ## if(!inherits(out, "try-error")) ## assign(m[i,1], m[i,2], envir=tcltkStockIcons) ## # tcltkStockIcons[[m[i,1]]] <- m[i,2] ## } ## } ## ## assignInNamespace("tcltkStockIcons", tcltkStockIcons, ns="gWidgetstcltk") ## } ##getStockIconName = function(name) allIcons[[name,exact=TRUE]] getStockIconName <- function(name) tcltkStockIcons$find_icon_name(name) ## stockIconFromClass = function(theClass=NULL) { ## default = "symbol_star" ## if(is.null(theClass) || ## is.na(theClass) || ## length(theClass) == 0 ## ) ## return(NA) ## if(theClass %in% .models) ## return(getStockIconName("lines")) ## if(theClass %in% .ts) ## return(getStockIconName("ts")) ## if(theClass %in% .functions) ## return(getStockIconName("function")) ## ret = switch(theClass, ## "numeric"= "numeric", ## "integer"= "numeric", ## "logical" = "logical", ## "character"="character", ## "matrix" = "matrix", ## "data.frame" = "dataframe", ## "list" = "dataframe", ## "complex"="numeric", ## "factor"="factor", ## "recordedplot" = "plot", ## NA) ## return(getStockIconName(ret)) ## } ## stockIconFromObject = function(obj) ## stockIconFromClass(class(obj)[1]) ##' get with default value getWithDefault <- function(x, default) { if(is.null(x) || (is.atomic(x) && length(x) ==1 && is.na(x))) default else x } gWidgetstcltk/R/dnd.R0000644000176000001440000001137212024721036014213 0ustar ripleyusers## idea from http://wiki.tcl.tk/416 ## globals within NAMESPACE .dragging <- FALSE; .dragValue = ""; .lastWidgetID <- "" dnd.env <- new.env() dnd.env[['dragging']] <- NULL dnd.env[['dragValue']] <- "" dnd.env[['lastWidgetID']] <- "" ################################################## ## ## function used by tcltkObject and gWidgettcltk addDropSource = function(obj, toolkit, targetType="text", handler=NULL, action=NULL, ...) { widget = getWidget(obj) tkbind(widget,"",function(w,...) { dnd.env[['dragging']] <- TRUE dnd.env[['lastWidgetID']] <- widget h = list(); h$obj = obj; h$action=action if(is.null(handler)) handler = function(h,...) svalue(obj) # default handler dnd.env[['dragValue']] <- handler(h) }) tkbind(widget,"",function(x,y,...) { .dragging <- dnd.env[['dragging']] .lastWidgetID <- dnd.env[['lastWidgetID']] if(is.null(.dragging) || !.dragging) return() x0 = as.integer(tkwinfo("rootx",widget)) y0 = as.integer(tkwinfo("rooty",widget)) w = tkwinfo("containing",x0+as.integer(x),y0+as.integer(y)) if(as.logical(tkwinfo("exists",w)) && length(as.character(w)) > 0 && length(as.character(.lastWidgetID)) > 0 ) { if(as.character(w)[1] != as.character(.lastWidgetID)[1]) { tkevent.generate(.lastWidgetID,"<>") } } dnd.env[['lastWidgetID']] <- "" if(as.logical(tkwinfo("exists",w))) tkevent.generate(w, "<>") ## cursor list at ##http://developer.apple.com/documentation/Darwin/Reference/ManPages/mann/cursors.ntcl.html#//apple_ref/doc/man/n/cursors tkconfigure(widget,cursor="target") }) tkbind(widget,"",function(x,y,...) { .dragging <- dnd.env[['dragging']] if(is.null(.dragging) || !.dragging) return() x0 = as.integer(tkwinfo("rootx",widget)) y0 = as.integer(tkwinfo("rooty",widget)) w = tkwinfo("containing",x0+as.integer(x), y0+as.integer(y)) if(as.logical(tkwinfo("exists", w))) { tkevent.generate(w,"<>") tkevent.generate(w,"<>") tkconfigure(w,cursor="") } dnd.env[['dragging']] <- FALSE tkconfigure(widget,cursor="") }) } setMethod(".adddropsource", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, targetType="text", handler=NULL, action=NULL, ...) { addDropSource(obj, toolkit, targetType, handler, action, ...) }) setMethod(".adddropsource", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, targetType="text", handler=NULL, action=NULL, ...) { addDropSource(obj, toolkit, targetType, handler, action, ...) }) ## motino setMethod(".adddropmotion", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler=NULL, action=NULL, ...) { .addHandler(obj,toolkit,signal="<>",handler,action,...) }) setMethod(".adddropmotion", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, handler=NULL, action=NULL, ...) { .addHandler(obj,toolkit, signal="<>",handler, action, ...) }) ################################################## ## target -- how to add for tcltkObjects? addDropTarget = function(obj, toolkit, targetType="text", handler=NULL, action=NULL, overrideobj = NULL,...) { widget = getWidget(obj) if(is.null(handler)) handler = function(h,...) svalue(obj) <- h$dropdata ## bind to three events tkbind(widget,"<>",function(w,...) { .dragging <- dnd.env[['dragging']] if(!is.null(.dragging) && .dragging) { } tkbind(widget,"<>",function(w,...) { .dragging <- dnd.env[['dragging']] if(!is.null(.dragging) && .dragging) { tkconfigure(widget, cursor="") } }) tkbind(widget,"<>",function(w,...) { h = list() h$obj = obj; h$action=action h$dropdata <- dnd.env[['dragValue']] dnd.env[['dragValue']] <- "" handler(h) }) }) } setMethod(".adddroptarget", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, targetType="text", handler=NULL, action=NULL, ...) { addDropTarget(obj, toolkit, targetType, handler, action, ...) }) setMethod(".adddroptarget", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, targetType="text", handler=NULL, action=NULL, ...) { addDropTarget(obj, toolkit, targetType, handler, action, ...) }) gWidgetstcltk/R/gradio.R0000644000176000001440000001516111611714373014722 0ustar ripleyuserssetClass("gRadiotcltk", representation = representation("gComponentR5tcltk", coercewith="NULLorFunction"), contains="gComponentR5tcltk", prototype=prototype(new("gComponentR5tcltk")) ) ## constructor setMethod(".gradio", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, items, selected=1, horizontal=FALSE, handler=NULL, action=NULL, container=NULL, ... ) { force(toolkit) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning(gettext("Container is not correct. No NULL containers possible\n" )) return() } tt = getWidget(container) ## use coerce with theArgs = list(...) if(!is.null(theArgs$coerce.with)) { coerce.with = theArgs$coerce.with } else { if(is.numeric(items)) coerce.with = as.numeric else if(is.logical(items)) coerce.with = as.logical else coerce.with = as.character } if(is.character(coerce.with)) coerce.with = get(coerce.with) items <- as.character(items) rb_widget <- getRefClass("RadioButton")$new(parent=tt, items=items, horizontal=horizontal) obj = new("gRadiotcltk",block=rb_widget$get_widget(), widget=rb_widget$get_widget(), R5widget=rb_widget, toolkit=toolkit, ID=getNewID(), e = new.env(), coercewith = coerce.with) svalue(obj, index=TRUE) <- selected ## add to container add(container, obj,...) ## add handler if(!is.null(handler)) addhandlerchanged(obj, handler, action) invisible(obj) }) ## methods ## setMethod(".svalue", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gRadiotcltk"), ## function(obj, toolkit, index=NULL, drop=NULL, ...) { ## rb_widget <- obj@R5widget ## index <- getWithDefault(index, FALSE) ## if(index) { ## return(rb_widget$get_index()) ## } else { ## val <- rb_widget$get_value() ## if(!is.null(obj@coercewith)) ## return(obj@coercewith(val)) ## else ## return(val) ## } ## }) ## svalue<- setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gRadiotcltk"), function(obj, toolkit, index=NULL, ..., value) { if(is.data.frame(value)) value <- value[,1, drop=TRUE] rb_widget <- obj@R5widget index <- getWithDefault(index, FALSE) if(index) { rb_widget$set_index(value) } else { rb_widget$set_value(value) } return(obj) return(obj) }) ## setMethod(".leftBracket", ## signature(toolkit="guiWidgetsToolkittcltk",x="gRadiotcltk"), ## function(x, toolkit, i, j, ..., drop=TRUE) { ## ## return(items) ## rb_widget <- x@R5widget ## items <- rb_widget$get_items() ## if(missing(i)) ## items ## else ## items[i] ## }) ## setMethod("[", ## signature(x="gRadiotcltk"), ## function(x, i, j, ..., drop=TRUE) { ## .leftBracket(x, x@toolkit, i, j, ..., drop=drop) ## }) ## ## This sets the labels for the buttons ## ## add in markup here. ## setReplaceMethod(".leftBracket", ## signature(toolkit="guiWidgetsToolkittcltk",x="gRadiotcltk"), ## function(x, toolkit, i, j, ..., value) { ## rb_widget <- x@R5widget ## if(!missing(i)) { ## items <- rb_widget$get_items() ## items[i] <- value ## value <- items ## } ## rb_widget$set_items(value) ## return(x) ## }) ## setReplaceMethod("[", ## signature(x="gRadiotcltk"), ## function(x, i, j,..., value) { ## .leftBracket(x, x@toolkit, i, j, ...) <- value ## return(x) ## }) ## setMethod(".length", ## signature(toolkit="guiWidgetsToolkittcltk",x="gRadiotcltk"), ## function(x,toolkit) { ## rb_widget <- x@R5widget ## rb_widget$no_items() ## ##length(tag(x,"items")) ## }) ## ## inherited enabled isn't workgin ## setReplaceMethod(".enabled", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gRadiotcltk"), ## function(obj, toolkit, ..., value) { ## rb_widget <- obj@R5widget ## rb_widget$set_enabled(value) ## return(obj) ## }) ################################################## ## handlers ##' only one handler per widget ##' ##' This could be changed, but only if asked ... ##' This does not get called by svalue -- it should? setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gRadiotcltk"), function(obj, toolkit, handler, action=NULL, ...) { rb_widget <- obj@R5widget user.data=list(obj=obj, handler=handler, action=action) ## id <- rb_widget$add_handler("", id <- rb_widget$add_handler("command", handler=function(user.data) { h <- user.data[c("obj", "action")] user.data$handler(h) }, user.data=user.data) invisible(id) }) ## click and changed the same setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gRadiotcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerchanged(obj,toolkit,handler,action,...) }) gWidgetstcltk/R/gcheckbox.R0000644000176000001440000001243311604711402015401 0ustar ripleyuserssetClass("gCheckboxtcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## constructor setMethod(".gcheckbox", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text, checked=FALSE, use.togglebutton=FALSE, handler=NULL, action=NULL, container=NULL,...) { force(toolkit) if(missing(text)) text = "" if(is(container,"logical") && container) container <- gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } theArgs <- list(...) tt <- getWidget(container) # gp = ttkframe(tt) ## widget use toolbutton or not? ## http://wiki.tcl.tk/17899 if(use.togglebutton) { check <- ttkcheckbutton(tt, text=as.character(text), style="Toolbutton") } else { check <- ttkcheckbutton(tt, text=as.character(text)) } # theLabel = ttklabel(gp, text=text) ## configure tclVar <- tclVar(as.numeric(checked)) tkconfigure(check,variable=tclVar) obj <- new("gCheckboxtcltk",block=check, widget=check, toolkit=toolkit, ID=getNewID(), e = new.env()) tag(obj,"tclVar") <- tclVar ## add to container add(container, obj,...) if (!is.null(handler)) obj@e$handlerID <- addhandlerchanged(obj, handler, action=action) invisible(obj) }) ### methods setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxtcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { cbVal <- as.logical(as.numeric(tclvalue(tag(obj,"tclVar")))) return(cbVal) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxtcltk"), function(obj, toolkit, index=NULL, ..., value) { tclvalue(tag(obj,"tclVar")) <- as.character(as.numeric(value)) return(obj) }) ## [ setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gCheckboxtcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { ## theLabel <- tag(x,"labelText") widget <- getWidget(x) val <- tclvalue(tkcget(widget, "-text")) return(val) }) setMethod("[", signature(x="gCheckboxtcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gCheckboxtcltk"), function(x, toolkit, i, j, ..., value) { widget <- getWidget(x) tkconfigure(widget, text=paste(value, collapse="\n")) return(x) }) setReplaceMethod("[", signature(x="gCheckboxtcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) ## inherited enabled isn't workgin setReplaceMethod(".enabled", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxtcltk"), function(obj, toolkit, ..., value) { ## Odd this isn't needed anymore widget <- getWidget(obj) if(as.logical(value)) tcl(widget,"state","!disabled") else tcl(widget,"state","disabled") return(obj) ## ## change both widget and label ## lapply(list(tag(obj,"check"), tag(obj,"label")), function(i) { ## if(as.logical(value)) ## tcl(i,"state","!disabled") ## else ## tcl(i,"state","disabled") ## }) ## return(obj) }) ### no method to change the value of text??? ### handlers setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxtcltk"), function(obj, toolkit, handler, action=NULL, ...) { changeHandler <- handler theArgs <- list(...); actualobj <- theArgs$actualobj if(is.null(actualobj)) actualobj <- obj ## bind to command, not ButtonRelease-1. That binding requires a pause addhandler(obj,toolkit, signal="command", action=action, actualobj=actualobj, handler = function(h,...) { changeHandler(h,...) }) }) setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxtcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerchanged(obj, toolkit, handler, action) }) gWidgetstcltk/R/gdf.R0000644000176000001440000005304612035022054014206 0ustar ripleyusers################################################## ### Gdf ## now we use the tablelist code ## gGrid cover gDf and gTable setClass("gGridtcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setClass("gDftcltk", contains="gGridtcltk", prototype=prototype(new("gComponenttcltk")) ) ## constructor for editing a data frame setMethod(".gdf", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, items = NULL, name = deparse(substitute(items)), do.subset = FALSE, container=NULL,...) { force(toolkit) tt <- getWidget(container) block <- ttkframe(tt) ## xscr <- ttkscrollbar(block, orient="horizontal", command=function(...) tkxview(widget,...)) yscr <- ttkscrollbar(block, orient="vertical", command=function(...) tkyview(widget,...)) widget <- tkwidget(block, "tablelist::tablelist", resizablecolumns=1, xscrollcommand=function(...) tkset(xscr,...), yscrollcommand=function(...) tkset(yscr,...)) tcl(widget, "configure", selecttype="cell") tkgrid(widget, row=0, column=0, sticky="news") tkgrid(yscr, row=0, column=1, sticky="ns") tkgrid(xscr, row=1, column=0, sticky="ew") tkgrid.columnconfigure(block, 0, weight=1) tkgrid.rowconfigure(block, 0, weight=1) ## tcl("autoscroll::autoscroll", xscr) ## tcl("autoscroll::autoscroll", yscr) ## new object obj <- new("gDftcltk",block=block, widget=widget, toolkit=toolkit, ID=getNewID(), e = new.env()) items <- as.data.frame(items) tl_configure_columns(widget, names(items)) obj[] <- items tag(obj, "head") <- head(items, n=1) ## add to container if (!is.null(container)) { if(is.logical(container) && container == TRUE) container = gwindow(visible=TRUE) add(container, obj, ...) } return(obj) }) ## #################################################### ## gWidget methods setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gGridtcltk"), function(obj, toolkit, ..., value) { width = as.integer(value[1]) height = as.integer(value[2]) ## size tkconfigure(getWidget(obj), maxwidth=width, maxheight=height) return(obj) }) ## data frame methods ## get selected value setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gGridtcltk"), function(obj, toolkit, index=NULL, drop=NULL,...) { message("svalue not implemented") }) ## set by index value selected value setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gGridtcltk"), function(obj, toolkit, index=NULL, ..., value) { message("svalue<- not implemented") }) ## refers to the entire data frame ## index returned by svalue(index=T) works here setMethod("[", signature(x="gGridtcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j,..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gGridtcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { widget <- x@widget opar <- options("warn"); on.exit(options(opar)) options(list(warn=-1)) # quiet for coerce_raw d <- dim(x) head <- tag(x, "head") l <- lapply(seq_len(d[2]), function(j) { coerce_raw(head[[j]], tl_get_column_raw(widget, j)) }) m <- structure(l, .Names=tl_get_column_names(widget), row.names=seq_len(d[1]), class="data.frame") m[i,j, ...] }) ## [<- setReplaceMethod("[", signature(x="gGridtcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j,...) <- value return(x) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gGridtcltk"), function(x, toolkit, i, j, ..., value) { widget <- x@widget if(!missing(i) || !missing(j)) { tmp <- x[] tmp[i,j] <- value value <- tmp } tl_load_data(widget, value) return(x) }) ## data frame like setMethod(".dim", signature(toolkit="guiWidgetsToolkittcltk",x="gGridtcltk"), function(x,toolkit) { widget <- x@widget c(tl_no_rows(widget), tl_no_cols(widget)) }) setMethod(".length", signature(toolkit="guiWidgetsToolkittcltk",x="gGridtcltk"), function(x,toolkit) return(dim(x)[2])) ## no dimnames for gGrid, only names setMethod(".dimnames", signature(toolkit="guiWidgetsToolkittcltk",x="gGridtcltk"), function(x,toolkit) { tktable <- getWidget(x) toVector <- function(i) sapply(i, function(j) paste(j, collapse=" ")) d <- dim(x) dimnames <- list(rownames=NULL, colnames=names(x)) dimnames }) setReplaceMethod(".dimnames", signature(toolkit="guiWidgetsToolkittcltk",x="gGridtcltk"), function(x, toolkit, value) { if(!is.list(value)) stop("value is a list with first element the row names, and second the column names") rnames = make.row.names(value[[1]]) cnames = value[[2]] d = dim(x) if(is.null(rnames) || length(rnames) != d[1]) stop("Row names are the wrong size") if(is.null(cnames) || length(cnames) != (d[2])) stop("Column names are the wrong size") ## set column names names(x) <- cnames ## set row names ## ignore return(x) }) setMethod(".names", signature(toolkit="guiWidgetsToolkittcltk",x="gGridtcltk"), function(x, toolkit) { widget <- x@widget tl_get_column_names(widget) }) setReplaceMethod(".names", signature(toolkit="guiWidgetsToolkittcltk",x="gGridtcltk"), function(x, toolkit, value) { tl_set_column_names(x@widget,value) return(x) }) ## ################################################## ## .gDfaddPopupMenu <- function(obj) { ## ## global variables to record row, column of menu popup ## x0 <- NA; y0 <- NA ## tktable <- getWidget(obj) ## menu <- tkmenu(tktable) ## insert <- function(x,ind, y) { ## if(ind == 0) { ## c(y,x) ## } else if(ind >= length(x)) { ## c(x,y) ## } else { ## c(x[1:(ind-1)], y, x[ind:length(x)]) ## } ## } ## ## return row, column of popup area ## getWhere <- function() { ## where <- paste("@",x0,",",y0, sep="") ## ind <- tcl(tktable,"index",where) ## ind <- as.numeric(unlist(strsplit(as.character(ind),","))) ## ind ## } ## ## GUI to write expression to evaluate to fill in column ## transformVariable <- function(col) { ## ## obj is main object ## w <- gwindow(gettext("Transform variable"), parent=obj,width=300, height=400) ## g <- ggroup(horizontal=FALSE, container = w) ## glabel("To transform a variable you define a function body.", container = g) ## glabel("You can use 'x' for the data frame and the column names.", container = g) ## glabel("", container = g) ## glabel("function(x) {", container=g) ## glabel("\twith(x, {", container = g) ## out <- gtext("", container = g); size(out) <- c(300,100) ## glabel("\t})", container = g) ## glabel("}", container = g) ## ## gseparator(container =g, expand=TRUE) ## bg <- ggroup(container = g) ## cancelButton <- gbutton("cancel", container = bg, handler = function(h,...) dispose(w)) ## okButton <- gbutton("ok", container = bg, handler = function(h,...) { ## str <- paste("x <- obj[,]", ## "f <- function(x) { with(x,{", ## svalue(out), ## "})}", ## "f(x)", ## sep="\n", collapse="\n") ## val <- try(eval(parse(text=str))) ## if(!inherits(val,"try-error")) { ## obj[,col] <- val ## dispose(w) ## } else { ## galert(gettext("Error in function body"), parent = w) ## } ## }) ## size(w) <- c(300,200) ## } ## columnEmpty <- function(col) { ## val <- obj[,col] ## XXX write me ## return(FALSE) ## } ## rowEmpty <- function(row) { ## val <- obj[,row] ## XXX write me ## return(FALSE) ## } ## ## confirm a delete ## confirmDelete <- function(msg="Really delete? There is non empty data") { ## out <- tkmessageBox(icon="question", ## message=gettext(msg), ## type="yesno", ## parent=tktable) ## ifelse(as.character(out) == "yes",TRUE, FALSE) ## } ## formatColumn <- function(col, type) { ## ## use tktable tag to format column to type. ## } ## ## make the menu ## tkadd(menu,"command",label=gettext("Transform Variable"), command = function() { ## ind <- getWhere() ## transformVariable(ind[2]) ## }) ## tkadd(menu,"separator") ## ## ## tkadd(menu,"command",label=gettext("Insert Variable"), command = function() { ## ind <- getWhere() ## tcl(tktable,"insert", "cols", ind[2]) ## classes <- tag(obj, "classes") ## tag(obj,"classes") <- insert(classes, ind[2]+1, "character") ## val <- ginput("New variable name:", parent=obj) ## if(!is.na(val)) ## names(obj)[ind[2] + 1] <- val ## }) ## tkadd(menu,"command",label=gettext("Delete Variable"), command = function() { ## ind <- getWhere() ## if(columnEmpty(ind[2]) || confirmDelete()) ## tcl(tktable,"delete","cols",ind[2]) ## tag(obj, "classes") <- tag(obj, "classes")[-ind[2]] ## }) ## tkadd(menu,"command",label=gettext("Rename Variable"), command = function() { ## ind <- getWhere() ## j <- ind[2] ## oldName <- names(obj)[j] ## val <- ginput("New variable name:", oldName, icon="question", parent=obj) ## if(!is.na(val)) ## names(obj)[j] <- val ## }) ## tkadd(menu,"command",label=gettext("Insert Case"), command = function() { ## ind <- getWhere() ## tcl(tktable,"insert","rows",ind[1]) ## val <- ginput("New case name:", parent=obj) ## if(is.na(val)) ## val <- "NA" # fill in ## rownames(obj)[ind[1] + 1] <- val ## }) ## tkadd(menu,"command",label=gettext("Delete Case"), command = function() { ## ind <- getWhere() ## if(rowEmpty(ind[1]) || confirmDelete()) ## tcl(tktable,"delete","rows",ind[1]) ## }) ## tkadd(menu,"command",label=gettext("Rename case"), command = function() { ## ind <- getWhere() ## i <- ind[1] ## oldName <- rownames(obj)[i] ## val <- ginput("New case name:", oldName, icon="question", parent=obj) ## if(!is.na(val)) ## rownames(obj)[i] <- val ## }) ## tkadd(menu,"separator") ## setClass <- function(type) { ## ind <- getWhere() ## tclvalue(typeVar) <- type ## classes <- tag(obj,"classes") ## classes[ind[2]] <- type ## tag(obj,"classes") <- classes ## formatColumn(col=ind[2], type=type) ## } ## typeVar <- tclVar("numeric") # for selecting type via radiobutton ## tkadd(menu, "radiobutton", label="numeric", variable=typeVar, command=function() setClass("numeric")) ## tkadd(menu, "radiobutton", label="integer", variable=typeVar, command=function() setClass("integer")) ## tkadd(menu, "radiobutton", label="factor", variable=typeVar, command=function() setClass("factor")) ## tkadd(menu, "radiobutton", label="character", variable=typeVar, command=function() setClass("character")) ## tkadd(menu, "radiobutton", label="logical", variable=typeVar, command=function() setClass("logical")) ## tkadd(menu, "radiobutton", label="other", variable=typeVar, command=function() { ## ## need to popup dialog to get function name for other. ## galert("other is not written", parent=obj) ## setClass("character") ## }) ## popupCommand <- function(x,y,X,Y) { ## ## before popping up we have some work to do ## x0 <<- x; y0 <<- y; ## classMenuItems <- 7:12 + 2 ## ind <- getWhere() ## row, column ## ## fix menu basd on where ## tkentryconfigure(menu, 0, state=ifelse(ind[2]==0,"disabled","normal")) ## tkentryconfigure(menu, 2, state=ifelse(ind[2]==0,"disabled","normal")) ## tkentryconfigure(menu, 3, state=ifelse(ind[2]==0,"disabled","normal")) ## tkentryconfigure(menu, 4, state=ifelse(ind[2]==0,"disabled","normal")) ## tkentryconfigure(menu, 5, state=ifelse(ind[1]==0,"disabled","normal")) ## tkentryconfigure(menu, 6, state=ifelse(ind[1]==0,"disabled","normal")) ## tkentryconfigure(menu, 7, state=ifelse(ind[1]==0,"disabled","normal")) ## for(i in classMenuItems) ## tkentryconfigure(menu, i, state=ifelse(ind[2]==0,"disabled","normal")) ## ## adjust class depends on which column ## if(ind[2] == 0) { ## tclvalue(typeVar) <- FALSE ## } else { ## theClass <- tag(obj,"classes")[ind[2]] ## if(theClass %in% c("numeric","integer","character","factor","logical")) ## tclvalue(typeVar) <- theClass ## else ## tclvalue(typeVar) <- "other" ## } ## ## popup ## tkpopup(menu,X,Y) ## } ## ## mac binding, just 3 for all ## if( as.character(tcl("tk","windowingsystem")) == "aqua" ) { ## tkbind(tktable, "<2>", popupCommand) ## tkbind(tktable, "", popupCommand) ## } ## tkbind(tktable, "<3>", popupCommand) ## } ## ## getFromIndex -- not using tcl array variable ## tktable.get <- function(tktable, i, j) { ## val <- tkget(tktable, paste(i,j, sep=",")) ## as.character(val) ## } ## ## set From Index -- not using tcl array variable ## tktable.set <- function(tktable, i, j, value) ## tkset(tktable, paste(i, j, sep=","), as.character(value)) ## ## take a data frame or matrix make a character matrix ## ## basically sapply(mat,format) but also has dimnames ## toCharacterMatrix <- function(x, rNames, cNames) { ## mat <- as.data.frame(x, stringsAsFactors=FALSE) ## mat <- as.data.frame(lapply(mat, format), stringsAsFactors=FALSE) ## if(!missing(rNames)) ## mat <- cbind(rNames,mat) ## mat[,1] <- as.character(mat[,1]) ## if(!missing(cNames)) ## mat <- rbind(c(rep("", !missing(rNames)), cNames), mat) ## return(mat) ## } ## ## fill in a tclArray object from character matrix ## ## modifies ta in place -- passed through environment ## fillTclArrayFromCharMat <- function(ta, cm) { ## ## cm[,1] contains column names, while cm[1,] has rownames ## lapply(2:ncol(cm), function(j) ## ta[[0, j - 1]] <- as.tclObj(cm[1, j], drop = TRUE)) ## for(j in 1:ncol(cm)) ## lapply(2:nrow(cm), function(i) ## ta[[i - 1, j - 1]] <- as.tclObj(cm[i, j], drop = TRUE)) ## } ## ## tclArray -> DataFrame ## tclArrayToDataFrame <- function(ta, tktable, classes) { ## d <- tkindex(tktable, "end") # get size from tktable ## d <- as.numeric(unlist(strsplit(as.character(d), ","))) ## l <- list() ## for (j in 1:d[2]) { ## vals <- sapply(1:d[1], function(i) { ## val <- ta[[i,j]] ## ifelse(is.null(val), NA, tclvalue(val)) ## }) ## l[[j]] <- try(switch(classes[j], ## factor=factor(vals), ## as(vals, classes[j])), ## silent=TRUE) ## if(inherits(l[[j]], "try-error")) l[[j]] <- vals ## character ## } ## ind <- which(classes == "character") ## if(length(ind)) { ## ## convert NA to "" ## for(i in ind) { ## tmp <- l[[i]] ## tmp[is.na(tmp)] <- "" ## l[[i]] <- tmp ## } ## } ## df <- as.data.frame(l) ## ## fix character -- turned to factor above through as.data.frame ## if(length(ind)) { ## df[,ind] <- as.character(df[,ind]) ## } ## ## dimnames ## getTclValueWithDefault <- function(val, default) { ## if(is.null(val)) ## default ## else ## tclvalue(val) ## } ## colnames(df) <- sapply(1:d[2], function(j) getTclValueWithDefault(ta[[0,j]], sprintf("X%s",j))) ## rownames(df) <- make.row.names(sapply(1:d[1], function(i) getTclValueWithDefault(ta[[i,0]], as.character(i)))) ## return(df) ## } ## helper function here ## unlike make.names this doesn't put "X" prefix make.row.names <- function(x) { dups = duplicated(x) if(any(dups)) x[dups] <- make.unique(x)[dups] return(unlist(x)) } ### ## Code for interfacing with tablelist5.6 which is loaded in ## zzz.R ## Events are: <> <> ## Configure tbl tl_configure_columns <- function(tbl, nms) { .Tcl(sprintf("%s configure -columns {%s}", tbl$ID, paste(sprintf("0 {%s} left", nms), collapse="\n") )) sapply(seq_along(nms), function(j) tl_set_column_editable(tbl, j)) } ## Load Data ## helper to load a row tl_insert_row <- function(tbl, row) { if(length(row) == 1 && grepl(" ", row)) row <- paste("{", row, "}", sep="") tcl(tbl, "insert", "end", unlist(lapply(row, as.character))) } tl_clear_data <- function(tbl) { tcl(tbl, "delete", "0", "end") } tl_load_data <- function(tbl, items) { ## need to clear old first! tl_clear_data(tbl) sapply(seq_len(nrow(items)), function(i) tl_insert_row(tbl, items[i,,drop=TRUE])) } ## return tcl cell index tl_get_cellindex <- function(tbl, i, j) { tcl(tbl, "cellindex", sprintf("%s, %s", i-1, j-1)) } ## Get Data ## get cell infor -- raw = text tl_get_cell_raw <- function(tbl, i, j) { raw <- tcl(tbl, "cellcget", tl_get_cellindex(tbl, i, j), "-text") tclvalue(raw) } ## returns text value for column -- must coerce to ... tl_get_column_raw1 <- function(tbl, j) { m <- tl_no_rows(tbl) sapply(seq_len(m), function(i) tl_get_cell_raw(tbl, i, j)) } ##helper parse_tcl <- function(x) { ctr <- 0 y <- strsplit(x, "")[[1]] tmp <- character(0) cur <- "" push_chr <- function(cur, i) { if(cur == "") i else paste(cur, i, sep="") } commit_cur <- function() { if(nchar(cur) > 0) tmp <<- c(tmp, cur) cur <<- "" } for(i in y) { if(i == "{") { if(ctr == 1) { commit_cur() } ctr <- ctr + 1 } else if(i == "}") { if(ctr == 2) { commit_cur() } ctr <- ctr - 1 } else if(i == " ") { if(ctr == 1) { commit_cur() } else { cur <- push_chr(cur, i) } } else { cur <- push_chr(cur, i) } } commit_cur() tmp } tl_get_column_raw <- function(tbl, j) { raw <- tcl(tbl, "getcolumns", j-1, j-1) parse_tcl(tclvalue(raw)) } ## return character matrix tl_get_raw <- function(tbl) { do.call(cbind, lapply(seq_len(tl_no_cols(tbl)), function(j) tl_get_column_raw(tbl, j))) } ## coerce coerce_raw <- function(x, values) UseMethod("coerce_raw") coerce_raw.default <- function(x, values) as.character(values) coerce_raw.integer <- function(x, values) as.integer(values) coerce_raw.numeric <- function(x, values) as.numeric(values) coerce_raw.logical <- function(x, values) as.logical(values) coerce_raw.factor <- function(x, values) factor(values) ## names tl_set_column_name <- function(tbl, j, nm) { tcl(tbl, "columnconfigure", j-1, title=nm) } tl_set_column_names <- function(tbl, nms) { for(j in seq_along(nms)) tl_set_column_name(tbl, j, nms[j]) } tl_get_column_name <- function(tbl, j) { tail(as.character(tcl(tbl, "columnconfigure", j-1, title=NULL)), n=1) } tl_get_column_names <- function(tbl) { sapply(seq_len(tl_no_cols(tbl)), function(j) tl_get_column_name(tbl, j)) } ## remove column tl_remove_column <- function(tbl, j) { tcl(tbl, "deletecolumns", j-1, j-1) } ## sort by column tl_sort_bycolumn <- function(tbl, j, decreasing=FALSE) { dir <- if(decreasing) "decreasing" else "increasing" tcl(tbl, "sortbycolumn", j-1, sprintf("-%s", dir)) } ## size tl_no_rows <- function(tbl) as.numeric(tcl(tbl, "childcount", "root")) tl_no_cols <- function(tbl) as.numeric(tcl(tbl, "columncount")) ## tl_set_focus_on_cell <- function(tbl, i, j) { tcl(tbl, "see", sprintf("%s, %s", i-1, j-1)) } ## show/hide column tl_hide_row <- function(tbl, i, hide=TRUE) { hide <- if(hide) 1 else 0 tcl(tbl, "rowconfigure", i-1, hide=hide) } tl_hide_column <- function(tbl, j, hide=TRUE) { hide <- if(hide) 1 else 0 tcl(tbl, "columnconfigure", j-1, hide=hide) } ## toggle editabbility of column tl_set_column_editable <- function(tbl, j, editable=TRUE) { editable <- if(editable) "yes" else "no" tcl(tbl, "columnconfigure", j-1, editable=editable) } gWidgetstcltk/R/ggraphics.R0000644000176000001440000000563111561042763015426 0ustar ripleyusers## cairo graphics device ## would like to get size from par("fin"), but this isn't so easy as it ## seems to pop up a new plot container ### Trouble when adding to a notebook. Currently when a notebook page is closed the signal to close the widget is not propogated. setClass("gGraphicstcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setMethod(".ggraphics", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, width=dpi*6, height=dpi*6, dpi=75, ps=12, container=NULL,...) { force(toolkit) msg <- paste("There is no embeddable graphics device available for", "gWidgetstcltk. However, the device created by the tkrplot", "package may be embedded into gWidgets by creating a group container", "with ggroup, and using the result of getToolkitWidget(group_container)", "as the parent for tkrplot.", sep="\n") ## take@widget to get glabel instance after going through gWidgets out <- glabel(msg, container=container)@widget return(out) }) ### methods ## ## adding to a group is funny, we intercept here ## setMethod(".add", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gContainertcltk", value="gGraphicstcltk"), ## function(obj, toolkit, value, ...) { ## cat("can't add a ggraphics() object to a container in gWidgetsrjava") ## }) ## raise this device setReplaceMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="gGraphicstcltk"), function(obj, toolkit, ..., value) { if(is.logical(value) == TRUE) { dev.set(tag(obj,"device")) } return(obj) }) ## save Current Page ## This uses GTK -- not R to save. ## need to have window fully shown setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gGraphicstcltk"), function(obj, toolkit, index=NULL, ..., value) { gwCat("svalue not implemented\n") return(obj) }) ### handlers ## add this expose event for graph setMethod(".addhandlerexpose", signature(toolkit="guiWidgetsToolkittcltk",obj="gGraphicstcltk"), function(obj, toolkit, handler, action=NULL, ...) { addhandler(obj,"expose-event",handler,action) }) ## applies a handler to the mouse click. The handler gets extra ## argument h$x, h$y passed into it. These are in [0,1] coordinates setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gGraphicstcltk"), function(obj, toolkit, handler, action=NULL, ...) { }) gWidgetstcltk/R/aaaHandlers.R0000644000176000001440000002477312024720532015662 0ustar ripleyusers## Handler code ## redid 7/2010 ##' run handlers for this signal ##' ##' @param obj is gWidgets object ##' @param signal the signal (handler list keyed by signal) ##' @param h list with proper components from call runHandlers <- function(obj, signal, h, ...) { ## check if enabled W <- getWidget(obj) if(isTtkWidget(W)) enabled <- enabled_ttkwidget(W) else enabled <- enabled_tkwidget(W) if(enabled) { l <- tag(obj, "..handlers") signalList <- l[[signal]] # first run last? lapply(signalList, function(i) { if(!i$blocked) { i$handler(h, ...) } }) } } ##' add a handler to an object ##' ##' The basic idea is that a list of handlers (keyed by the signal) is kept along with a flag ##' indicating whether the handler is blocked or not ##' The binding is done to call the runHandlers function so that this flag can be intercepted ##' For signal="command" we use the command option of the widget, otherwise we bind with tkbind setMethod(".addHandler", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, signal, handler, action=NULL, ...) { ## use tkbind l <- tag(obj, "..handlers") if(is.null(l)) l <- list() signalList <- l[[signal]] if(is.null(signalList)) signalList <- list() ## each component of signalList is a list with ID, blocked, handler, action=action id <- digest(Sys.time()) # some unique key hList <- list(ID=id, blocked=FALSE, handler=handler, action=action) signalList[[length(signalList) + 1]] <- hList # append l[[signal]] <- signalList tag(obj, "..handlers") <- l id <- list(id=id, signal=signal) # need this to block/remove/unblock theArgs = list(...) actualobj <- getWithDefault(theArgs$actualobj, obj) ## theArgs may have an extra with name=key, value FUN <- theArgs$FUN handler <- force(handler) if(is.null(FUN)) { FUN <- function(...) { h = list( obj=actualobj, action=action) runHandlers(obj, signal, h, ...) } } if(signal == "command") tkconfigure(getWidget(obj), command=FUN) else tkbind(getWidget(obj), signal, FUN) ## return id invisible(id) }) ## for tcltk objects setMethod(".addHandler", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, signal, handler, action=NULL, ...) { theArgs = list(...) theobj = ## tcltk object tcltk_obj <- obj obj <- theArgs$actualobj ## copied from above l <- tag(obj, "..handlers") if(is.null(l)) l <- list() signalList <- l[[signal]] if(is.null(signalList)) signalList <- list() ## each component of signalList is a list with ID, blocked, handler, action=action id <- digest(Sys.time()) # some unique key hList <- list(ID=id, blocked=FALSE, handler=handler, action=action) signalList[[length(signalList) + 1]] <- hList # append l[[signal]] <- signalList tag(obj, "..handlers") <- l id <- list(id=id, signal=signal) # need this to block/remove/unblock ## add handler handler <- force(handler) FUN <- theArgs$FUN if(is.null(FUN)) { FUN <- function(...) { ## check if enabled if(isTtkWidget(tcltk_obj)) enabled <- enabled_ttkwidget(tcltk_obj) else enabled <- enabled_tkwidget(tcltk_obj) if(enabled) { h = list(obj=obj, action=action) handler(h,...) } } } if(signal == "command") tkconfigure(tcltk_obj, command=FUN) else tkbind(tcltk_obj, signal, FUN) ## return invisible(id) }) ##' idle handler is different == have this hack to keep calling "after" setMethod(".addhandleridle", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler=NULL, action=NULL, interval=1000, ...) { signal <- "idle" l <- tag(obj, "..handlers") if(is.null(l)) l <- list() signalList <- l[[signal]] if(is.null(signalList)) signalList <- list() ## each component of signalList is a list with ID, blocked, handler, action=action id <- digest(Sys.time()) # some unique key hList <- list(ID=id, blocked=FALSE, handler=handler, action=action) signalList[[length(signalList) + 1]] <- hList # append l[[signal]] <- signalList tag(obj, "..handlers") <- l ## use tcl("apply",time, function) in a while loop here h = list() h$obj=obj h$action=action f <- function() { if(!windowExists(obj)) return() # otherwise, issue when destroyed l <- tag(obj, "..handlers") sigList <- l[['idle']] ind <- sapply(sigList, function(i) i$ID == id) if(any(ind)) { if(!sigList[[which(ind)]]$blocked) sigList[[which(ind)]]$handler(h) tcl("after", interval, f) } } ## start it off f() ## ID id <- list(id=id, signal="idle") }) ##' Function to call to update the "blocked" flag on a handler. runHandlers consults this ##' before making the call .blockUnblock <- function(obj, ID, block=TRUE, ...) { l <- tag(obj, "..handlers") if(is.null(ID)) { ## do all IDS lapply(names(l), function(signal) { sigList <- l[[signal]] if(length(sigList)) { for(i in sigList) .blockUnblock(obj, list(id=i$ID, signal=signal), block, ...) } }) return() } else if(is.null(ID$id) && !is.null(ID[[1]]$obj)) { ## might be a list of IDs (gradio, gcheckboxgroup), we check here lapply(ID, function(i) { .blockUnblock(i$obj, i$id, block) }) return() } else { ## single ID id <- ID$id signal <- ID$signal if(is.null(id) || is.null(signal)) return() if(is.null(l[[signal]])) return() # no signal list ind <- sapply(l[[signal]], function(i) { i$ID == id }) if(!any(ind)) return() for(i in which(ind)) { l[[signal]][[i]]$blocked <- block } } tag(obj, "..handlers") <- l } ##' call to block a handler by ID. If ID=NULL, all handlers are blocked setMethod(".blockhandler", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ID=NULL, ...) { .blockUnblock(obj, ID, block=TRUE) invisible() }) setMethod(".blockhandler", signature(toolkit="guiWidgetsToolkittcltk",obj="gComponentR5tcltk"), function(obj, toolkit, ID=NULL, ...) { #widget <- tag(obj, "widget") widget <- obj@R5widget widget$block_handler(ID) }) ##' call to unblock a handler by ID. If ID=NULL, all handlers are unblocked setMethod(".unblockhandler", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ID=NULL, ...) { .blockUnblock(obj, ID, block=FALSE) invisible() }) setMethod(".unblockhandler", signature(toolkit="guiWidgetsToolkittcltk",obj="gComponentR5tcltk"), function(obj, toolkit, ID=NULL, ...) { # widget <- tag(obj, "widget") widget <- obj@R5widget widget$unblock_handler(ID) }) ##' method to remove a handler setMethod(".removehandler", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ID=NULL, ...) { if(is.null(ID)) { ## remove all handlers. Get id, signal then call this recursively l <- tag(obj, "..handlers") lapply(names(l), function(signal) { sigList <- l[[signal]] if(length(sigList)) { for(i in sigList) .removehandler(obj, toolkit, ID=list(id=i$ID, signal=signal)) } }) } else if(is.null(ID$id) && !is.null(ID[[1]]$obj)) { ## might be a list of IDs (gradio, gcheckboxgroup), we check here lapply(ID, function(i) { removehandler(i$obj, ID=i) }) return() } else { ## single ID ## ID here has two components: id, signal id <- ID$id signal <- ID$signal if(is.null(id) || is.null(signal)) return() l <- tag(obj, "..handlers") if(is.null(l[[signal]])) return() # no signal list ind <- sapply(l[[signal]], function(i) { i$ID == id }) if(!any(ind)) return() # no match on id ## remove list that stores the handler for(i in which(ind)) l[[signal]][[i]] <- NULL ## now save tag(obj, "..handlers") <- l } }) setMethod(".removehandler", signature(toolkit="guiWidgetsToolkittcltk",obj="gComponentR5tcltk"), function(obj, toolkit, ID=NULL, ...) { ##widget <- tag(obj, "widget") widget <- obj@R5widget widget$remove_handler(ID) }) gWidgetstcltk/R/gedit.R0000644000176000001440000001601511672167127014556 0ustar ripleyusers## class defined in aaaClasses for inheritance library(tcltk) ## constructor setClass("gEdittcltk", representation = representation("gComponentR5tcltk", coercewith="NULLorFunction"), contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setMethod(".gedit", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="", width=25, coerce.with = NULL, initial.msg = "", handler=NULL, action=NULL, container=NULL, ... ) { force(toolkit) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } if (is.null(text)) text<-"" ## check that coerce.with is a function if(is.null(coerce.with) || is.function(coerce.with)) { ## okay } else { if(is.character(coerce.with)) { coerce.with = get(coerce.with) } } tt <- getWidget(container) e <- getRefClass("Entry")$new(tt) obj <- new("gEdittcltk", block=e$get_widget(), widget = e$get_widget(), R5widget=e, toolkit=toolkit,ID=getNewID(), e = new.env(), coercewith=coerce.with) if(nchar(text)) { svalue(obj) <- text } ## initial message if(nchar(initial.msg) > 0 && nchar(text) == 0) { e$set_init_msg(initial.msg) e$show_init_msg() } ## width if(!is.null(width)) tkconfigure(obj@widget,width=as.integer(width)) ## character count, not pixels ## Drag and drop ## addDropSource(obj) ## addDropTarget(obj) add(container, obj,...) if (!is.null(handler)) tag(obj, "handler.id") <- addhandlerchanged(obj,handler,action) invisible(obj) }) ## methods setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gEdittcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { widget <- obj@R5widget val <- widget$get_value() ## val = tclvalue(tag(obj,"tclVar")) if(val == "") val <- NA coercewith <- obj@coercewith if(is.null(coercewith)) return(val) if(is.character(coercewith)) coercewith <- get(coercewith) if(!is.function(coercewith)) return(val) return(coercewith(val)) }) ## svalue<- setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gEdittcltk"), function(obj, toolkit, index=NULL, ..., value) { if(is.na(value)) value <- "" widget <- obj@R5widget widget$set_value(value) ## tclvalue(tag(obj, "tclVar")) <- value return(obj) }) ## left bracket implement completion setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gEdittcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { widget <- x@R5widget vals <- widget$words if(missing(i)) vals else vals[i] }) setMethod("[", signature(x="gEdittcltk"), function(x, i, j, ..., drop=TRUE) { if(missing(i)) .leftBracket(x,x@toolkit, ...) else .leftBracket(x,x@toolkit, i, ...) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gEdittcltk"), function(x, toolkit, i, j, ..., value) { widget <- x@R5widget vals <- widget$words # vals <- tag(x, "typeAhead") if(missing(i)) vals <- value else vals[i] <- value widget$set_words(vals) ## tag(x, "typeAhead") <- vals return(x) }) setReplaceMethod("[", signature(x="gEdittcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gEdittcltk"), function(obj, toolkit, ..., value) { if(is.numeric(value)) tkconfigure(obj@widget,width=ceiling(value[1]/widthOfChar)) else message(gettext("size needs a numeric vector c(width,...)\n")) return(obj) }) ##' visible<- if FALSE, for password usage setReplaceMethod(".visible",signature(toolkit="guiWidgetsToolkittcltk", obj="gEdittcltk"), function(obj, toolkit, ..., value) { widget <- getWidget(obj) if(as.logical(value)) tkconfigure(widget, show="") else tkconfigure(widget, show="*") return(obj) }) ################################################## ## handlers ## changed is called after a commit (svalue, Return key in widget -- not drop down menu) ## keystroke is called when widget display changes ## Use Virtual Event for KeyRelease, as other one is used by class above ## use "R5classes" handlers here setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gEdittcltk"), function(obj, toolkit, handler, action=NULL, ...) { widget <- obj@R5widget FUN <- function() { h <- list(obj=obj, action=action) handler(h) } widget$add_handler("<>", FUN) ## .addHandler(widget$get_widget(), toolkit, signal="<>", handler, action, actualobj=obj) }) setMethod(".addhandlerkeystroke", signature(toolkit="guiWidgetsToolkittcltk",obj="gEdittcltk"), function(obj, toolkit, handler, action=NULL, ...) { FUN = function(d) { h = list(obj = obj, action = action, key=d) # add in key handler(h) } widget <- obj@R5widget widget$add_handler("<>", FUN) ## .addHandler(widget$get_widget(), toolkit, signal="<>", FUN, action, actualobj=obj) }) ## This just dispatches down to R5 classes. It should be put into a class gWidgetstcltk/R/gcheckboxgrouptable.R0000644000176000001440000003062611612676171017506 0ustar ripleyusers##' Checkboxgroup with table GCheckboxGroupTable <- setRefClass("GCheckboxGroupTable", contains=c("TcltkWidget"), fields=list( df="ANY", checked="logical", tr="ANY", frame="ANY" ), methods= list( init_widget=function(parent, items, checked=rep(TRUE, nrow(df)), ...) { if(is.data.frame(items)) { df <<- items } else { df <<- as.data.frame(items, stringsAsFactors=FALSE) } checked <<- rep(checked, length.out=nrow(df)) m <- df for(i in seq_len(ncol(m))) m[,i] <- as.character(m[,i]) a <- populate_rectangular_treeview(parent, m) frame <<- a$frame widget <<- tr <<- a$tr tkconfigure(tr, selectmode="none") tkconfigure(tr, show="tree headings") tcl(tr, "column", "#0", minwidth=40, width=40, anchor="center") ## add in checked off show_checked() ## put in handler to toggle tkbind(tr, "", function(W, x, y) { if(!.self$is_enabled()) return() row <- as.character(tkidentify(W, "row", x, y)) children <- as.character(tcl(W, "children", "")) i <- match(row, children) .self$toggle_checked(i) }) .self }, do_icon = function(i) { icon <- ifelse(.self$checked[i], "::image::on", "::image::off") ind <- as.character(tcl(tr, "children", ""))[i] tcl(tr, "item", ind, image=icon) }, show_checked=function() { children <- as.character(tcl(tr, "children", "")) for(i in seq_len(no_items())) { icon <- ifelse(checked[i], "::image::on", "::image::off") tcl(tr, "item", children[i], image=icon) } }, toggle_checked = function(i) { checked[i] <<- !checked[i] do_icon(i) }, get_value = function(index=FALSE) { if(index) return(which(checked)) else return(get_items()[checked]) }, set_value = function(val, index=FALSE) { ## index, logical or by name if(is.logical(val)) { checked <<- rep(val, length=no_items()) show_checked() return() } if(is.logical(index) && !index) { val <- match(val, get_items()) if(length(val) == 1 && is.na(val)) val <- integer(0) } tmp <- rep(FALSE, length=no_items()) tmp[val] <- TRUE checked <<- tmp show_checked() }, get_items = function(drop=TRUE) { if(drop) df[,1,drop=TRUE] else df }, set_items = function(new_items) { ## clear tree, add in items ## nms in case not a data frame if(!is.data.frame(new_items)) { new_items <- data.frame(new_items, stringsAsFactors=FALSE) } if(ncol(new_items) != ncol(df)) stop("Wrong number of columns") df <<- new_items checked <<- rep(checked, length=nrow(df)) m <- df for(i in 1:ncol(m)) m[,i] <- as.character(m[,i]) ## clear old all_ind <- as.character(tcl(tr, "children", "")) sapply(all_ind, function(i) tcl(tr, "detach", i)) ## add values apply(m, 1, function(vals) { if(length(vals) == 1) vals <- paste("{", vals, "}", sep="") tcl(tr, "insert", "", "end", values=vals) }) show_checked() }, no_items = function() length(get_items()) )) ##' Helpers ## Now I need the gWIdgets interface ## build widget based on table setClass("gCheckboxgroupTabletcltk", contains="gComponentR5tcltk", prototype=prototype(new("gComponentR5tcltk")) ) ##' Constructor. ##' ##' Need not be a method, as only called internally ##' Standard parameters, but we don't need horizontal argument. (We do need toolkit.) .gcheckboxgrouptable <- function(toolkit, items, checked = FALSE, horizontal=FALSE, use.table=TRUE, handler = NULL, action = NULL, container = NULL, ...) { tt = getWidget(container) cbg_widget <- getRefClass("GCheckboxGroupTable")$new(parent=tt, items=items, checked=checked) obj <- new("gCheckboxgroupTabletcltk", block=cbg_widget$frame, widget=cbg_widget$get_widget(), R5widget=cbg_widget, toolkit=toolkit, e = new.env()) svalue(obj) <- checked ## add to container add(container, obj,...) ## add handler if(!is.null(handler)) tag(obj, "handler.id") <- addhandlerchanged(obj, handler, action) invisible(obj) } ## ### methods ## setMethod(".svalue", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgroupTabletcltk"), ## function(obj, toolkit, index=NULL, drop=NULL, ...) { ## cbg_widget <- obj@R5widget ## index <- getWithDefault(index, FALSE) ## if(index) { ## return(cbg_widget$get_value(index=TRUE)) ## } else { ## val <- cbg_widget$get_value() ## return(val) ## } ## }) ## ## toggles state to be T or F ## setReplaceMethod(".svalue", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgroupTabletcltk"), ## function(obj, toolkit, index=NULL, ..., value) { ## cbg_widget <- obj@R5widget ## index <- getWithDefault(index, FALSE) ## cbg_widget$set_value(value, index=index) ## return(obj) ## }) ## ## [ and [<- refer to the names -- not the TF values ## setMethod("[", ## signature(x="gCheckboxgroupTabletcltk"), ## function(x, i, j, ..., drop=TRUE) { ## .leftBracket(x, x@toolkit, i, j, ..., drop=drop) ## }) ## setMethod(".leftBracket", ## signature(toolkit="guiWidgetsToolkittcltk",x="gCheckboxgroupTabletcltk"), ## function(x, toolkit, i, j, ..., drop=TRUE) { ## cbg_widget <- x@R5widget ## items <- cbg_widget$get_items() ## if(missing(i)) ## items ## else ## items[i] ## }) ## ## assigns names ## setReplaceMethod("[", ## signature(x="gCheckboxgroupTabletcltk"), ## function(x, i, j,..., value) { ## .leftBracket(x, x@toolkit, i, j, ...) <- value ## return(x) ## }) ## setReplaceMethod(".leftBracket", ## signature(toolkit="guiWidgetsToolkittcltk",x="gCheckboxgroupTabletcltk"), ## function(x, toolkit, i, j, ..., value) { ## cbg_widget <- x@R5widget ## if(!missing(i)) { ## items <- cbg_widget$get_items() ## items[i] <- value ## value <- items ## } ## cbg_widget$set_items(value) ## return(x) ## }) ## setMethod(".length", ## signature(toolkit="guiWidgetsToolkittcltk",x="gCheckboxgroupTabletcltk"), ## function(x,toolkit) { ## cbg_widget <- x@R5widget ## cbg_widget$no_items() ## }) ## ## inherited enabled isn't workgin ## setReplaceMethod(".enabled", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgroupTabletcltk"), ## function(obj, toolkit, ..., value) { ## cbg_widget <- obj@R5widget ## cbg_widget$set_enabled(value) ## return(obj) ## }) ## This handler code is common to gradio and gcheckboxgroup. Should abstract out into a superclass. ## IF we do that, we should also use CheckButton bit setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgroupTabletcltk"), function(obj, toolkit, handler, action=NULL, ...) { cbg_widget <- obj@R5widget user.data=list(obj=obj, handler=handler, action=action) id <- cbg_widget$add_handler("", handler=function(user.data) { h <- user.data[c("obj", "action")] user.data$handler(h) }, user.data=user.data) invisible(id) }) ## clicked is changed setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgroupTabletcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerclicked(obj, toolkit, handler, action, ...) }) gWidgetstcltk/R/ggraphicsnotebook.R0000644000176000001440000000134511646163577017200 0ustar ripleyusers## creates a notebook interface tohandle plots setClass("gGraphicsNotebooktcltk", representation=representation( width="numeric",height="numeric" ), contains="gNotebooktcltk", prototype=prototype(new("gNotebooktcltk")) ) setMethod(".ggraphicsnotebook", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, width=dpi*6, height=dpi*6,dpi=75, container = NULL, ...) { ## ... passed onto gnotebook force(toolkit) return(glabel("No ggraphics available in gWidgetstcltk", container=container)@widget) }) gWidgetstcltk/R/glayout.R0000644000176000001440000001271012035021605015124 0ustar ripleyuserssetClass("gLayouttcltk", contains="gContainertcltk", prototype=prototype(new("gContainertcltk")) ) ## an gWidget for tables ## take two -- this time build up tale, then use visible to show ## this way, we don't need to set size initially ## constructor setMethod(".glayout", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, homogeneous = FALSE, spacing = 10, # amount (pixels) between row, cols, NULL=0 container = NULL, ... ) { force(toolkit) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } tt <- getWidget(container) gp <- ttkframe(tt) tkpack(gp, expand=TRUE, fill="both") obj = new("gLayouttcltk", block=gp, widget=gp, toolkit=toolkit, e = new.env()) add(container, obj, ...) ## how to add in per column adjusments? adjust = "center" # left or right or center tag(obj,"homogeneous") <- homogeneous tag(obj,"spacing") <- as.numeric(spacing) tag(obj,"adjust") <- adjust tag(obj,"childlist") <- list() invisible(obj) }) ## for adding setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gLayouttcltk", value="gWidgettcltk"), function(obj, toolkit, value, ...) { ## add parent, children childComponents <- obj@e$childComponents if(is.null(childComponents)) childComponents <- list() obj@e$childComponents <- c(childComponents, value) value@e$parentContainer <- obj ## inherit enabled from parent try(enabled(value) <- enabled(obj),silent=TRUE) theArgs = list(...) ## tkpack(getBlock(value), side="left") }) ## retrieve values setMethod("[", signature(x="gLayouttcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gLayouttcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { l <- tag(x, "childlist") ind <- sapply(l, function(comp) { i[1] %in% comp$x && j[1] %in% comp$y }) if(any(ind)) return(l[ind][[1]]$child) # first else NA }) ## how we populate the table setReplaceMethod("[", signature(x="gLayouttcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gLayouttcltk"), function(x, toolkit, i, j, ..., value) { ## check that all is good if(is.character(value)) { value <- glabel(value, container = x) } spacing <- tag(x,"spacing") ## need means to adjust via sticky sticky = "w" # like others theArgs = list(...) if(!is.null(theArgs$anchor)) { anchor = theArgs$anchor if(anchor[1] == -1) sticky = "w" else if(anchor[1] == 1) sticky = "e" else if(anchor[2] == -1) sticky = "s" } if(!is.null(theArgs$expand) && theArgs$expand) sticky = "nsew" tkgrid(getBlock(value), row = min(i) - 1, rowspan = 1 + max(i) - min(i), column = min(j) - 1, columnspan = 1 + max(j) - min(j), sticky = sticky, padx=spacing, pady=spacing ) weight <- ifelse(tag(x, "homogeneous"), 1, 0) lapply( (min(i):max(i)), function(row) tkgrid.rowconfigure(getBlock(value), row-1, weight=weight)) lapply( (min(j):max(j)), function(col) tkgrid.columnconfigure(getBlock(value), col-1, weight=weight)) ## add to list so [ method works l <- tag(x, "childlist") l[[as.character(length(l) + 1)]] <- list(x=i, y=j, child=value) tag(x, "childlist") <- l return(x) ## if(obj$adjust == "right") { ## group = ggroup() ## addSpring(group) ## add(group,value) ## } else if(obj$adjust = "left") { ## group = ggroup() ## add(group,value) ## addSpring(group) ## } else { ## group = value ## } }) ## dim setMethod(".dim", signature(toolkit="guiWidgetsToolkittcltk",x="gLayouttcltk"), function(x, toolkit) { w <- getWidget(x) d <- rev(as.numeric(tcl("grid","size", w))) names(d) <- c("nrow", "ncol") d }) gWidgetstcltk/R/gspinbutton.R0000644000176000001440000001604411611714657016037 0ustar ripleyusers## Could make spinbutton slider, subclass as methods are identical ## setClass("gSpinbuttontcltk", ## contains="gComponenttcltk", ## prototype=prototype(new("gComponenttcltk")) ## ) setClass("gSpinbuttontcltk", representation = representation("gComponentR5tcltk"), contains="gComponentR5tcltk", prototype=prototype(new("gComponentR5tcltk")) ) setMethod(".gspinbutton", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, from=0,to=10,by=1,value=from,digits=0, handler=NULL, action=NULL, container=NULL, ...) { force(toolkit) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } tt = getWidget(container) sp_widget <- getRefClass("SpinButton")$new(parent=tt, from=from, to=to, by=by) obj = new("gSpinbuttontcltk",block=sp_widget$get_widget(), widget=sp_widget$get_widget(), R5widget=sp_widget, toolkit=toolkit, ID=getNewID(), e = new.env()) ## add to container add(container, obj,...) ## add handler if(!is.null(handler)) addhandlerchanged(obj, handler, action) invisible(obj) ## ## no spinbutton in the tcltk ## vals = as.character(seq(from,to,by=by)) ## tt = getWidget(container) ## gp = ttkframe(tt) ## sb = tkwidget(gp, "spinbox", from=from, to=to, increment=by) ## tcl(sb,"set",value) ## tkpack(sb, expand=TRUE, fill="both") ## obj = new("gSpinbuttontcltk",block=gp, widget=sb, ## toolkit=toolkit, ID=getNewID(), e = new.env()) ## add(container, obj,...) ## if (!is.null(handler)) { ## id = addhandlerchanged(obj, handler, action) ## } ## invisible(obj) }) ## ### methods ## setMethod(".svalue", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gSpinbuttontcltk"), ## function(obj, toolkit, index=NULL, drop=NULL, ...) { ## sp_widget <- obj@R5widget ## sp_widget$get_value() ## ## sb = getWidget(obj) ## ## val = as.numeric(tcl(sb,"get")) ## ## return(val) ## }) ## setReplaceMethod(".svalue", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gSpinbuttontcltk"), ## function(obj, toolkit, index=NULL, ..., value) { ## sp_widget <- obj@R5widget ## sp_widget$set_value(value) ## ## sb = getWidget(obj) ## ## tcl(sb,"set",value) ## return(obj) ## }) ## enabled -- use tkconfigure, not tcl setReplaceMethod(".enabled", signature(toolkit="guiWidgetsToolkittcltk",obj="gSpinbuttontcltk"), function(obj, toolkit, ..., value) { if(as.logical(value)) # tcl(getWidget(obj),"state","!disabled") tkconfigure(getWidget(obj),state="normal") else # tcl(getWidget(obj),"state","disabled") tkconfigure(getWidget(obj),state="disabled") return(obj) }) ## ## Method to replace values of spin button ## setReplaceMethod("[", ## signature(x="gSpinbuttontcltk"), ## function(x, i, j,..., value) { ## .leftBracket(x, x@toolkit, i, j, ...) <- value ## return(x) ## }) ## setReplaceMethod(".leftBracket", ## signature(toolkit="guiWidgetsToolkittcltk",x="gSpinbuttontcltk"), ## function(x, toolkit, i, j, ..., value) { ## obj <- x ## sp_widget <- obj@R5widget ## sp_widget$set_items(value) ## ## widget <- getWidget(obj) ## ## ## check that value is a regular sequence ## ## if(length(value) <=1) { ## ## warning("Can only assign a vector with equal steps, as produced by seq") ## ## return(obj) ## ## } ## ## if(length(value) > 2 && ## ## !all.equal(diff(diff(value)), rep(0, length(value) - 2))) { ## ## warning("Can only assign a vector with equal steps, as produced by seq") ## ## return(obj) ## ## } ## ## ## get current value, increment ## ## curValue <- svalue(obj) ## ## inc <- head(diff(value), n=1) ## ## tkconfigure(widget, from=min(value), to =max(value), increment=inc) ## ## tcl(widget, "set", curValue) ## ## all done ## return(obj) ## }) ## size has no height setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gSpinbuttontcltk"), function(obj, toolkit, ..., value) { width <- ceiling(value[1]/widthOfChar) tkconfigure(getWidget(obj), width=width) return(obj) }) ### handlers setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gSpinbuttontcltk"), function(obj, toolkit, handler, action=NULL, ...) { sp_widget <- obj@R5widget user.data=list(obj=obj, handler=handler, action=action) ## id <- rb_widget$add_handler("", id <- sp_widget$add_handler("command", handler=function(user.data) { h <- user.data[c("obj", "action")] user.data$handler(h) }, user.data=user.data) invisible(id) ## #.addhandlerclicked(obj, toolkit, handler, action,...) ## changeHandler <- handler ## ## need a pause ## addhandler(obj,toolkit, signal="", ## action=action, ## handler = function(h,...) { ## tcl("after",150,function(...) { ## changeHandler(h,...) ## need to pause ## }) ## }) ## addhandler(obj,toolkit, signal="", ## action=action, ## handler = function(h,...) { ## tcl("after",150,function(...) { ## changeHandler(h,...) ## need to pause ## }) ## }) }) gWidgetstcltk/R/gtext.R0000644000176000001440000002462712275560635014626 0ustar ripleyusers## TODO ## * FONTS ## some common function ## does gtext object have a selection hasSelection = function(obj) tclvalue(tktag.ranges(getWidget(obj),"sel")) != "" ## begin setClass("gTexttcltk", representation(tags="list"), contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setMethod(".gtext", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text=NULL, width=NULL, height=200, font.attr = NULL, wrap = TRUE, handler = NULL, action=NULL, container=NULL, ...) { force(toolkit) theArgs <- list(...) ladd <- function(...,bg) add(...) # don't pass bg to add -- if present if(is(container,"logical") && container) container <- gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } ## options ## wrap if(wrap) wrap <- "word" else wrap <- "none" ## background color bg <- if(!is.null(theArgs$bg)) theArgs$bg else "white" tt <- getWidget(container) gp <- ttkframe(tt) xscr <- ttkscrollbar(gp, orient="horizontal", command=function(...)tkxview(txt,...)) yscr <- ttkscrollbar(gp, command=function(...)tkyview(txt,...)) txt <- tktext(gp, bg=bg, setgrid=FALSE, #font="courier", undo = TRUE, # undo support xscrollcommand=function(...)tkset(xscr,...), yscrollcommand=function(...)tkset(yscr,...), wrap=wrap) ## pack into a grid ## see tkFAQ 10.1 -- makes for automatic resizing tkgrid(txt,row=0,column=0, sticky="news") tkgrid(yscr,row=0,column=1, sticky="ns") tkgrid(xscr, row=1, column=0, sticky="ew") tkgrid.columnconfigure(gp, 0, weight=1) tkgrid.rowconfigure(gp, 0, weight=1) ## from tcltk2 package, this package is installed if(windowingsystem() != "aqua") { tcl("autoscroll::autoscroll", xscr) tcl("autoscroll::autoscroll", yscr) } ## set point tkmark.set(txt,"insert","0.0") obj <- new("gTexttcltk", block=gp, widget=txt, tags=list(), toolkit=toolkit,ID=getNewID(), e = new.env()) ## font.attr sets text properties for entire buffer if(!is.null(font.attr)) { font(obj) <- font.attr } ## add initial text if(!is.null(text)) { add(obj, text) } ## set height if requested if(!is.null(width)) ## width height in terms of characters size(obj) <- c(width,height) ## adddropsource(obj) adddroptarget(obj) ## attach to container add(container, obj,...) ## add handler if (!is.null(handler)) { obj@e$handler.id <- addhandlerkeystroke(obj, handler, action) } return(obj) }) ## drop=TRUE to get only mouse selected text setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gTexttcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { ## rongui request, if INDEX = TRUE return selected text ## by index in the buffer if(!is.null(index) && index == TRUE) { ## get the selected text from gtext, ## return the index instead of text. if(hasSelection(obj)) ## row.column: row 1-based, column 0-based val <- as.character(tktag.ranges(getWidget(obj),"sel")) else val <- c(0,0) return(as.numeric(val)) } ## otherwise we return text ## if drop=FALSE or NULL grab all text ## if drop=TRUE, get selected text only if(is.null(drop) || drop == FALSE) { val <- tclvalue(tkget(getWidget(obj),"0.0","end")) ## strip off last "\n"'s val <- gsub("\n*$","",val) } else { range <- as.numeric(tktag.ranges(getWidget(obj),"sel")) ## range is numeric(0) if none if(length(range) > 0) val <- tclvalue(tkget(getWidget(obj),"sel.first","sel.last")) else val <- "" } ## val = unlist(strsplit(val,"\n")) return(val) }) ## svalue<-() replaces text setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gTexttcltk"), function(obj, toolkit, index=NULL, ..., value) { ## how to clear out old text tkdelete(getWidget(obj),"0.0","end") if(length(value) > 1) value <- paste(value, collapse="\n") tkinsert(getWidget(obj),"end",value) tksee(getWidget(obj),"0.0") return(obj) }) ## clear all text in buffer setMethod("dispose",signature(obj="gTexttcltk"), function(obj,...) { .dispose(obj, obj@toolkit, ...) }) setMethod(".dispose", signature(toolkit="guiWidgetsToolkittcltk",obj="gTexttcltk"), function(obj, toolkit, ...) { svalue(obj) <- "" }) ### insert (was add) method is a workhorse for this class. Value can be ## * a line of text ## * a vector of lines of text ## need to do where value of "at.cursor" ## add text setMethod(".insert", signature(toolkit="guiWidgetsToolkittcltk",obj = "gTexttcltk"), function(obj, toolkit, value, where = c("end","beginning","at.cursor"), font.attr = NULL, do.newline = TRUE, ...) { ## just call add where <- match.arg(where) .add(obj, toolkit, value, where=where, font.attr=font.attr, do.newline=do.newline, ...) }) ## should be .insert, but legacy setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gTexttcltk",value="character"), function(obj, toolkit, value, ...) { theArgs <- list(...) # look for font.attr, do.newline, where do.newline <- ifelse(is.null(theArgs$do.newline), TRUE, as.logical(theArgs$do.newline)) where <- ifelse(is.null(theArgs$where), "end", theArgs$where) where <- switch(where, "at.cursor"="insert", "beginning"="0.0", "end") txt <- getWidget(obj) value <- paste(value,collapse="\n") if(do.newline) value = paste(value,"\n",sep="") ### Handle markup here markup <- theArgs$font.attr if(!is.null(markup)) { ## bit of a hack to set font fname <- paste(as.character(date()),rnorm(1), sep="") ## some random string fontList <- fontlistFromMarkup(markup, fname) do.call("tkfont.create", fontList) tkmark.set(txt, "left","insert"); tkmark.gravity(txt,"left","left") tkmark.set(txt, "right","insert"); tkmark.gravity(txt,"right","right") tkinsert(txt, where, value) tktag.add(txt, fname, "left","right") tktag.configure(txt, fname, font=fname) if("color" %in% names(markup)) tktag.configure(txt, fname, foreground=markup['color']) } else { ## no markup tkinsert(getWidget(obj),where,value) } ## does this place the cursor? TK FAQ 10.6 tksee(getWidget(obj),where) # where = "end" or "0.0" }) ## add a widget setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gTexttcltk",value="guiWidget"), function(obj, toolkit, value, ...) { .add(obj,toolkit, value@widget, ...) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gTexttcltk",value="gWidgettcltk"), function(obj, toolkit, value, ...) { message("gtext: implement adding a widget to text area\n") return() }) ## set the font for the selected area of the gtext object setReplaceMethod(".font", signature(toolkit="guiWidgetsToolkittcltk",obj="gTexttcltk"), function(obj, toolkit, ..., value) { ## if a selection, set font, else set font for buffer widget <- getWidget(obj) if(hasSelection(obj)) { selected <- as.character(tktag.ranges(getWidget(obj),"sel")) fname <- paste(as.character(date()),rnorm(1), sep="") ## some random string ## make font, tag in buffer, configure tag fontList <- fontlistFromMarkup(value) do.call("tkfont.create", merge(list(fname), fontList)) tktag.add(widget, fname, selected[1], selected[2]) tktag.configure(widget, fname, font=fname) if("color" %in% names(value)) tktag.configure(widget, fname, foreground=value['color']) } else { ## clear out old tags -- we are resetting tagNames <- as.character(tktag.names(widget)) sapply(tagNames, function(i) tktag.delete(widget, i)) .font(widget, toolkit, ...) <- value } return(obj) }) setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gTexttcltk"), function(obj,toolkit, handler=NULL, action=NULL,...) { .addhandlerkeystroke(obj,toolkit,handler,action) }) gWidgetstcltk/R/gwindow.R0000644000176000001440000002634211666311572015142 0ustar ripleyusers## constructor setMethod(".gwindow", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, title="Window", visible=TRUE, width = NULL, height = NULL, parent=NULL, handler=NULL, action = NULL, ... ) { force(toolkit) ## don't draw until asked tclServiceMode(FALSE) win <- tktoplevel() tktitle(win) <- title tkwm.state(win,"withdrawn") # was at beginneing ## enable autoresizing tkwm.geometry(win,"") ## how to set location??? location <- parent # renamed if(!is.null(location)) { if(is(location,"guiWidget") || is(location, "gWindowtcltk") || is(location, "tkwin")) { location <- getToolkitWidget(location) curgeo <- tclvalue(tkwm.geometry(location)) ## widthXheight+xpos+ypos pos <- unlist(strsplit(curgeo, "\\+")) sz <- unlist(strsplit(pos[1],"x")) xpos = as.numeric(pos[2]); ypos=as.numeric(pos[3]) tkwm.geometry(win,paste("+",xpos+30,"+",ypos+30,sep="")) # shift tkwm.transient(win, location) # set transient tkbind(location,"",function(...) tkdestroy(win)) } else if(is.numeric(location) && length(location) == 2) { tkwm.geometry(win, location[1], location[2]) } } ## pack a frame inside for theme issues: ## tkdocs.com: ## Strictly speaking, we could just put the other parts of ## our interface directly into the main root window, without ## the intervening content frame. However, the main window ## isn't itself part of the "themed" widgets, so its background color wouldn't ## match the themed widgets we will put inside it. Using a ## "themed" frame widget to hold the content ensures that the ## background is correct. ## pack in frame for adding to contentPane <- ttkframe(win, padding=c(3,3,12,12)) tkgrid(contentPane, row=1, column = 0, sticky="nwes") tkgrid.columnconfigure(win, 0, weight = 1) tkgrid.rowconfigure(win, 1, weight = 1) ## pack in toolbar tb <- ttkframe(win) tkgrid(tb, row=0, column = 0, sticky = "nswe") ## pack in statusbar sb <- ttkframe(win) tkconfigure(sb, borderwidth = 1, relief="sunken") tkgrid(sb, row=2, column = 0, sticky="we") ## debugging code ## just to see the frame ## tkconfigure(contentPane, borderwidth=4, relief="solid") ## tkconfigure(tb, borderwidth=4, relief="solid") ## size the frame object ## set default size? only minsize here if(!is.null(width)) { if(is.null(height)) height = .7*width tkconfigure(contentPane, width=as.integer(width), height=as.integer(height)) tkgrid.propagate(contentPane,FALSE) ## make frame size carry forward } obj <- new("gWindowtcltk",block=win, widget=contentPane, toolkit=toolkit, ID=getNewID(),e=new.env()) obj@e$parentContainer <- NULL tag(obj,"tb") <- tb tag(obj,"sb") <- sb if (!is.null(handler)) { id <- addhandlerdestroy(obj, handler=handler, action=action) } tclServiceMode(TRUE) if(visible) { tkwm.state(win,"normal") } return(obj) }) ################################################## ## Methods ## getToolkitWidget returns window -- not frame ## general add setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk", value="gWidgettcltk"), function(obj, toolkit, value, ...) { ## add parent, children childComponents <- obj@e$childComponents if(is.null(childComponents)) childComponents <- list() obj@e$childComponents <- c(childComponents, value) value@e$parentContainer <- obj ## pack into frame tkpack(getBlock(value), expand=TRUE, fill="both") return(TRUE) ## --- IGNORED -- ## adding widget to window means pack theArgs = list(...) packArgs = list(getBlock(value)) if(!is.null(theArgs$expand) && theArgs$expand) { packArgs$expand=TRUE packArgs$fill = "both" packArgs$side="top" } else { packArgs$side="top" } ## override with anchor argument if(!is.null(theArgs$anchor)) { an = theArgs$anchor if(an[1] == 1) packArgs$side = "right" else if(an[1] == -1) packArgs$side = "left" else if(an[2] == 1) packArgs$side = "top" else packArgs$side = "bottom" } #do.call("tkpack", packArgs) packArgs$side <- NULL # clera out for test do.call("tkgrid", packArgs) }) ## return window -- not frame setMethod(".getToolkitWidget", signature(obj="gWindowtcltk", toolkit="guiWidgetsToolkittcltk"), function(obj, toolkit) obj@block) ## add toolbar, menubar, statusbar ## menubar -- in gmenu ## toolbar setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk", value="gToolbartcltk"), function(obj, toolkit, value, ...) { tkpack(getBlock(value), anchor="w") ## ## put before all others. ## ## get children, check then put in. XXX ## ## XXX -- not working ## g <- getWidget(obj) ## slaves <- unlist(strsplit(tclvalue(tkpack("slaves",g))," ")) ## args <- list(getBlock(value), ## side="top",anchor="w",expand=FALSE, fill="x") ## if(length(slaves)) ## args$before = slaves[1] ## do.call("tkpack",args) ## tag(obj,"toolbar") <- getBlock(value) }) ## statusbar setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk", value="gStatusbartcltk"), function(obj, toolkit, value, ...) { tkpack(getBlock(value), anchor="w") ## ## put after all others ## ## XXX Get children, put last -- NOT WORKING!! ## g = getWidget(obj) ## slaves = unlist(strsplit(tclvalue(tkpack("slaves",g))," ")) ## args <- list(getBlock(value), ## side="top",anchor="w",expand=FALSE, fill="x") ## if(length(slaves)) ## args$after <- slaves[length(slaves)] ## do.call("tkpack",args) ## tag(obj,"statusbar") <- getBlock(value) }) ## methods ## svalue refers to title setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, index=NULL, drop=NULL, ..) { ## return title val <- tcl("wm","title",getBlock(obj)) tclvalue(val) }) setMethod(".svalue<-", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, index=NULL,..., value) { ## set the title tcl("wm","title",getBlock(obj), as.character(value)) return(obj) }) setMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, ...) { widget <- getBlock(obj) width <- tclvalue(tkwinfo("width",widget)) height <- tclvalue(tkwinfo("height",widget)) return(as.numeric(c(width=width, height=height))) }) setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, ...,value) { tkwm.minsize(getBlock(obj), value[1], value[2]) return(obj) }) setMethod(".dispose", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, ...) { tcl("after",5,function() { tkdestroy(getBlock(obj)) }) }) setReplaceMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, ...,value) { if(as.logical(value)) { tkwm.state(obj@block,"normal") } else { tkwm.state(obj@block,"withdrawn") } return(obj) }) ##' update will cause window to resize to natural size ##' ##' @param object gwindow object ##' @param toolkit name of toolkit ##' @param ... ignored ##' @return NULL setMethod(".update", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(object, toolkit, ...) { w <- getBlock(object) tkwm.geometry(w, "") invisible() }) ##' focus will raise window ##' ##' @param object gwindow object ##' @param toolkit name of toolkit ##' @param ... ignored ##' @return NULL called for side effect of raising window setMethod(".focus", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, ...) { w <- getBlock(obj) tkraise(w) }) setReplaceMethod(".focus", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, ..., value) { if(as.logical(value)) { w <- getBlock(obj) tkraise(w) } return(obj) }) ################################################## ## handlers setMethod(".addhandlerunrealize", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, handler, action=NULL, ...) { win <- getBlock(obj) h <- list(obj = obj, action=action,...) tkwm.protocol(win, "WM_DELETE_WINDOW", function(...) { val <- handler(h,...) ## FALSE -- destroy, TRUE -- keep if(is.null(val) || !is.logical(val) || !val) tkdestroy(win) ## revers }) }) ## no ID setMethod(".addhandlerdestroy", signature(toolkit="guiWidgetsToolkittcltk",obj="gWindowtcltk"), function(obj, toolkit, handler, action=NULL, ...) { ## need to tkbind explicitly here f <- function() { h <- list(obj=obj, action=action) handler(h) } tkbind(getWidget(obj), "", f) }) gWidgetstcltk/R/gdialogs.R0000644000176000001440000003466312275447577015276 0ustar ripleyusers## some dialogs for R ## dialogs don't get windows, they make them ## dialogs are modal ## dialogs return their value -- not an object. so source(gfile()) should work ## we don't implement gbasiddialog. -- how to do so not clear? ## TODO: ## used to create all three dialogs tcltkDialog = function( message, text = "", title = "Input", icon = c("info","warning","error","question"), type = c("message","confirm","input"), parent = NULL, handler = NULL, action = NULL, ... ) { ## top level widnow dlg <- tktoplevel() f <- ttkframe(dlg, padding=3) tkpack(f, expand=TRUE, fill="both") if(!is.null(parent)) { parent <- getBlock(parent) ## needs to be top level window parent <- getTopParent(parent) curgeo <- tclvalue(tkwm.geometry(parent)) ## widthXheight+xpos+ypos pos <- unlist(strsplit(curgeo, "\\+")) sz <- unlist(strsplit(pos[1],"x")) xpos = as.numeric(pos[2]); ypos=as.numeric(pos[3]) tkwm.geometry(dlg,paste("+",xpos+10,"+",ypos+10,sep="")) # shift tkwm.transient(dlg, parent) # set transient tkbind(parent,"",function(...) tkdestroy(dlg)) } ## set up dlg window tkwm.deiconify(dlg) # tkgrab.set(dlg) ## was giving errors tkfocus(dlg) tkwm.title(dlg,title) tkwm.resizable(dlg, FALSE, FALSE) dlgframe <- ttkframe(f, padding=3) tkpack(dlgframe, expand=TRUE, fill="both") ## set up icon ## These are stupid icons!!! icon = match.arg(icon) allIcons = getStockIcons() iconFile = switch(icon, "warning"=allIcons$alert, "error" = allIcons$error, "question" = allIcons$help, allIcons$ok ) imageID = paste("gdialogs",as.character(runif(1)),sep="") tcl("image","create","photo",imageID,file=iconFile) icon = ttklabel(dlgframe,image=imageID) tkgrid(icon,row=0,column=0) ## set up label if(missing(message) || is.null(message)) message <- "" l <- ttklabel(dlgframe, text = paste(as.character(message), sep="\n")) tkgrid(l, row=0, column = 1, stick ="nw", padx=25, pady=5) ## entry widget for input if(type == "input") { textEntryVarTcl <- tclVar(text) textEntryWidget <- ttkentry(dlgframe, width=max(25,as.integer(1.3*nchar(text))), textvariable=textEntryVarTcl) tkgrid(textEntryWidget,row = 1, column=1,stick="nw", padx=5,pady=5) } ## what to return? TRUE or FALSE or string for ginput ReturnVal <- FALSE onOK <- function() { if(type == "input") ReturnVal <<- tclvalue(textEntryVarTcl) else ReturnVal <<- TRUE ## call handler if asked if(!is.null(handler)) handler(list(obj=NULL, action=action, input=ReturnVal)) tkgrab.release(dlg) tkdestroy(dlg) } onCancel <- function(){ if(type == "input") ReturnVal <<- NA else ReturnVal <<- FALSE tkgrab.release(dlg) tkdestroy(dlg) } gp <- ttkframe(f) OK.but <-ttkbutton(gp,text=" OK ",command=onOK, state="active") Cancel.but <-ttkbutton(gp,text=" Cancel ",command=onCancel) tkpack(gp, fill="y") if(type == "confirm" || type == "input") tkpack(Cancel.but,side="left") tkpack(OK.but,side="left") if(type == "input") tkfocus(textEntryWidget) # set focus else tkfocus(OK.but) tkbind(dlg, "", function() { tkgrab.release(dlg) }) if(type == "input") tkbind(textEntryWidget, "", onOK) tkwait.window(dlg) invisible(ReturnVal) } setMethod(".gmessage", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, message, title = "message", icon = c("info","warning","error","question"), parent = NULL, handler = NULL, action = NULL, ... ) { icon = match.arg(icon) l <- list(icon=icon, message=gettext(message[1]), title = title, type="ok") if(length(message) > 1) l$detail=gettext(message[2]) if(!is.null(parent)) l$parent <- getWidget(parent) out <- do.call("tkmessageBox",l) if(is.logical(out) && out && !is.null(handler)) { h = list() h$obj=NULL; h$action=action handler(h) } return(out) ## ## old ## return(tcltkDialog( ## message, ## title=title, ## icon=icon, ## type="message", ## parent = parent, ## handler=handler, ## action=action, ## ...)) ## icon = match.arg(icon) ## ret = tkmessageBox( ## message=message, ## title=title, ## icon=icon) ## if(as.character(ret) == "ok") ## TRUE ## else ## FALSE }) ## if OK then run handler, else not setMethod(".gconfirm", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, message, title = "Confirm", icon = c("info", "warning", "error", "question"), parent = NULL, handler = NULL, action = NULL, ... ) { icon = match.arg(icon) l <- list(icon=icon, message=gettext(message[1]), title = title, type="yesno") if(length(message) > 1) l$detail=gettext(message[2]) if(!is.null(parent)) l$parent <- getWidget(parent) out <- do.call("tkmessageBox",l) val <- switch(as.character(out), "yes"=TRUE, "no" = FALSE, FALSE) if(val && !is.null(handler)) { h = list() h$obj=NULL; h$action=action handler(h) } return(val) ## return(tcltkDialog( ## message, ## title=title, ## icon=icon, ## type="confirm", ## parent = parent, ## handler=handler, ## action=action, ## ...)) ## icon = match.arg(icon) ## ret = tkmessageBox( ## message=message, ## title=title, ## icon=icon, ## type="yesnocancel" ## ) ## val = switch(as.character(ret), ## "yes"=1, ## "no"=0, ## "cancel"=-1) ## if(!is.null(handler)) { ## h = list() ## h$obj=NULL; h$action=action ## handler(h) ## } ## return(val) }) ## Add input to the above ## h,... in handler has componets action, input (for value) setMethod(".ginput", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, message, text = "", title = "Input", icon = c("info","warning","error","question"), parent = NULL, handler = NULL, action = NULL, ... ) { return(tcltkDialog( message, text = text, title=title, icon=icon, type="input", parent = parent, handler=handler, action=action, ...)) }) ## add a widget to the dialog. This is modal ## see next one for one that gets called here setMethod(".gbasicdialog", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, title = "Dialog", widget, parent = NULL, handler = NULL, action = NULL, ... ) { message(gettext("gbasiddialog isn't implemented in tcltk"),"\n") return() }) ## with no paret setClass("gBasicDialogNoParenttcltk", contains="gWindowtcltk", prototype=prototype(new("gContainertcltk")) ) setMethod(".gbasicdialognoparent", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, title = "Dialog", parent=NULL, handler = NULL, action = NULL, ... ) { dlg <- gwindow(title, parent=parent, visible=FALSE) tt <- dlg@widget@widget g <- ggroup(container = dlg, horizontal=FALSE, expand=TRUE) obj <- new("gBasicDialogNoParenttcltk", block=dlg, widget=g, toolkit=guiToolkit("tcltk")) tag(obj,"handler") <- handler tag(obj,"action") <- action tag(obj,"tt") <- tt args <- list(...) tag(obj, "do.buttons") <- getWithDefault(args$do.buttons, TRUE) tkbind(tt, "", function() { tkgrab.release(tt) }) return(obj) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gBasicDialogNoParenttcltk", value="guiWidget"), function(obj, toolkit, value, ...) { .add(obj, toolkit, value@widget, ...) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gBasicDialogNoParenttcltk", value="gWidgettcltk"), function(obj, toolkit, value, ...) { add(obj@widget, value, ...) ## keep these around tag(obj,"widget") <- value }) ##' close window setMethod(".dispose", signature(toolkit="guiWidgetsToolkittcltk", obj="gBasicDialogNoParenttcltk"), function(obj, toolkit, ...) { flag <- tag(obj, "flag") tclvalue(flag) <- "destroy" }) setMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk", obj="gBasicDialogNoParenttcltk"), function(obj, toolkit, set=NULL, ...) { if(as.logical(set)) { handler <- tag(obj,"handler") action <- tag(obj,"action") widget <- tag(obj,"widget") tt <- tag(obj,"tt") dlg <- obj@block g <- obj@widget ## we use tclwait.variable, rather than window ## with window, we need to destroy widget before returning loop ## and then widget is destroyed before we can use it. flag <- tclVar("") tag(obj, "flag") <- flag ## bind to destroy event tkwm.protocol(dlg@widget@block, "WM_DELETE_WINDOW", function() { tclvalue(flag) <- "destroy" }) ans <- FALSE if(tag(obj, "do.buttons")) { buttonGroup = ggroup(container=g, expand=TRUE, fill="x") ## just x XXX addSpring(buttonGroup) OKbutton = gbutton("OK",container=buttonGroup,action = tt, handler=function(h,...) { ans <<- TRUE tkgrab.release(h$action) tclvalue(flag) <- "destroy" }) addSpace(buttonGroup, 10) Cancelbutton = gbutton("Cancel",container=buttonGroup, action=tt, handler=function(h,...) { ans <<- FALSE tkgrab.release(h$action) tclvalue(flag) <- "destroy" }) } ## make window visible and on top of stack visible(dlg) <- TRUE focus(dlg) <- TRUE ## make modal tkwait.variable(flag) ## process response if(ans) { ## yes if(!is.null(handler)) { handler(list(obj=widget,action=action)) } dispose(dlg) return(ans) } else { ## no dispose(dlg) return(ans) } } else { ## nothing dispose(dlg) return(NA) } }) ## alert setMethod(".galert", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, message, title = "message", delay = 3, parent=NULL, ... ) { force(toolkit) w <- gwindow(title, width=250, height=50, parent = parent) g <- ggroup(container = w) l <- glabel(" ", container = g) label <- glabel(message, container = g, expand=TRUE) font(label) <- c("weight"="bold") gimage(filename="dismiss",dirname="stock", container = g, handler = function(h,...) dispose(w)) addHandlerMouseMotion(label, handler = function(h,...) dispose(w)) w }) gWidgetstcltk/R/gnotebook.R0000644000176000001440000003002211604711402015425 0ustar ripleyusers## TODO: ## * drag and drop onto tabs, raise on motion, ## * the [ method is not working ## * dispose is forgetting -- not hiding -- the child widget ## * where is my delete method? setMethod(".gnotebook", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, tab.pos = 3, # same as pos= in text closebuttons = FALSE, dontCloseThese = NULL, # integer of tabs not to close container=NULL, # add to this container ...) { force(toolkit) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } tt <- getWidget(container) gp <- ttkframe(tt) nb <- ttknotebook(gp) tkpack(nb, expand=TRUE, fill="both") # pack into gp, gp packed during add(.) ## tabpos if(tab.pos !=3) gwCat(gettext("tab.pos is not implemented\n")) ## create gnotebook object obj = new("gNotebooktcltk", block=gp, widget=nb, toolkit=toolkit,ID=getNewID(),e = new.env(), closebuttons = as.logical(closebuttons), dontCloseThese = ifelse(is.null(dontCloseThese),0,dontCloseThese)) ## add to container add(container, obj, ...) invisible(obj) }) ### methods ## return the current tab number setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gNotebooktcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { nb <- getWidget(obj) curTab <- tclvalue(tcl(nb,"select")) allTabs <- unlist(strsplit(tclvalue(tcl(nb,"tabs")),"\\s+")) which(curTab == allTabs) # 1-based }) ## set the current tab to value setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gNotebooktcltk"), function(obj, toolkit, index=NULL, ..., value) { nb <- getWidget(obj) n = length(obj) value <- max(1,min(value,n)) tcl(nb,"select",value - 1) # 0 -based return(obj) }) ## remove the current tab ## this should be called delete -- which is used to remove objects setMethod(".dispose", signature(toolkit="guiWidgetsToolkittcltk",obj="gNotebooktcltk"), function(obj, toolkit, ...) { nb <- getWidget(obj) theArgs = list(...) to.right=ifelse(!is.null(theArgs$to.right), theArgs$to.right,FALSE) dontCloseThese = obj@dontCloseThese if(dontCloseThese == 0) dontCloseThese = NULL deleteOK = function(i) { if(is.null(dontCloseThese)) return(TRUE) if(i %in% dontCloseThese) return(FALSE) return(TRUE) } cur.pageno = svalue(obj) ## we clear out the current page unless there is more! inds = 0 if(to.right) { n = length(obj) no.right = n - cur.pageno if(no.right > 0) inds = no.right:0 # must work from last backwards } ## clear out would like "hide" here, as then we can ## readd. Not working here? why not? children <- obj@e$childComponents for(i in inds) { j = cur.pageno + i if(deleteOK(j)) { # tcl(nb,"hide", j - 1) tcl(nb,"forget", j - 1) children[[j]] <- NULL } } obj@e$childComponents <- children if(cur.pageno > 0 && length(children)) { # error if no pages if(cur.pageno <= length(obj)) svalue(obj) <- cur.pageno else svalue(obj) <- length(obj) } }) setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk",obj="gNotebooktcltk", widget="gWidgettcltk"), function(obj, toolkit, widget, ...) { nb <- getWidget(obj) childWidget <- getBlock(widget) tcl(nb,"forget",childWidget) ## remove from childComponents children <- obj@e$childComponents ind <- sapply(children, function(i) digest(i) == digest(widget)) if(any(ind)) children <- children[!ind] obj@e$childComponents <- children }) ### add() is a workhorse method here. Several args available in ... #add.gNotebook = functionf(obj, value, # label="", markup = FALSE, # index = NULL, override.closebutton = FALSE, ...) { setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gNotebooktcltk", value="guiWidget"), function(obj, toolkit, value, ...) { .add(obj, toolkit, value@widget, ...) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gNotebooktcltk", value="gWidgettcltk"), function(obj, toolkit, value, ...) { ## add parent, children childComponents <- obj@e$childComponents if(is.null(childComponents)) childComponents <- list() obj@e$childComponents <- c(childComponents, value) value@e$parentContainer <- obj ## in ... we have many possibilies ## label -- for setting label (also look for name) ## index for setting the index of page to add ## markup -- markup label ## override.closebutton -- to not put closebutton even if set in constructor nb <- getWidget(obj) widget <- getBlock(value) ## process ... theArgs = list(...) # for making generic if(!is.null(theArgs$label)) { label = theArgs$label } else if(!is.null(theArgs$name)) { label = theArgs$name } else { label = id(obj) if(is.null(label)) label = "unnamed" } index = if (is.null(theArgs$index)) NULL else theArgs$index if(!is.null(theArgs$pageno)) index = theArgs$pageno # also called paegno markup = if (is.null(theArgs$markup)) FALSE else theArgs$markup override.closebutton = if (is.null(theArgs$override.closebutton)) FALSE else as.logical(theArgs$override.closebutton) packingOptions = list() packingOptions$sticky = if(is.null(theArgs$anchor)) "nw" else xyToAnchor(theArgs$anchor) if(!is.null(theArgs$expand) && theArgs$expand) packingOptions$sticky="news" ## label -- a string in tcltk if(!is.character(label)) label = svalue(label) ## closebutton ## closebutton file <- system.file("images/cancel.gif",package="gWidgets") closeb <- tcl("image","create","photo",file=file) doCloseButton <- FALSE if(!is.null(obj@closebuttons) && as.logical(obj@closebuttons) && !override.closebutton) { doCloseButton <- TRUE gwCat(gettext("gnotebook: close buttons are not active\n")) } ## where # if(!is.null(index)) index = max(1,min(index,n)) ## add drop motion for labels ## ## Can't do close buttons until we can identify when a tab click is on the icon ## We should be able to: nb identify element x y should work, as in ## tkbind(nb, "", function(x,y) { ## tcl(nb, "identify", "element", x, y) ## }) ## however this failes, only identify works and we can't sort out label from image ## if(doCloseButton) { ## packingOptions$image=closeb ## packingOptions$compound = "right" ## } if(is.null(index)) { f <- function(...) tcl(nb,"add", widget, text=label,...) do.call(f,packingOptions) } else { if(doCloseButton) f <- function(...) tcl(nb,"add",index-1, widget, text=label,...) do.call(f,packingOptions) } }) ## Regular R methods treat gnotebook like a vector ## find out number of pages setMethod(".length", signature(toolkit="guiWidgetsToolkittcltk",x="gNotebooktcltk"), function(x, toolkit) { nb <- getWidget(x) as.numeric(tclvalue(tcl(nb,"index","end"))) }) ## return tabnames setMethod(".names",signature(toolkit="guiWidgetsToolkittcltk",x="gNotebooktcltk"), function(x, toolkit) { nb <- getWidget(x) n <- length(x) if(n > 0) vals <- sapply(1:n, function(i) tclvalue(tcl(nb,"tab",i - 1, "-text"))) else vals <- NA return(vals) }) ## can assigne with names(x) <-x or even names(x)[i] <- "single name" setReplaceMethod(".names", signature(toolkit="guiWidgetsToolkittcltk",x = "gNotebooktcltk"), function(x,toolkit, value) { nb <- getWidget(x) n = length(x) if(length(value) != n) stop(gettext("New names for notebook must have proper length")) lapply(1:n, function(i) { tcl(nb,"tab",i-1, text=value[i]) }) return(x) }) ## return widget contained in notebook page i as a list or single widget setMethod("[", signature(x="gNotebooktcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gNotebooktcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { if(missing(i)) i = 1:length(x) children <- x@e$childComponents[i] if(length(children) == 1) children <- children[[1]] return(children) }) ## Puts widget into a position setReplaceMethod("[", signature(x="gNotebooktcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gNotebooktcltk"), function(x, toolkit, i, j, ..., value) { ## message(gettext("Can't add widget via [<-\n")) return() nb <- getWidget(x) widget <- getBlock(value) if(missing(i)) stop(gettext("Missing value for i")) ## works, but parent is all messed up tcl(nb,"add",i - 1, value) }) ### handlers setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gNotebooktcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerexpose(obj,toolkit, handler,action) }) setMethod(".addhandlerexpose", signature(toolkit="guiWidgetsToolkittcltk",obj="gNotebooktcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj,toolkit,"<>",handler, action) }) gWidgetstcltk/R/gexpandgroup.R0000644000176000001440000001772612275234663016177 0ustar ripleyusers## expander group, like a group, only expands, contracts if requested ## inherits from ggroup, see ggroup's arguments: horizontal, spacing, container setClass("gExpandgrouptcltk", contains="gGrouptcltk", prototype=prototype(new("gGrouptcltk")) ) setMethod(".gexpandgroup", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="", markup=FALSE,horizontal=TRUE, handler=NULL, action=NULL, container = NULL, ...){ force(toolkit) ## the ... arguments get passed as follows ## expand, container, anchor go for outergroup ## horizontal, spacing, use.scrollwindow pass to inner group oggroup <- function(container,spacing, user.scrollwindow, ...) ggroup(container=container, horizontal=FALSE, ...) iggroup <- function(container, horizontal, expand, anchor, ...) ggroup(container=container, horizontal=horizontal, ...) ## theArgs = list(...) ## groupArgs = list() ## for(i in c("spacing","use.scrollwindow")) { ## if(!is.null(theArgs[[i]])) { ## groupArgs[[i]] = theArgs[[i]] ## theArgs[[i]] = NULL ## } ## } ## theArgs$horizontal = FALSE ## theArgs$container = container cg = oggroup(container, ...) # cg = do.call("ggroup",theArgs) labelGroup = ggroup(horizontal=TRUE, container=cg) rightArrow = system.file("images","1rightarrow.gif",package="gWidgets") downArrow = system.file("images","1downarrow.gif",package="gWidgets") icon = gimage(downArrow,container=labelGroup) label = glabel(text, container=labelGroup) ## we need this so that getBlock doesn't find cg's block eg1 = ggroup(container=cg, expand=TRUE,horizontal) ## groupArgs$container=eg1 ## groupArgs$expand=TRUE ## eg = do.call("ggroup", groupArgs) eg <- iggroup(container=eg1, horizontal=horizontal, ...) # obj = new("gExpandgrouptcltk",block = eg1, widget = eg, obj = new("gExpandgrouptcltk",block = cg, widget = eg, horizontal=horizontal, toolkit = toolkit, ID = getNewID(), e = new.env()) tag(obj, "containerGroup") <- cg tag(obj, "expandGroup") <- eg1 tag(obj, "icon") <- icon tag(obj, "label") <- label tag(obj, "state") <- FALSE tag(obj, "rightArrow") <- rightArrow tag(obj, "downArrow") <- downArrow tag(obj, "height") <- tkcget(getWidget(obj), "-height") changeState = function(h,...) { if((state <- tag(obj,"state"))) { visible(obj) <- FALSE } else { visible(obj) <- TRUE } } addHandlerClicked(icon, handler=changeState) addHandlerClicked(label, handler=changeState) visible(obj) <- FALSE # initial state ## must take care of closing/opening if(!is.null(handler)) { addHandlerChanged(obj, handler=handler, action=action) } invisible(obj) }) ## methods setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk", value = "gWidgettcltk"), function(obj, toolkit, value, ...) { ## add value to expandgroup add(obj@widget, value, ...) }) setMethod(".addSpace", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk"), function(obj, toolkit, value, ...) { ## add value to expandgroup addSpace(obj@widget, value, ...) }) setMethod(".addSpring", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk"), function(obj, toolkit, ...) { ## add value to expandgroup addSpring(obj@widget, ...) }) ## push onto label setReplaceMethod(".font", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk"), function(obj, toolkit, ..., value) { ## add value to expandgroup font(tag(obj,"label")) <- value return(obj) }) ## Should make ## a) svalure refer to padding, ala ggroup padding ## b) names refer to label ## c) font refer to font of label ## d) visible refer to state ## value refers to padding ## FOr svalue<- we still accept non-numeric for setting lable setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { svalue(tag(obj,"label")) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk", value = "numeric"), function(obj, toolkit, index=NULL, ..., value) { svalue(obj@widget, value) return(obj) }) ## set name, but is deprecated setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk"), function(obj, toolkit, index=NULL, ..., value) { gwCat("Using names<- to set label value") svalue(tag(obj,"label")) <- as.character(value) return(obj) }) ## visible method setMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk"), function(obj, toolkit, set=TRUE,...) { tag(obj,"state") }) ## control expand/close with logical setReplaceMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk"), function(obj, toolkit, ..., value) { W <- getWidget(obj) ## cg = tag(obj,"containerGroup") ## eg = tag(obj,"expandGroup") if( (value <- as.logical(value)) ) { ## true, expand ## add(cg, eg, expand=TRUE) tkpack("propagate", W, TRUE) tkconfigure(W, height=tag(obj, "height")) svalue(tag(obj,"icon")) <- tag(obj,"downArrow") } else { ## delete(cg,eg) tag(obj, "height") <- tkwinfo("height", W) tkpack("propagate", W, FALSE) tkconfigure(W, height=1) svalue(tag(obj,"icon")) <- tag(obj,"rightArrow") } tag(obj,"state") <-value return(obj) }) ## names refers to label setMethod(".names", signature(toolkit="guiWidgetsToolkittcltk",x="gExpandgrouptcltk"), function(x, toolkit) { svalue(tag(x,"label")) }) setReplaceMethod(".names", signature(toolkit="guiWidgetsToolkittcltk", x="gExpandgrouptcltk"), function(x, toolkit, value) { svalue(tag(x,"label")) <- as.character(value) return(x) }) setReplaceMethod(".font", signature(toolkit="guiWidgetsToolkittcltk", obj="gExpandgrouptcltk"), function(obj, toolkit, value) { font(tag(obj, "label")) <- value return(obj) }) ## handlers ## putonto expander button setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gExpandgrouptcltk"), function(obj, toolkit, handler, action=NULL, ...) { addHandlerChanged(tag(obj,"icon"), handler, action,...) addHandlerChanged(tag(obj,"label"), handler, action,...) }) gWidgetstcltk/R/gpanedgroup.R0000644000176000001440000001073111604711402015756 0ustar ripleyuserssetClass("gPanedgrouptcltk", contains="gContainertcltk", prototype=prototype(new("gContainertcltk")) ) ## TODO: method obj[1 or 2 ] <- replacewidget setMethod(".gpanedgroup", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, widget1, widget2, horizontal=TRUE, container=NULL, ...) { ## add a paned group force(toolkit) if(is.null(container)) { message(gettext("No NULL containers in tcltk. Creating a new window\n")) container=gwindow() } else if(is.logical(container) && container) { container = gwindow() } if(!is(container,"guiWidget")) { container = gwindow() } ## process args if(horizontal) orient = "horizontal" else orient = "vertical" tt <- getWidget(container) ## pg <- tkwidget(tt,"panedwindow", orient=orient) pg <- ttkpanedwindow(tt, orient=orient) tkpack(pg, expand=TRUE, fill="both") ## make object -- note block is pg so that add works correctly ## as it calls getBlock(container) obj = new("gPanedgrouptcltk", block=pg, widget=pg, toolkit=toolkit,ID=getNewID(), e = new.env()) tag(obj,"horizontal") <- horizontal if(!missing(widget1) || !missing(widget2)) { gwCat(gettext("In tcltk, you use the gpanedgroup object in the container argument of a constructor\n")) } return(obj) }) ## add -- use this rather than at construction time setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gPanedgrouptcltk", value="gWidgettcltk"), function(obj, toolkit, value, ...) { ## add parent, children childComponents <- obj@e$childComponents if(is.null(childComponents)) childComponents <- list() obj@e$childComponents <- c(childComponents, value) value@e$parentContainer <- obj theArgs = list(...) # argList = list(getWidget(obj),"add",getBlock(value)) argList = list(getWidget(obj),"insert","end",getBlock(value)) ## args to position sticky = "n" if(!is.null(theArgs$anchor)) { sticky = xyToAnchor(theArgs$anchor) } if(!is.null(theArgs$expand) && theArgs$expand) { if(tag(obj,"horizontal")) sticky = "news" else sticky = "news" } argList$sticky = sticky ## for ttk argList$sticky <- NULL do.call("tcl", argList) ## tcl(tt,"add",widget,...) }) ## delete means we can readd -- in this case we actually dispose, as ## the widget doesn't get added back? setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk",obj="gPanedgrouptcltk", widget="gWidgettcltk"), function(obj, toolkit, widget, ...) { ## call forget tcl(getWidget(obj),"forget",getBlock(widget)) }) ## svalue refers to sash position between 0 and 1 ## sashpos setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gPanedgrouptcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { sashpos <- as.numeric(tclvalue(tcl(getWidget(obj),"sashpos",0))) theSize <- size(obj) if(tag(obj,"horizontal")) return(sashpos/theSize[1]) else return(sashpos/theSize[2]) }) ## svalue sets position setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gPanedgrouptcltk"), function(obj, toolkit, index=NULL, ..., value) { if(0 <= value && value <= 1) { theSize <- size(obj) if(tag(obj,"horizontal")) pos <- floor(value * theSize[1]) else pos <- floor(value * theSize[2]) tcl(getWidget(obj),"sashpos", 0, as.integer(pos)) } return(obj) }) gWidgetstcltk/R/gimage.R0000644000176000001440000001577011651631355014716 0ustar ripleyusers## I should make an abstract class for gButton, gImage and gLabel ## instead I get lots of repeated code. setClass("gImagetcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## image use setMethod(".gimage", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, filename = "", dirname="", size="", handler=NULL, action=NULL, container=NULL, ...) { force(toolkit) ## container in tcltk if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning(gettext("Container argument is not correct: No NULL containers possible in gWidgetstcltk\n")) return() } ## XXX pushed this into svalue method -- otherwise we repeat ## ## get filename ## iconFile = NULL ## if(dirname == "stock") { ## ## check if in gWidgetstcltk ## isIcon <- system.file(paste("icons/",filename,".gif",sep=""), ## package="tcltk") ## if(file.exists(isIcon)) { ## iconFile <- isIcon ## } else { ## gWidgetstcltkIcons = getStockIcons() ## iconFile = gWidgetstcltkIcons[[filename,exact=TRUE]] ## if(!is.null(iconFile) && !file.exists(iconFile)) { ## iconFile <- gWidgetstcltkIcons[["clear"]] ## } ## } ## } else if(dirname != "") { ## iconFile = paste(dirname,filename,sep=.Platform$file.sep) ## } else { ## iconFile = filename ## } ## imageID = paste("gimage",gp$ID,sep="") ## ## base tk support gif, ppm and bitmap (ppm doesn't seem to though) ## if(!is.null(iconFile) && file.exists(iconFile)) { ## x = try(tcl("image","create","photo",imageID,file=iconFile),silent=TRUE) ## ## now try as bitmap ## if(inherits(x,"try-error")) { ## x = try(tcl("image","create","bitmap",imageID,file=iconFile),silent=TRUE) ## } ## if(inherits(x,"try-error")) { ## cat(gettext("gimage had issues. Only gif, ppm and xbm files in gWidgetstcltk\n")) ## lab <- ttklabel(gp,text="") ## } else { ## lab <- ttklabel(gp, image=imageID) ## } ## } else { ## ## uninitialized ## lab <- ttklabel(gp,text="") ## } ## tkpack(lab, expand=TRUE, fill="both") ## we need the imageID (tcl name for image) ## for stockicons we have that ::stockicon::quit.fig ## returned by findIcon() ## for non stock, we need to make. For this we need iconFile -- path ## and make a image id ## iconFile <- NULL ## imageID <- "" ## if(dirname == "stock") { ## imageID <- findIcon(filename) ## } else { ## if(dirname != "") { ## iconFile = paste(dirname,filename,sep=.Platform$file.sep) ## } else { ## iconFile = filename ## } ## imageID = paste("::gimage::",filename,sep="") ## if(!is.null(iconFile) && file.exists(iconFile)) { ## x = try(tcl("image","create","photo",imageID,file=iconFile),silent=TRUE) ## ## now try as bitmap ## if(inherits(x,"try-error")) { ## x = try(tcl("image","create","bitmap",imageID,file=iconFile),silent=TRUE) ## } ## if(inherits(x,"try-error")) { ## cat(gettext("gimage had issues. Only gif, ppm and xbm files in gWidgetstcltk\n")) ## imageID <- "" ## } ## } ## } ## implement size -- photo has width, height if (size != "") message(gettext("gimage: size argument is currently ignored\n")) tt <- getWidget(container) lab <- ttklabel(tt, text="") ## if(imageID != "") ## tkconfigure(lab, image=imageID) obj = new("gImagetcltk", block=lab, widget=lab, toolkit=toolkit,ID=getNewID(),e = new.env() ) ## if file and dirnot empty (and dir not stock) if(filename != "" && dirname != "" && dirname != "stock" ) filename <- paste(dirname, filename, sep=.Platform$file.sep) if(filename != "") svalue(obj) <- filename if(!is.null(handler)) { id = addhandlerclicked(obj, handler=handler, action=action) } ## attach add(container, obj,...) invisible(obj) }) setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gImagetcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { ## return name? return(tag(obj,"..filename")) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gImagetcltk"), function(obj, toolkit, index=NULL, ..., value) { ## value is a full filename or icon name gWidgetstcltkIcons = getStockIcons() ## is a stock icon if(!is.null(gWidgetstcltkIcons[[value]])) { imageID <- findIcon(value) tkconfigure(getWidget(obj),image=imageID) } else if(file.exists(value)) { imageID <- sprintf("gWidgets::%s", digest(value)) x = try(tcl("image","create","photo", imageID, file=value), silent=TRUE) if(inherits(x,"try-error")) { message(gettext("Only gif and pnm files are possible in gWidgetstcltk\n")) } else { tkconfigure(getWidget(obj),image=imageID) } } ## store dynamically, not with @filename tag(obj,"..filename") <- value return(obj) }) ## set size setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gImagetcltk"), function(obj, toolkit, ..., value) { ## pixels for tkframe etc tkconfigure(getWidget(obj), width=value[1], height=value[2]) return(obj) }) setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gImagetcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerclicked(obj, toolkit, handler, action, ...) }) gWidgetstcltk/R/gstatusbar.R0000644000176000001440000000503011604711402015616 0ustar ripleyusers## StatusBar. Use value to push message, value to pop setClass("gStatusbartcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## constructor setMethod(".gstatusbar", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="", container=NULL, ...) { force(toolkit) if(is(container,"logical") && container) container = gwindow() ## container must be a gwindow unless we pass in argument not.toplevel=TRUE theArgs <- list(...) if(!is.null(theArgs$not.toplevel) && as.logical(theArgs$not.toplevel)) { tt <- getBlock(container) } else { if(!(is(container,"gWindowtcltk") || is(container@widget,"gWindowtcltk"))) { message(gettext("gstatusbar: container must be gwindow instance\n")) } tt <- tag(container,"sb") } gp <- ttkframe(tt) sb <- ttklabel(gp, text=text) tkpack(sb, side="left",anchor="w", expand=TRUE, fill="x") obj = new("gStatusbartcltk",block=gp, widget=sb, toolkit=toolkit, ID=getNewID(), e = new.env()) stack <- c(text) tag(obj,"stack") <- stack ## add to container add(container, obj,...) invisible(obj) }) ### methods ## This pops label setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gStatusbartcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { ## pop the stack stack <- tag(obj,"stack") val <- stack[1] if(length(stack)) stack <- stack[-1] tag(obj,"stack") <- stack if(length(stack)) value <- stack[1] else value <- "" tkconfigure(obj@widget, text=as.character(value)) return(val) }) ## This pushes to label setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gStatusbartcltk"), function(obj, toolkit, index=NULL, ..., value) { stack <- tag(obj,"stack") stack <- c(value, stack) tag(obj,"stack") <- stack tkconfigure(obj@widget, text=as.character(value)) return(obj) }) gWidgetstcltk/R/tcltkFuns.R0000644000176000001440000001630111764450765015442 0ustar ripleyusers##' Coerce tclObj object to logical value ##' ##' @param x should be a "0" or "1" value ##' @param ... ignored ##' @return a logical or NA as.logical.tclObj <- function(x, ...) as.logical(as.numeric(x)) ##' Does object exists as tcl variable ##' ##' @param x character string with name of variable ##' @return logical tclObj_exists <- function(x) as.logical(.Tcl(sprintf("info exists %s", x))) ##' create a tcl image from the file ##' ##' @param basename basename of image. We add some bit to avoid filename collisions ##' @param file file of image ##' @return image name make_tcl_image <- function(basename, file) { already_defined <- function(nm) any(nm == as.character(tcl("image","names"))) nm <- sprintf("::tcl::%s", basename) if(!already_defined(nm)) { tcl("image","create","photo", nm ,file=file) } return(nm) } ##' Heuristic to determine if widget is a ttk widget ##' ##' @param x tk object or its id ##' @return logical indicating is ttk widget or not isTtkWidget <- function(x) { cl <- as.character(tkwinfo("class",x)) (cl %in% c("Treeview")) || grepl("^[A-Z]{2,}", cl) } ##' what windowing system? ##' ##' @return one of c("x11", "win32", "aqua") windowingsystem <- function() { ## one of x11 (X11-based), win32 (MS Windows), or aqua (Mac OS X Aqu as.character(.Tcl("tk windowingsystem")) } ## return tk widget from obj ## ** This should be a method ** getWidget = function(obj) { if(is(obj,"tkwin")) return(obj) if(is(obj,"gWidgettcltk")) return(getWidget(obj@widget)) else if(is(obj,"guiWidget")) return(getWidget(obj@widget)) else return(NA) } getBlock = function(obj) { if(is(obj,"tkwin")) return(obj) if(is(obj,"gWidgettcltk")) return(getBlock(obj@block)) else if(is(obj,"guiWidget")) return(getBlock(obj@widget)) else return(NA) } getTopParent = function(tkobj) { ## in env is parent variable if present ans <- NULL while(is.null(ans)) { e <- tkobj$env$parent if(is.list(e) && e[['ID']] =="") ans <- tkobj else tkobj <- tkobj$env$parent } return(ans) } getTopLevel <- function(obj) { if(is(obj, "guiWidget")) { return(getTopLevel(obj@widget)) } else if(!is.null(obj@e$parentContainer)) { return(getTopLevel(obj@e$parentContainer)) } else { return(obj) } } ####################################################### ## methods to interact with underlying toolkit object setMethod(".getToolkitWidget", signature(obj="gWidgettcltk", toolkit="guiWidgetsToolkittcltk"), function(obj, toolkit) getWidget(obj)) setMethod(".callToolkitMethod", signature(x="gWidgettcltk", toolkit="guiWidgetsToolkittcltk"), function(x, toolkit, meth_name) { widget <- getWidget(x) f <- function(...) { get(meth_name, parent.frame())(widget, ...) } f # return a function }) setMethod(".getToolkitProperty", signature(x="gWidgettcltk", toolkit="guiWidgetsToolkittcltk"), function(x, toolkit, property) { widget <- getWidget(x) tkcget(widget, sprintf("-%s", property)) }) setMethod(".setToolkitProperty", signature(x="gWidgettcltk", toolkit="guiWidgetsToolkittcltk"), function(x, toolkit, property, value) { widget <- getWidget(x) l <- list(widget); l[[property]] <- value do.call(tkconfigure, l) x }) ## Does the top level window exists windowExists = function(obj) { win = getTopParent(getWidget(obj)) as.logical(tkwinfo("exists", win)) } findTkIcon <- function(i) { if(is.null(i)) return("") stock <- getStockIcons() gwi <- system.file(paste("image/",i,".png",sep=""), package="gWidgetstcltk") if(is.null(i) || is.na(i) || i == "") val <- "" else if(file.exists(i)) val <- i else if (file.exists(gwi)) val <- gwi else val <- stock[[i, exact=TRUE]] ## what to return if(is.null(val)) return("") else return(val) } ################################################## ## function to add scrollbars to widget and pack into grid addScrollbarsToWidget <- function(widget, parent) { xscr <- ttkscrollbar(parent, orient="horizontal", command=function(...) tkxview(widget, ...)) yscr <- ttkscrollbar(parent, orient="vertical", command=function(...) tkxview(widget, ...)) tkconfigure(widget, xscrollcommand=function(...) tkset(xscr,...), yscrollcommand=function(...) tkset(yscr,...)) tkgrid(widget, row=0, column=0, sticky="news") tkgrid(yscr,row=0,column=1, sticky="ns") tkgrid(xscr, row=1, column=0, sticky="ew") tkgrid.columnconfigure(parent, 0, weight=1) tkgrid.rowconfigure(parent, 0, weight=1) } ##' helper to make a treeview and populate from m ##' ##' @param parent parent container. Must use pack manager. ##' @param m character matrix. May have 1 or more columns ##' @return list with components \code{frame} (the enclosing frame for ##' size management, managed by pack); \code{tr}, a treeview widget. populate_rectangular_treeview <- function(parent, m) { enc_frame <- ttkframe(parent) frame <- ttkframe(enc_frame) tkpack(frame, expand=TRUE, fill="both") tr <- ttktreeview(frame, columns=seq_len(ncol(m)), show="headings", selectmode="browse" ) addScrollbarsToWidget(tr, frame) tkpack.propagate(enc_frame, FALSE) ## headings,widths charWidth <- as.integer(tclvalue(tcl("font","measure","TkTextFont","0"))) sapply(seq_len(ncol(m)), function(i) { tcl(tr, "heading", i, text=colnames(m)[i]) tcl(tr, "column", i, width=10 + charWidth*max(apply(m, 2, nchar))) }) tcl(tr, "column", ncol(m), stretch=TRUE) # stretch last tcl(tr, "column", "#0", stretch=FALSE) # no strecth on icons ## values apply(m, 1, function(vals) { if(length(vals) == 1) vals <- paste("{", vals, "}", sep="") tcl(tr, "insert", "", "end", values=vals) }) return(list(tr=tr, frame=enc_frame)) } ### tk2tip.R - Tooltips for Tk widgets ### Copyright (c), Philippe Grosjean (phgrosjean@sciviews.org) ### Licensed under LGPL 3 or above ### ### Changes: ### - 2007-01-01: first version (for tcltk2_1.0-0) ### ### To do: ### - add and check catch instructions here ## JV: Rather than load in tcltk2 dependency, we borrow Philippe's work here tk2tip <- function (widget, message) { ## if (!is.tk()) stop("Package Tk is required but not loaded") if (is.null(message)) message <- "" res <- tclRequire("tooltip") if (inherits(res, "tclObj")) { res <- tcl("tooltip::tooltip", widget, message) ## Store tip text in the object (use NULL instead of "" for no tip) if (message == "") message <- NULL widget$env$tip <- message } else stop("cannot find tcl package 'tooltip'") return(invisible(res)) } tk2killtip <- function () { ## if (!is.tk()) stop("Package Tk is required but not loaded") return(invisible(tcl("tooltip::hide"))) } ## Get tip method tip <- function (x, ...) UseMethod("tip") tip.tk2widget <- function (x, ...) return(x$env$tip) ## Chenge tip method `tip<-` <- function (x, value) UseMethod("tip<-") `tip<-.tk2widget` <- function (x, value) { tk2tip(x, value) return(x) } gWidgetstcltk/R/gframe.R0000644000176000001440000000716711414475356014733 0ustar ripleyuserssetClass("gFrametcltk", contains="gGrouptcltk", prototype=prototype(new("gGrouptcltk")) ) ## add a frame for packing. subclass of gGroup setMethod(".gframe", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text = "", markup=FALSE, pos = 0, ## pos in [0,1] 0 for left, (.01,.99) center, 1 for right horizontal=TRUE, container=NULL, ...) { force(toolkit) ## we can't do any markup here. Font() could be used if(markup) { gwCat(gettext("HTML markup not supported for title. \n")) text = gsub("<[^>]*>","",text) # strip off HTML } ## where to put labAnchor = "nw" if(.33 < pos && pos < .66) labAnchor = "n" else if(.66 <= pos) labAnchor = "ne" theArgs <- list(...) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } tt <- getWidget(container) f <- tkwidget(tt, "ttk::labelframe", text=text, labelanchor=labAnchor) ## put in some padding. Adjust with svalue if(!is.null(theArgs$spacing)) spacing <- theArgs$spacing else spacing <- 5 tkconfigure(f,"padding"=spacing) ## XXX -- not sure this is supposed to be here ## ## handle expand and anchor arguments for packing frame ## argList = list(f) ## if(!is.null(theArgs$expand) && theArgs$expand) { ## argList$expand = TRUE ## argList$fill = "both" ## } ## if(is.null(theArgs$anchor)) ## theArgs$anchor= c(-1,1) ## argList$anchor = xyToAnchor(theArgs$anchor) ## do.call("tkpack",argList) obj = new("gFrametcltk", block=f, widget=f, toolkit=toolkit, horizontal=horizontal, ID=getNewID(), e = new.env()) tag(obj,"title") <- text ## attach to container if there if(!is.null(container)) { add(container, obj,...) } return(obj) }) ## methods ## should be same as from ggroup: ## svalue<- padding ## names<- name ## sets the padding. Same as ggroup setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gFrametcltk"), function(obj, toolkit, index=NULL, drop=NULL, ..., value) { ## adds some breathing room to object ## value is pixels widget <- getWidget(obj) tcl(widget,"configure","padding"=as.numeric(value)) return(obj) }) ## should put in a names argument to change label value ## return label name setMethod(".names",signature(toolkit="guiWidgetsToolkittcltk", x="gFrametcltk"), function(x, toolkit) { tag(x,"title") }) setReplaceMethod(".names", signature(toolkit="guiWidgetsToolkittcltk",x = "gFrametcltk"), function(x,toolkit,value) { f <- x@widget ## XXX What to put here? tkconfigure(f,text=as.character(value)) tag(x,"title") <- value return(x) }) gWidgetstcltk/R/aaaGenerics.R0000644000176000001440000015522712313661747015675 0ustar ripleyusersrequire(methods) require(digest) require(tcltk) MSG = function(...) message("DEBUG: ",...,"\n") missingMsg = function(x) { if(missing(x)) x = "XXX" message("This method ",x," needs to be written\n") } ## toolkit class ## register classes here for toolkits ## Not needed as in gwidgets ## setClass("guiWidgetsToolkittcltk", ## contains="guiWidgetsToolkit", ## prototype=prototype(new("guiWidgetsToolkit")) ## ) ################################################## ## put S3 classes from tcltk into S4 classes ## got these from apropos("New") -> try(class(do.call(i,list()))) oldClasses =c("tkwin", "tclVar", "tclObj") setClass("tcltkObject") lapply(oldClasses, function(i) { setOldClass(i) setIs(i,"tcltkObject") }) setOldClass("try-error") # for handling try-errors ## a base class which is virtual ################################################## ## A virtual class to hold either RGTK or these guys ## A virtual class for our newly defined objects ## this one contains the ID for the object. ## this may better be done within the NAMESPACE id.env <- new.env() id.env[['n']] <- 0L getNewID = function() { # get new one, incremented n <- id.env[['n']] id.env[['n']] <- n + 1 return(n+1) } setClass("gWidgettcltk", representation(ID="numeric", e="environment" ), ) setClassUnion("guiWidgetORgWidgettcltkORtcltkObject", c("guiWidget","gWidgettcltk","tcltkObject")) ## subclss setClass("gComponenttcltk", representation( block="guiWidgetORgWidgettcltkORtcltkObject", widget="guiWidgetORgWidgettcltkORtcltkObject", toolkit="guiWidgetsToolkit" ), contains="gWidgettcltk", ) setClass("gContainertcltk", representation( block="guiWidgetORgWidgettcltkORtcltkObject", widget="guiWidgetORgWidgettcltkORtcltkObject", toolkit="guiWidgetsToolkit" ), contains="gWidgettcltk", ) setClass("gComponentR5tcltk", representation(R5widget="ANY"), contains="gComponenttcltk", ) ## make tcltk S3 object S4 objects oldclasses = c("tkwin", "tclVar") for(i in oldclasses) { setOldClass(i) setIs(i,"guiWidgetORgWidgettcltkORtcltkObject") } ################################################## ### Common methods. Specific to a class are put into the file for that class ## we have two definitions. For instance, "svalue" and ".svalue". The "svalue" method dispatches on the object to the .svalue method. This allows us to use svalue instead of .svalue when defining the methods/constructors inside this package. setMethod("svalue",signature(obj="gWidgettcltk"), function(obj, index=NULL, drop=NULL, ...) { .svalue(obj, obj@toolkit, ..., index=index, drop=drop) }) ## svalue ## need method for character and AsIs setMethod("svalue",signature(obj="character"), function(obj, index=NULL, drop=NULL, ...) { ifelse(length(obj) == 1, return(getObjectFromString(obj)), return(obj) ) }) ## method for Any is just a pass through setMethod("svalue",signature(obj="ANY"), function(obj, index=NULL, drop=NULL, ...) { return(obj) }) setMethod(".svalue",signature(toolkit = "guiWidgetsToolkittcltk", obj="character"), function(obj, toolkit, index=NULL, drop=NULL, ...) { ifelse(length(obj) == 1, return(getObjectFromString(obj)), return(NA) ) }) ## svalue<- -- objec specific setReplaceMethod("svalue",signature(obj="gWidgettcltk"), function(obj, index=NULL, ...,value) { .svalue(obj, obj@toolkit, index=index, ...) <- value obj }) ## [ setMethod("[", signature(x="gWidgettcltk"), function(x,i,j,...,drop=TRUE) { return(.leftBracket(x, x@toolkit,i,j,...,drop=TRUE)) }) ## [<- setReplaceMethod("[",signature(x="gWidgettcltk"), function(x,i,j,...,value) { if(missing(i) && missing(j)) .leftBracket(x, x@toolkit,...) <- value else if(missing(j)) .leftBracket(x, x@toolkit,i,...) <- value else .leftBracket(x, x@toolkit,i,j,...) <- value return(x) }) ## size ## return size -- not implemented setMethod("size",signature(obj="gWidgettcltk"), function(obj, ...) { .size(obj, obj@toolkit,...) }) setMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ...) { width <- tclvalue(tkwinfo("width",getWidget(obj))) height <- tclvalue(tkwinfo("height",getWidget(obj))) return(as.numeric(c(width=width, height=height))) }) ## size<- setReplaceMethod("size",signature(obj="gWidgettcltk"), function(obj, ..., value) { .size(obj, obj@toolkit,...) <- value return(obj) }) setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ..., value) { width <- value[1] if(length(value) > 1) height <- value[2] else height <- 0 if(height > 0) tkconfigure(getWidget(obj), width=width, height=height) else tkconfigure(getWidget(obj), width=width) return(obj) }) ## size for components is funny. For many width is characters, height ## is lines of text setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gComponenttcltk"), function(obj, toolkit, ..., value) { ## width in characters, height in lines ## convert Pixels to each ## XXX TODO: Hack in iterative process to fix size. This doesn't match ## size(obj) <- width; size(obj)[1] - width == 0 (or even close) ## simple way is width <- value[1] height <- NULL if(length(value) > 1) height <- value[2] ## ## set width ## f <- function(lamda) { ## tkconfigure(getWidget(obj), width=ceiling(width*lamda/widthOfChar)) ## act_width <- as.numeric(tkwinfo("width", getWidget(obj))) ## abs(act_width - width) ## } ## nlm(f, 1)#, stepmax=.05, steptol=.01) ## if(!is.null(height)) { ## f <- function(char_height) { ## tkconfigure(getWidget(obj), height=ceiling(width/char_height)) ## act_width <- as.numeric(tkwinfo("height", getWidget(obj))) ## abs(act_width - width) ## } ## nlm(f, heightOfChar, steptol=1) ## } width <- ceiling(width/widthOfChar) if(!is.null(height)) height <- ceiling(height/heightOfChar) if(!is.null(height)) tkconfigure(getWidget(obj), width=width, height=height) else tkconfigure(getWidget(obj), width=width) return(obj) }) ## this works if container has no children (gwindow) but fails otherwise. setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gContainertcltk"), function(obj, toolkit, ..., value) { ## pixels for tkframe etc width <- value[1] if(length(value) > 1) height <- value[2] else height <- 0 if(height > 0) tkconfigure(getWidget(obj), width=width, height=height) else tkconfigure(getWidget(obj), width=width) return(obj) }) ## visible setMethod("visible",signature(obj="gWidgettcltk"), function(obj, set=NULL, ...) { .visible(obj,obj@toolkit, set=set, ...) }) ##' get visibility setMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, set=TRUE, ...) { widget <- getBlock(obj) if(is.null(set)) { ## return logical as.logical(tkwinfo("viewable", widget)) } else { .visible(obj, toolkit) <- set return(NA) } }) ## is widget viewable setMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="tkwin"), function(obj, toolkit, set=TRUE, ...) { w <- getWidget(obj) as.logical(tkwinfo("viewable", w)) }) ## visible<- setReplaceMethod("visible",signature(obj="gWidgettcltk"), function(obj, ..., value) { .visible(obj, obj@toolkit, ...) <- value return(obj) }) setReplaceMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ..., value) { message("visible<- not implemented\n") return(obj) }) setReplaceMethod(".visible", signature(toolkit="guiWidgetsToolkittcltk",obj="tkwin"), function(obj, toolkit, ..., value) { ## visible not implemented return(obj) }) ## enabled -- TRUE If state is normal ##' enabled different for ttk widget enabled_ttkwidget <- function(x, ...) { !as.logical(tcl(x, "instate", "disabled")) } enabled_tkwidget <- function(x, ...) { as.character(tkcget(x, "-state")) == "normal" } setMethod("enabled",signature(obj="gWidgettcltk"), function(obj, ...) { .enabled(obj, obj@toolkit,...) }) setMethod(".enabled", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ...) { w <- getWidget(obj) if(isTtkWidget(w)) enabled_ttkwidget(w) else enabled_tkwidget(w) }) ## enabled<- setReplaceMethod("enabled",signature(obj="gWidgettcltk"), function(obj, ..., value) { .enabled(obj, obj@toolkit,...) <- value return(obj) }) setReplaceMethod(".enabled", signature(toolkit="guiWidgetsToolkit",obj="gWidgettcltk"), function(obj, toolkit, ..., value) { .enabled(obj,guiToolkit("tcltk"), ...) <- value return(obj) }) setenabled_ttkwidget <- function(x, value) { tcl(x, "state", ifelse(value, "!disabled", "disabled")) } setenabled_tkwidget <- function(x, value) { tkconfigure(x, state=ifelse(as.logical(value), "normal", "disabled")) } setReplaceMethod(".enabled", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ..., value) { w <- getWidget(obj) if(isTtkWidget(w)) setenabled_ttkwidget(w, as.logical(value)) else setenabled_tkwidget(w, as.logical(value)) ## recurse into childComponents childComponents <- obj@e$childComponents if(!is.null(childComponents)) lapply(childComponents,function(i) enabled(i) <- value) return(obj) }) ## editable or readonly ## I want a editable<- method for gdf, gcombobox, glabel setMethod(".editable", signature(toolkit="guiWidgetsToolkittcltk", obj="gWidgettcltk"), function(obj, toolkit) { widget <- getWidget(obj) as.character(tkcget(widget, "-state")) != "readonly" }) setReplaceMethod(".editable", signature(toolkit="guiWidgetsToolkittcltk", obj="gWidgettcltk", value="logical"), function(obj, toolkit, ..., value) { widget <- getWidget(obj) tkconfigure(widget, "state"=ifelse(value, "normal", "readonly")) return(obj) }) ## focus focus_ttkwidget <- function(x, ...) as.logical(tcl(x, "instate", "focus")) focus_tkwidget <- function(x, ...) { if(is.tkwin(x)) x <- x$ID tl <- tkwinfo("toplevel", x) cur <- as.character(tcl("focus", displayof=tl)) return(cur == x) } setMethod("focus",signature(obj="gWidgettcltk"), function(obj, ...) { .focus(obj, obj@toolkit,...) }) setMethod(".focus", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ...) { w <- getWidget(obj) if(isTtkWidget(w)) focus_ttkwidget(w) else focus_tkwidget(w) }) ## focus<- setReplaceMethod("focus",signature(obj="gWidgettcltk"), function(obj, ..., value) { .focus(obj, obj@toolkit,...) <- value return(obj) }) setfocus_ttkwidget <- function(x, value) if(value) tcl(x, "state", "focus") setfocus_tkwidget <- function(x, value) if(value) tkfocus(x) setReplaceMethod("focus",signature(obj="tcltkObject"), function(obj, ..., value) { w <- getWidget(obj) if(isTtkWidget(w)) setfocus_ttkwidget(w, value) else setfocus_tkwidget(w, value) return(obj) }) setReplaceMethod(".focus", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ..., value) { focus(obj@widget, toolkit, ...) <- value return(obj) }) setReplaceMethod(".focus", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, ..., value) { value = as.logical(value) if(as.logical(value)) tkfocus(getBlock(obj)) return(obj) }) ## default Widget is initially focused. SHould have binding for this ## defaultWidget setMethod("defaultWidget",signature(obj="gWidgettcltk"), function(obj, ...) { .defaultWidget(obj, obj@toolkit,...) }) setMethod(".defaultWidget", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ...) focus(obj) ) ## defaultWidget<- setReplaceMethod("defaultWidget",signature(obj="gWidgettcltk"), function(obj, ..., value) { .defaultWidget(obj, obj@toolkit,...) <- value return(obj) }) setReplaceMethod("defaultWidget",signature(obj="tcltkObject"), function(obj, ..., value) { .defaultWidget(obj, toolkit=guiToolkit("tcltk"),...) <- value return(obj) }) setReplaceMethod(".defaultWidget", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ..., value) { widget <- getWidget(obj) .defaultWidget(widget, toolkit, ...) <- value return(obj) }) setReplaceMethod(".defaultWidget", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, ..., value) { value = as.logical(value) if(value) tkfocus(obj) return(obj) }) ## isExtant ## enabled -- TRUE If state is normal setMethod("isExtant",signature(obj="gWidgettcltk"), function(obj, ...) { .isExtant(obj, obj@toolkit,...) }) setMethod(".isExtant", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ...) { w <- getWidget(obj) as.logical(as.numeric(tkwinfo("exists", w))) }) ## tooltip<- setReplaceMethod("tooltip",signature(obj="gWidgettcltk"), function(obj, ..., value) { .tooltip(obj, obj@toolkit,...) <- value return(obj) }) setReplaceMethod(".tooltip", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ..., value) { widget <- getWidget(obj) tk2tip(widget, paste(value, collapse="\n")) return(obj) }) setReplaceMethod("tooltip",signature(obj="tcltkObject"), function(obj, ..., value) { ## set the tip. tk2tip(obj, paste(value, collapse="\n")) return(obj) }) ## font ## The .font method is not imported from gWidgets, or exported from gWidgetstcltk. Add this bac if you are going to use this method setMethod("font",signature(obj="gWidgettcltk"), function(obj, ...) { warning("font() not defined. Set fonts with font<-") return() .font(obj, obj@toolkit,...) }) ## font<- setReplaceMethod("font",signature(obj="gWidgettcltk"), function(obj, ..., value) { .font(obj, obj@toolkit,...) <- .fixFontMessUp(value) return(obj) }) setReplaceMethod(".font", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ..., value) { .font(obj@widget, toolkit, ...) <- value return(obj) }) .font.styles = list( families = c("normal","sans","serif","monospace"), weights = c("normal","oblique","italic"), styles = c("ultra-light","light","normal","bold","ultra-bold","heavy"), colors = c("black","blue","red","green","brown","yellow","pink") ) ## common merge.list <- function(x,y, overwrite=TRUE) { for(i in names(y)) { if(is.null(x[[i]]) || overwrite) x[[i]] <- y[[i]] } x } ## ... passed into tkfont.create as font name fontlistFromMarkup <- function(markup,...) { if(!is.list(markup)) markup <- lapply(markup,function(x) x) fontList <- list(...) if(!is.null(markup$family)) fontList <- merge(fontList, list(family=switch(markup$family, "normal"="times", "sans" = "helvetica", "serif" = "times", "monospace"="courier", markup$family))) if(!is.null(markup$style)) fontList <- merge(fontList, list(slant=switch(markup$style, "normal"="roman", "oblique"="roman", "italic"="italic", "roman"))) if(!is.null(markup$weight)) fontList <- merge(fontList, list(weight=switch(markup$weight, "heavy"="bold", "ultra-bold"="bold", "bold"="bold", "normal"="normal", "light"="normal", "ultra-light" = "normal", "normal"))) if(!is.null(markup$size)) if(is.numeric(markup$size)) fontList <- merge(fontList, list(size=markup$size)) else fontList <- merge(fontList,list(size = switch(markup$size, "xxx-large"=24, "xx-large"=20, "x-large"=18, "large"=16, "medium"=12, "small"=10, "x-small"=8, "xx-small"=6, as.integer(markup$size)))) return(fontList) } setReplaceMethod(".font", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, ..., value) { fname <- paste(as.character(date()),rnorm(1), sep="") ## some random string theArgs <- fontlistFromMarkup(value, fname) ## now call ## font with ttk is different -- fix XXX theFont = do.call("tkfont.create",theArgs) ret <- try(tkconfigure(getWidget(obj), font=fname), silent=TRUE) ## colors are different if("color" %in% names(value)) try(tkconfigure(getWidget(obj), foreground=value['color']), silent=TRUE) ## all done return(obj) }) ## tag, tag<- ## In RGtk2 we used the getData() and setData() methods. In tcltk we use the ## crummy implementation from rJava -- a list which grows without bound ## ## create namespace object ## tags = list() ## assignInNamespace("tags",list(),"gWidgetstcltk") ## ## clear out tags for this ID. Not exported. Is this used? ## Tagsclear = function(obj) { ## id = obj@ID ## tags = getFromNamespace("tags",ns="gWidgetstcltk") ## allKeys = names(tags) ## inds = grep(paste("^",id,"::",sep=""),allKeys) ## if(length(inds) == 0) ## return(NA) ## ## else ## tags[[inds]] <- NULL ## assignInNamespace("tags",tags,ns="gWidgetstcltk") ## } setMethod("tag",signature(obj="gWidgettcltk"), function(obj,i,drop=TRUE, ...) { if(missing(drop)) drop <- TRUE .tag(obj, obj@toolkit,i, drop=drop,...) }) ## dispatch in *this* toolkit, not present in obj setMethod("tag",signature(obj="tcltkObject"), function(obj,i,drop=TRUE, ...) { if(missing(drop)) drop <- TRUE .tag(obj, guiToolkit("tcltk"),i, drop=drop,...) }) setMethod(".tag", signature(toolkit="guiWidgetsToolkittcltk",obj="guiWidget"), function(obj, toolkit, i, drop=TRUE, ...) { if(missing(i)) i = NULL if(missing(drop)) drop <- TRUE .tag(obj@widget,toolkit, i, drop=drop, ...) }) setMethod(".tag", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, i, drop=TRUE, ...) { if(missing(i)) i = NULL if(missing(drop)) drop <- TRUE if(is.null(i)) return(as.list(obj@e)) else return(obj@e[[i]]) }) ## tag <- setReplaceMethod("tag",signature(obj="gWidgettcltk"), function(obj, i, replace=TRUE, ..., value) { .tag(obj, obj@toolkit,i,replace, ...) <- value return(obj) }) ## dispatch in *this* toolkit, not present in obj setReplaceMethod("tag",signature(obj="tcltkObject"), function(obj,i, replace=TRUE, ..., value) { .tag(obj, guiToolkit("tcltk"),i, replace, ...) <- value return(obj) }) ## objects can be in many different flavors: guiWIdget, gWidgettcltk, tcltkObject setReplaceMethod(".tag", signature(toolkit="guiWidgetsToolkittcltk",obj="guiWidget"), function(obj, toolkit, i, replace=TRUE, ..., value) { if(missing(i)) i = NULL .tag(obj@widget,toolkit, i, replace, ...) <- value return(obj) }) setReplaceMethod(".tag", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, i, replace=TRUE, ..., value) { if(missing(i)) i = NULL obj@e[[i]] <- value return(obj) }) ################################################## ## id -- define for "ANY" as well setMethod("id",signature(obj="gWidgettcltk"), function(obj, ...) { tag(obj,".tcltkID") }) setMethod("id",signature(obj="tcltkObject"), function(obj, ...) { tag(obj, ".tcltkID", ...) return(obj) }) setMethod("id",signature(obj="ANY"), function(obj, ...) { if(!is.null(theID<- attr(obj,"id"))) { return(theID) } else { if(is.character(obj)) { return(obj[1]) } else { dps = deparse(substitute(obj)) attr(obj,"id") <- dps return(dps) } } }) setMethod(".id", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ...) { tag(obj,".tcltkID", ...) }) setMethod(".id", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, ...) { return(tag(obj,".tcltkID")) }) ## id<- setReplaceMethod("id",signature(obj="gWidgettcltk"), function(obj, ..., value) { tag(obj,".tcltkID", ...) <- value return(obj) }) ## dispatch in *this* toolkit, not present in obj setReplaceMethod("id",signature(obj="tcltkObject"), function(obj, ..., value) { tag(obj, ".tcltkID", ...) <- value return(obj) }) setReplaceMethod("id",signature(obj="ANY"), function(obj, ..., value) { attr(obj,"id") <- value return(obj) }) ## we need a .id to handle dispatch from guiWidgets, otherwise, we use id() setReplaceMethod(".id", signature(toolkit="guiWidgetsToolkittcltk", obj="gWidgettcltk"), function(obj, toolkit, ..., value) { id(obj, ...) <- value return(obj) }) ## add method is biggie ## we have several levels of classes here guiWidget -- gWidgetRGkt -- tcltkObject, when ## we get down to that level we can finally add setMethod("add",signature(obj="gWidgettcltk"), function(obj, value, ...) { .add(obj, obj@toolkit,value,...) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="guiWidget", value="ANY"), function(obj, toolkit, value, ...) { gwCat(gettext("Can't add without a value\n")) }) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gWidgettcltk", value="try-error"), function(obj, toolkit, value, ...) { gmessage(paste("Error:",obj)) }) ## pushdonw setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="guiWidget", value="guiWidgetORgWidgettcltkORtcltkObject"), function(obj, toolkit, value, ...) { .add(obj@widget, toolkit, value, ...) }) ## for gWindow setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gContainertcltk", value="guiWidget"), function(obj, toolkit, value, ...) { .add(obj, toolkit, value@widget, ...) }) ## for gContainer setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk", obj="gContainertcltk",value="gWidgettcltk"), function(obj, toolkit, value, ...) { ## add parent, children childComponents <- obj@e$childComponents if(is.null(childComponents)) childComponents <- list() obj@e$childComponents <- c(childComponents, value) value@e$parentContainer <- obj ## inherit enabled from parent try(.enabled(value,toolkit) <- .enabled(obj,toolkit),silent=TRUE) theArgs = list(...) ## passed to do.call. Populate this argList = list(getBlock(value)) ## expand, fill, anchor ## XXX make expand option default to TRUE expand <- getWithDefault(theArgs$expand, getWithDefault(getOption("gw:tcltkDefaultExpand", FALSE))) ## fill horizontal <- obj@horizontal fill <- getWithDefault(theArgs$fill, ifelse(horizontal, "y", "x")) # FALSE, x, y, both=TRUE if(is.logical(fill)) { if(fill) fill <- "both" else fill <- NULL } ## the default anchor. -1,0 or W makes layouts nicer looking IMHO defaultAnchor <- getWithDefault(getOption("gw:tcltkDefaultAnchor"), c(-1, 0)) anchor <- xyToAnchor(getWithDefault(theArgs$anchor, defaultAnchor)) ## expand: if TRUE then can either anchor or fill. If if(!expand) { fill <- NULL } argList$expand <- expand argList$fill <- fill argList$anchor <- anchor if(obj@horizontal) argList$side = "left" else argList$side = "top" ## call tkpack do.call("tkpack",argList) tcl("update","idletasks") if(!is.null(widget <- .tag(obj,toolkit, "scrollable.widget"))) { ## get scrollbars to add to end etc. tcl("event","generate",getWidget(obj),"") tkxview.moveto(widget,1) tkyview.moveto(widget,1) } }) ##' Add method to incorporate tk widget into gui: ##' ##' @example ##' g = ggroup(cont=gwindow()) ##' library(tkrplot) ##' l = tkrplot(getToolkitWidget(g), function() hist(rnorm(100))) ##' add(g, l) setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gContainertcltk", value="tkwin"), function(obj, toolkit, value, ...) { tkpack(value, expand=TRUE, fill="both") }) ## addSPring, addSpace setMethod("addSpring",signature(obj="gWidgettcltk"), function(obj, ...) { .addSpring(obj, obj@toolkit,...) }) setMethod(".addSpring", signature(toolkit="guiWidgetsToolkittcltk",obj="gContainertcltk"), function(obj, toolkit, ...) { tt <- getBlock(obj) blankLabel <- ttklabel(tt,text=" ") if(obj@horizontal) { ## doesn't work! tkpack(blankLabel, expand=TRUE, fill="x", side="left") } else { tkpack(blankLabel, expand=TRUE, fill="y", side="top") } invisible() }) setMethod("addSpace",signature(obj="gWidgettcltk"), function(obj, value, ...) { .addSpace(obj,obj@toolkit,value,...) }) setMethod(".addSpace", signature(toolkit="guiWidgetsToolkittcltk",obj="gContainertcltk"), function(obj, toolkit, value, ...) { theArgs = list(...) horizontal = ifelse(is.null(theArgs$horizontal), TRUE, as.logical(theArgs$horizontal)) tt <- getBlock(obj) value = as.integer(value) if(horizontal) tkpack(ttklabel(tt, text=""),side="left",padx=value) else tkpack(ttklabel(tt, text=""),side="top", pady=value) invisible() }) ## delete -- get down to two tcltkObjects setMethod("delete",signature(obj="gWidgettcltk"), function(obj, widget, ...) { .delete(obj, obj@toolkit,widget,...) }) ## push down to tcltk vs tcltk. Can be 9 possiblities! setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk",obj="gContainertcltk",widget="guiWidget"), function(obj, toolkit, widget, ...) { .delete(obj, toolkit, widget@widget, ...) }) setMethod(".delete", signature(toolkit="guiWidgetsToolkittcltk",obj="gContainertcltk",widget="gWidgettcltk"), function(obj, toolkit, widget, ...) { ## call remove on container tkpack.forget(getBlock(widget)) }) ## dispose -- delete the parent window, or something else setMethod("dispose",signature(obj="gWidgettcltk"), function(obj, ...) { .dispose(obj, obj@toolkit,...) }) setMethod(".dispose", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, ...) { tcl("after",5,function() { tt <- getTopParent(getBlock(obj)) tkgrab.release(tt) tkdestroy(tt) }) # wait a pause }) ## update setMethod("update",signature(object="gWidgettcltk"), function(object, ...) { .update(object, object@toolkit, ...) }) setMethod(".update", signature(toolkit="guiWidgetsToolkittcltk",object="gComponenttcltk"), function(object, toolkit, ...) { missingMsg(".update");return() object@widget$QueueDraw() }) ## ## ################################################## ################################################## ## handlers. Also in aaaHandlers ## ## basic handler for adding with a signal. Not exported. setGeneric("addhandler", function(obj, signal, handler, action=NULL, ...) standardGeneric("addhandler")) setMethod("addhandler",signature(obj="guiWidget"), function(obj, signal, handler, action=NULL, ...) { .addhandler(obj@widget, obj@toolkit, signal, handler, action, ...) }) setMethod("addhandler",signature(obj="gWidgettcltk"), function(obj, signal, handler, action=NULL, ...) { .addhandler(obj, obj@toolkit, signal, handler, action, ...) }) setMethod("addhandler",signature(obj="tcltkObject"), function(obj, signal, handler, action=NULL, ...) { .addhandler(obj, guiToolkit("tcltk"), signal, handler, action, ...) }) ## method for dispatch setGeneric(".addhandler", function(obj, toolkit, signal, handler, action=NULL, ...) standardGeneric(".addhandler")) setMethod(".addhandler", signature(toolkit="guiWidgetsToolkittcltk",obj="guiWidget"), function(obj, toolkit, signal, handler, action=NULL, ...) { .addhandler(obj@widget, force(toolkit), signal, handler, action, ...) }) setMethod(".addhandler", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, signal, handler, action=NULL, ...) { .addHandler(obj, force(toolkit), signal, handler, action, ...) }) ## Make upcase for Handler setGeneric(".addHandler", function(obj, toolkit, signal, handler, action=NULL, ...) standardGeneric(".addHandler")) setMethod(".addHandler", signature(toolkit="guiWidgetsToolkittcltk",obj="guiWidget"), function(obj, toolkit, signal, handler, action=NULL, ...) { .addhandler(obj@widget, force(toolkit), signal, handler, action, ...) }) ## removew handler ## removehandler setMethod("removehandler", signature("gWidgettcltk"), function(obj, ID=NULL, ...) { .removehandler(obj, obj@toolkit, ID, ...) }) setMethod("removehandler", signature("tcltkObject"), function(obj, ID=NULL, ...) { .removehandler(obj, guiToolkit("tcltk"), ID, ...) }) ## in aaaHandlers ## setMethod(".removehandler", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), ## function(obj, toolkit, ID=NULL, ...) { ## ## ID here has two components ## type = ID[1] ## handlerID=as.character(ID[2]) ## ID = as.character(obj@ID) ## ## remove from list ## allHandlers = getFromNamespace("allHandlers",ns="gWidgetstcltk") ## ## is this a idleHandler ## if(type == "addIdleListener") { ## t = allHandlers[[ID]][[type]][[handlerID]]$timer ## t = .jcall(t,"V","stopTimer") ## } ## allHandlers[[ID]][[type]][[handlerID]]<-NULL ## ## now store the hash ## assignInNamespace("allHandlers",allHandlers,ns="gWidgetstcltk") ## }) ## blockhandler setMethod("blockhandler", signature("gWidgettcltk"), function(obj, ID=NULL, ...) { .blockhandler(obj, obj@toolkit, ID, ...) }) setMethod("blockhandler", signature("tcltkObject"), function(obj, ID=NULL, ...) { .blockhandler(obj, guiToolkit("tcltk"), ID, ...) }) ## setMethod(".blockhandler", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), ## function(obj, toolkit, ID=NULL, ...) { ## .blockhandler(getWidget(obj),toolkit,ID,...) ## }) ## setMethod(".blockhandler", ## signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), ## function(obj, toolkit, ID=NULL, ...) { ## gwCat(gettext("define block handler\n")) ## }) ## unblock handler setMethod("unblockhandler", signature("gWidgettcltk"), function(obj, ID=NULL, ...) { .unblockhandler(obj, obj@toolkit, ID, ...) }) setMethod("unblockhandler", signature("tcltkObject"), function(obj, ID=NULL, ...) { .unblockhandler(obj, guiToolkit("tcltk"), ID, ...) }) ## setMethod(".unblockhandler", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), ## function(obj, toolkit, ID=NULL, ...) { ## .blockhandler(getWidget(obj),toolkit,ID,...) ## }) ## setMethod(".unblockhandler", ## signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), ## function(obj, toolkit, ID=NULL, ...) { ## cat("define unblock handler\n") ## }) ## addhandlerchanged setMethod("addhandlerchanged",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerchanged(obj, obj@toolkit, handler, action, ...) }) setMethod("addhandlerchanged",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerchanged(obj, guiToolkit("tcltk"), handler, action, ...) }) setMethod("addhandlerchanged",signature(obj="ANY"), function(obj, handler=NULL, action=NULL, ...) { warning("No method addhandlerchanged for object of class",class(obj),"\n") }) setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) }) ## expose: expose-event or realize setMethod("addhandlerexpose",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerexpose(obj,obj@toolkit,handler, action, ...) }) setMethod("addhandlerexpose",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerexpose(obj, guiToolkit("tcltk"), handler, action, ...) }) setMethod(".addhandlerexpose", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) }) setMethod(".addhandlerexpose", signature(toolkit="guiWidgetsToolkittcltk",obj="gComponenttcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj,toolkit, signal="", handler=handler, action=action, ...) }) ## unrealize: unrealize setMethod("addhandlerunrealize",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerunrealize(obj, obj@toolkit,handler, action, ...) }) setMethod("addhandlerunrealize",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerunrealize(obj, guiToolkit("tcltk"),handler, action, ...) }) setMethod(".addhandlerunrealize", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) }) ## destroy: destroy setMethod("addhandlerdestroy",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerdestroy(obj, obj@toolkit,handler, action, ...) }) setMethod("addhandlerdestroy",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerdestroy(obj, guiToolkit("tcltk"),handler, action, ...) }) setMethod(".addhandlerdestroy", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) }) ## keystroke: changed setMethod("addhandlerkeystroke",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerkeystroke(obj, obj@toolkit,handler, action, ...) }) setMethod("addhandlerkeystroke",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerkeystroke(obj, guiToolkit("tcltk"),handler, action, ...) }) ## setMethod(".addhandlerkeystroke", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), ## function(obj, toolkit, ## handler, action=NULL, ...) { ## .addHandler(obj, toolkit, signal="", ## handler=handler, action=action, ...) ## }) ##' for gedit, gtext ##' ##' This uses the FUN argument for .addHandler to pass in a special function This way the arguments ##' that tcltk passes in can be used ##' ##' %K The keysym corresponding to the event, substituted as a textual string. Valid only for ##' KeyPress and KeyRelease events. ##' This handler can not be blocked or removed! ##' setMethod(".addhandlerkeystroke", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj,toolkit, handler=NULL, action=NULL,...) { .addHandler(obj,toolkit,"",handler,action, FUN = function(K) { h = list(obj = obj, action = action, key=K) runHandlers(obj, "", h, ...) ## handler(h) }) }) ## clicked: clicked setMethod("addhandlerclicked",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerclicked(obj, obj@toolkit,handler, action, ...) }) setMethod("addhandlerclicked",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerclicked(obj, guiToolkit("tcltk"),handler, action, ...) }) setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) }) ## doubleclick: no default setMethod("addhandlerdoubleclick",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerdoubleclick(obj,obj@toolkit,handler, action, ...) }) setMethod("addhandlerdoubleclick",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerdoubleclick(obj,guiToolkit("tcltk"),handler, action, ...) }) setMethod(".addhandlerdoubleclick", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) }) ## rightclick: button-press-event -- handle separately setMethod("addhandlerrightclick",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerrightclick(obj,obj@toolkit,handler, action, ...) }) setMethod("addhandlerrightclick",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerrightclick(obj,guiToolkit("tcltk"),handler, action, ...) }) setMethod(".addhandlerrightclick", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { if(windowingsystem() == "aqua" || grepl("^mac",.Platform$pkgType)) { id <- lapply(c("", "", ""), function(i) { id <- .addHandler(obj, toolkit, signal=i, handler=handler, action=action, ...) list(obj=obj, id=id, signal=i) # for remove/block/unblock }) } else { id <- .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) } invisible(id) }) ## focus setMethod("addhandlerfocus",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerfocus(obj,obj@toolkit,handler, action, ...) }) setMethod("addhandlerfocus",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerfocus(obj,guiToolkit("tcltk"),handler, action, ...) }) setMethod(".addhandlerfocus", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) }) ##' blur: blur should be focus out but is mouse out and focus out, so called twice! setMethod("addhandlerblur",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerblur(obj,obj@toolkit,handler, action, ...) }) setMethod("addhandlerblur",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlerblur(obj,guiToolkit("tcltk"),handler, action, ...) }) ##' blur is on mouse motion here and change in focus. Handle is called twice!!! setMethod(".addhandlerblur", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { IDs <- lapply(c("", ""), function(i) .addHandler(obj, toolkit, signal=i, handler=handler, action=action, ...) ) IDs }) ## mousemotion setMethod("addhandlermousemotion",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .addhandlermousemotion(obj,obj@toolkit,handler, action, ...) }) setMethod("addhandlermousemotion",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .addhandlermousemotion(obj,guiToolkit("tcltk"),handler, action, ...) }) setMethod(".addhandlermousemotion", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj, toolkit, signal="", handler=handler, action=action, ...) }) ## idle setMethod("addhandleridle",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, interval=1000, ...) { .addhandleridle(obj, obj@toolkit, handler=handler, action=action, interval=interval, ...) }) setMethod("addhandleridle",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, interval=1000, ...) { .addhandleridle(obj, guiToolkit("tcltk"), handler=handler, action=action, interval=interval, ...) }) ## addpopumenu ## ## this does not get exported .addPopupMenu = function(obj, menulist, action=NULL,...) { editPopupMenu <- getWidget(gmenu(menulist, popup=TRUE, action=action,container=obj, ...)) RightClick <- function(x,y) # x and y are the mouse coordinates { V = getWidget(obj) rootx <- as.integer(tkwinfo("rootx",V)) rooty <- as.integer(tkwinfo("rooty",V)) xTxt <- as.integer(x)+rootx yTxt <- as.integer(y)+rooty tcl("tk_popup",editPopupMenu,xTxt,yTxt) } tkbind(getWidget(obj), "",RightClick) } .add3rdMousePopupMenu = function(obj, menulist, action=NULL, ...) { editPopupMenu <- getWidget(gmenu(menulist, popup=TRUE, action=action,container=obj, ...)) RightClick <- function(x,y) # x and y are the mouse coordinates { V = getWidget(obj) rootx <- as.integer(tkwinfo("rootx",V)) rooty <- as.integer(tkwinfo("rooty",V)) xTxt <- as.integer(x)+rootx yTxt <- as.integer(y)+rooty tcl("tk_popup",editPopupMenu,xTxt,yTxt) } W <- getWidget(obj) if(isMac()) { tkbind(W, "", RightClick) tkbind(W, "", RightClick) } else { tkbind(W, "",RightClick) } } setMethod("addpopupmenu",signature(obj="gWidgettcltk"), function(obj, menulist, action=NULL, ...) { .addpopupmenu(obj, obj@toolkit,menulist, action, ...) }) setMethod("addpopupmenu",signature(obj="tcltkObject"), function(obj, menulist, action=NULL, ...) { .addpopupmenu(obj, guiToolkit("tcltk"), menulist, action, ...) }) ### setMethod(".addpopupmenu", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, menulist, action=NULL, ...) { .addPopupMenu(obj, menulist, action=action, ...) }) ## add3rdmousepopupmenu setMethod("add3rdmousepopupmenu",signature(obj="gWidgettcltk"), function(obj, menulist, action=NULL, ...) { .add3rdmousepopupmenu(obj, obj@toolkit,menulist, action, ...) }) setMethod("add3rdmousepopupmenu",signature(obj="tcltkObject"), function(obj, menulist, action=NULL,...) { .add3rdmousepopupmenu(obj, guiToolkit("tcltk"),menulist, action,...) }) setMethod(".add3rdmousepopupmenu", signature(toolkit="guiWidgetsToolkittcltk",obj="gWidgettcltk"), function(obj, toolkit, menulist,action=NULL, ...) { .add3rdMousePopupMenu(obj, menulist, action, ...) }) setMethod(".add3rdmousepopupmenu", signature(toolkit="guiWidgetsToolkittcltk",obj="tcltkObject"), function(obj, toolkit, menulist, action=NULL, ...) { .add3rdMousePopupMenu(obj, menulist, action, ...) }) ## "dotmethods" defined in dnd.R ## adddropsource setMethod("adddropsource",signature(obj="gWidgettcltk"), function(obj, targetType="text", handler=NULL, action=NULL, ...) { .adddropsource(obj, obj@toolkit,targetType=targetType, handler=handler, action=action, ...) }) setMethod("adddropsource",signature(obj="tcltkObject"), function(obj, targetType="text", handler=NULL, action=NULL, ...) { .adddropsource(obj, guiToolkit("tcltk"),targetType=targetType, handler=handler, action=action, ...) }) ## adddropmotion setMethod("adddropmotion",signature(obj="gWidgettcltk"), function(obj, handler=NULL, action=NULL, ...) { .adddropmotion(obj, obj@toolkit, handler=handler, action=action, ...) }) setMethod("adddropmotion",signature(obj="tcltkObject"), function(obj, handler=NULL, action=NULL, ...) { .adddropmotion(obj, guiToolkit("tcltk"), handler=handler, action=action, ...) }) ## adddroptarget setMethod("adddroptarget",signature(obj="gWidgettcltk"), function(obj, targetType="text", handler=NULL, action=NULL, ...) { .adddroptarget(obj, obj@toolkit,targetType=targetType, handler=handler, action=action, ...) }) setMethod("adddroptarget",signature(obj="tcltkObject"), function(obj, targetType="text", handler=NULL, action=NULL, ...) { .adddroptarget(obj, guiToolkit("tcltk"),targetType=targetType, handler=handler, action=action, ...) }) ## R Methods setMethod("dim", "gWidgettcltk", function(x) .dim(x,x@toolkit)) setMethod(".dim", signature(toolkit="guiWidgetsToolkittcltk",x="gWidgettcltk"), function(x,toolkit) { gwCat(sprintf("Define dim for x of class: %s", class(x)[1])) return(NULL) }) setMethod("length", "gWidgettcltk", function(x) .length(x,x@toolkit)) setMethod(".length", # signature(toolkit="guiWidgetsToolkittcltk"), signature(toolkit="ANY",x="ANY"), function(x,toolkit) { # gwCat(sprintf("Define length for x of class:%s\n"),class(x)[1]) #return(NULL) # message("calling length for class", class(x)[1]) return(NA) }) setMethod("dimnames", "gWidgettcltk", function(x) .dimnames(x,x@toolkit)) setReplaceMethod("dimnames", signature(x="gWidgettcltk"), function(x,value) { .dimnames(x,x@toolkit) <- value return(x) }) ## as of 2.5.0 this became primiive if(as.numeric(R.Version()$major) <= 2 & as.numeric(R.Version()$minor) <= 4.1) { setGeneric("names") setGeneric("names<-") } setMethod("names", "gWidgettcltk", function(x) .names(x,x@toolkit)) setReplaceMethod("names", signature(x="gWidgettcltk"), function(x,value) { .names(x,x@toolkit) <- value return(x) }) gWidgetstcltk/R/gvarbrowser.R0000644000176000001440000001642611646163642016032 0ustar ripleyusers## Use this to filter by type ## knownTypes in common ### Use this for filtering by (gvarbrowser, gvarbrowsertree) .datasets = c( "numeric","logical","factor","character", "data.frame","matrix","list", "table","xtabs", "nfnGroupedData","nffGroupedData","nmGroupedData" ) .models = c("lm","glm","lqs","aov","anova", "lme","lmList","gls", "ar","arma","arima0","fGARCH","fAPARCH" ) .ts = c("ts", "mts", "timeSeries", "its", "zoo") .functions=c("function") .plots = c("recordedplot") knownTypes = list( "data sets and models"=c(.datasets, .models, .ts), "data sets"= c(.datasets,ts), "model objects" = .models, "time series objects" = .ts, "functions"=.functions, "saved plots" = .plots, "all" = NULL ) ## list of some type lsType = function(type, envir=.GlobalEnv) { x = with(.GlobalEnv, sapply(ls(), function(i) class(get(i)))) objects = names(x)[sapply(x, function(i) any(i %in% type))] return(objects) } lsDatasets = function(envir=.GlobalEnv) lsType(.datasets, envir) lsModels = function(envir=.GlobalEnv) lsType(.models, envir) lsTs = function(envir=.GlobalEnv) lsType(.ts, envir) lsFunctions = function(envir=.GlobalEnv) lsType(.functions, envir) offspring = function(path=c(), data=NULL) { if(length(path) == 0) { x = ls(envir=.GlobalEnv) if(length(x) == 0) { return(data.frame(names="",hasSubTree=FALSE,type="")) } type = c();hasTree=c() for(i in 1:length(x)) { y = getObjectFromString(x[i]) type[i] = str2(y) hasTree[i] = hasSubTree(y) } } else { string = paste(path,collapse="$") obj = getObjectFromString(string) x = with(obj, ls()) if(length(x) == 0) { return(data.frame(names="",hasSubTree=FALSE,type="")) } type = c();hasTree=c() for(i in 1:length(x)) { y = getObjectFromString(paste(string,x[i],sep="$")) type[i] = str2(y) hasTree[i] = hasSubTree(y) } } allValues = data.frame(names=I(x), hasSubTree=hasTree, type=I(type)) if(!is.null(data)) { return(allValues[allValues$type %in% data, ,drop=FALSE]) } else { return(allValues) } } hasSubTree = function(x) { tmp = try(is.list(x) && ## !is.guiWidget(x) && !is.gWidget(x) && !is.null(names(x)), silent=TRUE) if(!inherits(tmp,"try-error") && tmp) return(TRUE) else return(FALSE) } ## in common.R ## getObjectFromString = function(string, envir=.GlobalEnv) { ## out = try(eval(parse(text=string), envir=envir), silent=TRUE) ## if(inherits(out, "try-error")) ## return(NA) ## return(out) ## } setClass("gVarbrowsertcltk", representation(filter="guiComponent"), contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) ## THe main object setMethod(".gvarbrowser", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, handler = NULL, action = "summary", container = NULL, ...) { force(toolkit) ## fix handler if action is non-null if(is.null(handler) && !is.null(action)) { handler = function(h, ...) { values = h$obj[] value = paste(values, collapse = "$") if (!is.null(action)) print(do.call(h$action, list(svalue(value)))) } } ## begin group <- ggroup(horizontal=FALSE, container=container,...) filterGroup <- ggroup(container=group) glabel("Filter by:",container=filterGroup) filterPopup <- gdroplist(names(knownTypes), container=filterGroup) svalue(filterPopup) <- "data sets" ## main tree tree <- gtree(offspring=offspring, offspring.data=knownTypes[[svalue(filterPopup)]], col.types=data.frame(Name="string",Type="string"), icon.FUN = function(d,...) { .treeByReturnVector(d,function(x) stockIconFromClass(x[,'type'])) }, container = group, expand=TRUE ) obj <- new("gVarbrowsertcltk",block=group, widget=tree, filter=filterPopup, toolkit=toolkit,ID=getNewID(), e = new.env()) gbutton("update", container=group, align=c(-1,0), action=obj, handler=function(h,...) { update(h$action) }) ## update the tree this way addhandlerclicked(filterPopup, handler = function(h,...) { key = svalue(filterPopup) offspring.data = knownTypes[[key]] update(h$action, offspring.data = offspring.data) }, action=tree) ## ## add an idle handler for updating tree every second ## idleid = addhandleridle(tree, interval=5000, handler = function(h,...) { ## key = svalue(filterPopup) ## offspring.data = knownTypes[[key]] ## update(h$obj, offspring.data = offspring.data) ## }) ## addhandlerunrealize(tree, handler = function(h,...) { ## removeHandler(h$obj, h$action) ## },action=idleid) # tag(obj, "idle.id") <- idleid # To remove ## removeHandler(obj@widget, tag(obj, "idle.id")) ## drop handler adddropsource(tree,handler=function(h,...) { values = h$obj[] values = sapply(values, untaintName) return(paste(values,collapse="$")) }) if(!is.null(handler)) { id <- addhandlerdoubleclick(tree, handler=handler, action=action) tag(obj, "handler.id") <- id } ## all done return(obj) }) ### methods ## push methods and handlers down to tree in this case setMethod(".update", signature(toolkit="guiWidgetsToolkittcltk",object="gVarbrowsertcltk"), function(object,toolkit,...) { tree <- object@widget@widget filterPopup <- object@filter offspring.data <- knownTypes[[svalue(filterPopup)]] .update(tree, toolkit, offspring.data=offspring.data) }) setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gVarbrowsertcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { values = obj@widget[] # from tree value = paste(values, collapse = "$") return(value) }) setMethod("[", signature(x="gVarbrowsertcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x,guiToolkit("tcltk"), i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gVarbrowsertcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { if(missing(i)) x@widget[...] else x@widget[i,...] }) gWidgetstcltk/R/ggroup.R0000644000176000001440000001533011704342472014756 0ustar ripleyusers## class in aaaClasses.R ## constructor setMethod(".ggroup", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, horizontal = TRUE, spacing = 5, use.scrollwindow = FALSE, container = NULL, ... ) { force(toolkit) theArgs = list(...) # raise.on.dragmotion if(is.null(spacing)) spacing = 0 if(is.null(container)) { message(gettext("No NULL containers in tcltk. Creating a new window\n")) container=gwindow() } else if(is.logical(container) && container) { container = gwindow() } if(!is(container,"guiWidget")) { container = gwindow() } tt <- getWidget(container) ## implement scrollbars if asked. ## XXX Not quite working as desired... if(use.scrollwindow == TRUE && windowingsystem() != "aqua") { ## cf http://mail.python.org/pipermail/python-list/1999-June/005180.html block <- ttkframe(tt) ## put in one direction only widget <- tkcanvas(block) if(horizontal) { xscr <- ttkscrollbar(block, orient="horizontal", command=function(...)tkxview(widget,...)) tkconfigure(widget, xscrollcommand = function(...) tkset(xscr,...)) ## Pack into a grid ## see tkFAQ 10.1 -- makes for automatic resizing tkgrid(widget,row=0,column=0, sticky="news") tkgrid(xscr, row=1, column=0, sticky="ew") tkgrid.rowconfigure(block, 0, weight=1) tcl("autoscroll::autoscroll", xscr) } else { yscr <- ttkscrollbar(block, command=function(...)tkyview(widget,...)) tkconfigure(widget, yscrollcommand = function(...) tkset(yscr,...)) ## Pack into a grid ## see tkFAQ 10.1 -- makes for automatic resizing tkgrid(widget,row=0,column=0, sticky="news") tkgrid(yscr,row=0,column=1, sticky="ns") tkgrid.columnconfigure(block, 0, weight=1) tcl("autoscroll::autoscroll", yscr) } ## Set up frame gp <- ttkframe(widget) gpID <- tcl(widget,"create","window",0,0,anchor="nw",window=gp) tkgrid.columnconfigure(widget,0,weight=1) tkgrid.rowconfigure(widget,0,weight=1) ## give an initial size # gpwidth <- getWithDefault(theArgs$width, 300) # gpheight <- getWithDefault(theArgs$height, 300) # if(horizontal) # tkitemconfigure(widget, gpID, height=gpheight) # else # tkitemconfigure(widget, gpID, width=gpwidth) tcl("update","idletasks") ## tkbind(widget,"",function() { ## bbox <- tcl(widget,"bbox","all") ## tcl(widget,"config",scrollregion=bbox) ## }) tkbind(block, "", function() { if(horizontal) { width <- tkwinfo("width", block) tkconfigure(widget, width=width) } else { height <- tkwinfo("height", block) tkconfigure(widget, height=height) } }) tkbind(gp, "", function() { if(horizontal) { tkconfigure(widget, height=tkwinfo("height", gp)) } else { tkconfigure(widget, width=tkwinfo("width", gp)) } }) tkbind(gp,"",function() { bbox <- tcl(widget,"bbox","all") tcl(widget,"config",scrollregion=bbox) }) tkbind(widget, "", function(W) { width <- as.numeric(tkwinfo("width", W)) height <- as.numeric(tkwinfo("height", W)) # gpwidth <- as.numeric(tkwinfo("width", gp)) # gpheight <- as.numeric(tkwinfo("height", gp)) gpwidth <- as.numeric(tkwinfo("width", block)) gpheight <- as.numeric(tkwinfo("height", block)) if(gpwidth < width && !horizontal) tkitemconfigure(widget, gpID, width=width) if(gpheight < height && horizontal) tkitemconfigure(widget, gpID, height=height) }) } else { gp <- ttkframe(tt) tkconfigure(gp, borderwidth=0) # XXX block <- gp widget <- NULL # for later } tkconfigure(gp, padding=spacing) if(!is.null(theArgs$debug)) { theArgs$debug <- NULL tkconfigure(gp,borderwidth=4, relief="solid") } obj = new("gGrouptcltk",block=block, widget=gp, horizontal=horizontal, e = new.env(), ID=getNewID(), toolkit=toolkit ) ## to move widget when scrolling ## if(!is.null(widget <- tag(value,"scrollable.widget"))) { ## tkxview.moveto(widget,1) ## tkyview.moveto(widget,1) ## } .tag(obj,toolkit, i="scrollable.widget") <- widget obj@e$i <- widget ## attach to container if there if(!is.null(container)) { theArgs$obj <- container theArgs$value <- obj do.call("add", theArgs) } ## raise if we drag across if(!is.null(theArgs$raise.on.dragmotion)) { # tkbind(gp, "", function(W) { # tkfocus(W) # }) } return(obj) }) ################################################## ## methods setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gGrouptcltk"), function(obj, toolkit, index=NULL, drop=NULL, ..., value) { ## adds some breathing room to object ## value is pixels gp <- getWidget(obj) # tkcofigure(gp,padx=value,pady=value) tkconfigure(gp,padding = value) return(obj) }) ################################################## ## handlers gWidgetstcltk/R/gbutton.R0000644000176000001440000001172011511107632015125 0ustar ripleyuserssetClass("gButtontcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setMethod(".gbutton", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="", border = TRUE, handler=NULL, action=NULL, container=NULL,... ) { force(toolkit) theArgs <- list(...) ## look like label if border=FALSE if(border == FALSE) { return(glabel(text,handler,action,container,...)) } ## compound is tcltk speak for where to put icon. One of ## top, left, right or bottom ## http://search.cpan.org/~ni-s/Tk-804.027/pod/Button.pod if(is.null(theArgs$compound)) compound <- "left" else compound <- theArgs$compound if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } tt = getWidget(container) icon <- findIcon(text) if(icon == "") { ## not stock button <- ttkbutton(tt, text=text) } else { button <- ttkbutton(tt, text=text, image=icon, compound=compound) } obj <- new("gButtontcltk", block=button, widget=button, toolkit=toolkit,ID=getNewID(), e = new.env()) ## add gp to container add(container, obj, ...) ## add handler if (!is.null(handler)) tag(obj,"handler.id") <- addhandlerchanged(obj,handler,action) invisible(obj) }) ## handle gaction ## constructor for action=gaction_instance setMethod(".gbutton",signature(action="guiComponent", toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="", border = TRUE, handler=NULL, action=NULL, container=NULL,... ) { .gbutton(toolkit, text = text, border=border, handler = handler, action = action@widget, container = container, ...) }) ## constructor for action=gaction_instance setMethod(".gbutton",signature(action="gActiontcltk", toolkit="guiWidgetsToolkittcltk"), function(toolkit, text="", border = TRUE, handler=NULL, action=NULL, container=NULL,... ) { alst <- action@widget obj <- .gbutton(toolkit, text = alst$label, border = border, handler = alst$handler, action = alst$action, container = container, ...) if(!is.null(alst$tooltip)) .tooltip(obj,toolkit) <- alst$tooltip action@e$buttons <- c(action@e$buttons,obj) return(obj) }) ### methods setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gButtontcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { val = paste(as.character(tkcget(getWidget(obj),"-text")), sep=" ",collapse=" ") return(val) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gButtontcltk"), function(obj, toolkit, index=NULL, ..., value) { widget <- getWidget(obj) text = as.character(value) tkconfigure(widget, text=text) imageID <- findIcon(text) ## "" if not stcok if(imageID != "") tkconfigure(widget, image=imageID) else tkconfigure(widget, image="") return(obj) }) ## size has no height setReplaceMethod(".size", signature(toolkit="guiWidgetsToolkittcltk",obj="gButtontcltk"), function(obj, toolkit, ..., value) { width <- ceiling(value[1]/widthOfChar) tkconfigure(getWidget(obj), width=width) return(obj) }) ### handlers setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gButtontcltk"), function(obj, toolkit, handler, action=NULL, ...) { # ID <- .addHandler(obj,toolkit,"", handler, action) ID <- .addHandler(obj,toolkit,"command", handler, action) return(ID) }) setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gButtontcltk"), function(obj, toolkit, handler, action=NULL, ...) { addhandlerclicked(obj, handler, action) }) gWidgetstcltk/R/gaction.R0000644000176000001440000001054212022213303015057 0ustar ripleyusers## reusuabel chunk of code setClass("gActiontcltk", representation(widget="list",e = "environment"), prototype(widget=list(), e = new.env()) ) setMethod(".tag", signature(toolkit="guiWidgetsToolkittcltk",obj="gActiontcltk"), function(obj, toolkit, i, drop=TRUE, ...) { if(missing(i)) i = NULL if(missing(drop)) drop <- TRUE if(is.null(i)) return(as.list(obj@e)) else return(obj@e[[i]]) }) setReplaceMethod(".tag", signature(toolkit="guiWidgetsToolkittcltk",obj="gActiontcltk"), function(obj, toolkit, i, replace=TRUE, ..., value) { if(missing(i)) i = NULL obj@e[[i]] <- value return(obj) }) setMethod(".gaction", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, label, tooltip = NULL, icon = NULL, key.accel = NULL, handler = NULL, action = NULL, parent=NULL, ...) { force(toolkit) lst <- list(label = label, tooltip = tooltip, icon = icon, key.accel = key.accel, handler = handler, action = action) e <- new.env(); e$state <- TRUE; e$buttons <- e$menuitems <- e$toolbaritems <- list() e$label <- label obj <- new("gActiontcltk", widget = lst, e =e) if(!is.null(key.accel) && !is.null(parent)) { toplevel <- tkwinfo("toplevel", getWidget(parent)) tkbind(toplevel, sprintf("<%s>",key.accel), function() { if(obj@e$state) { h <- list(action=action) handler(h) } }) } return(obj) }) setMethod(".getToolkitWidget", signature(obj="gActiontcltk", toolkit="guiWidgetsToolkittcltk"), function(obj, toolkit) obj@widget) ## is this a gaction .isgAction <- function(obj) { is(obj,"guiComponent") && is(obj@widget,"gActiontcltk") } ## methods need to be disabled setReplaceMethod(".enabled", signature(toolkit="guiWidgetsToolkittcltk",obj="gActiontcltk"), function(obj, toolkit, ..., value) { e <- obj@e e$state <- as.logical(value) if(length(e$buttons) > 0) lapply(e$buttons, function(i) enabled(i) <- as.logical(value)) if(length(e$toolbaritems) > 0) lapply(e$toolbaritems, function(i) { if(as.logical(value)) tkconfigure(i,state="normal") else tkconfigure(i, state = "disabled") }) if(length(e$menuitems) > 0) lapply(e$menuitems, function(i) { if(as.logical(value)) tcl(i,"entryconfigure",e$label,state="normal") else tcl(i,"entryconfigure",e$label,state="disabled") }) return(obj) }) setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gActiontcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { val <- obj@widget$label return(val) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gActiontcltk"), function(obj, toolkit, index=NULL, ..., value) { e <- obj@e if(length(e$buttons) > 0) lapply(e$buttons, function(i) svalue(i) <- as.character(value)) if(length(e$toolbaritems) > 0) lapply(e$toolbaritems, function(i) { tkconfigure(i, text=value) }) if(length(e$menuitems) > 0) lapply(e$menuitems, function(i) { tcl(i,"entryconfigure",e$label,label=value) }) return(obj) }) gWidgetstcltk/R/gcheckboxgroup.R0000644000176000001440000001566311611714017016471 0ustar ripleyusers## build widget based on gcheckbox setClass("gCheckboxgrouptcltk", representation = representation("gComponentR5tcltk", coercewith="NULLorFunction"), contains="gComponentR5tcltk", prototype=prototype(new("gComponentR5tcltk")) ) setMethod(".gcheckboxgroup", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, items, checked = FALSE, horizontal=FALSE, use.table=FALSE, handler = NULL, action = NULL, container = NULL, ...) { force(toolkit) if(missing(items) || length(items) == 0) stop("Need items to be a vector of items") if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning(gettext("Container is not correct. No NULL containers possible\n" )) return() } if(use.table) { obj <- .gcheckboxgrouptable(toolkit, items=items, checked=checked, handler=handler, action=action, container=container, ...) return(obj) } theArgs = list(...) if(!is.null(theArgs$coerce.with)) { coerce.with = theArgs$coerce.with } else { if(is.numeric(items)) coerce.with = as.numeric else coerce.with = as.character } if(is.character(coerce.with)) coerce.with = get(coerce.with) tt = getWidget(container) cbg_widget <- getRefClass("CheckButtonGroup")$new(parent=tt, items=items, selected=checked, horizontal=horizontal) obj <- new("gCheckboxgrouptcltk", block=cbg_widget$get_widget(), widget=cbg_widget$get_widget(), R5widget=cbg_widget, toolkit=toolkit, coercewith = coerce.with, e = new.env()) svalue(obj) <- checked ## add to container add(container, obj,...) ## add handler if(!is.null(handler)) tag(obj, "handler.id") <- addhandlerchanged(obj, handler, action) invisible(obj) }) ### methods ## setMethod(".svalue", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgrouptcltk"), ## function(obj, toolkit, index=NULL, drop=NULL, ...) { ## cbg_widget <- obj@R5widget ## index <- getWithDefault(index, FALSE) ## if(index) { ## return(cbg_widget$get_index()) ## } else { ## val <- cbg_widget$get_value() ## if(!is.null(obj@coercewith)) ## return(obj@coercewith(val)) ## else ## return(val) ## } ## }) ## toggles state to be T or F setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgrouptcltk"), function(obj, toolkit, index=NULL, ..., value) { cbg_widget <- obj@R5widget index <- getWithDefault(index, FALSE) if(index) { cbg_widget$set_index(value) } else if(is.logical(value)) { n <- length(obj) value <- rep(value, length.out=n) cbg_widget$set_index(which(value)) } else { cbg_widget$set_value(value) } return(obj) }) ## [ and [<- refer to the names -- not the TF values ## setMethod("[", ## signature(x="gCheckboxgrouptcltk"), ## function(x, i, j, ..., drop=TRUE) { ## .leftBracket(x, x@toolkit, i, j, ..., drop=drop) ## }) ## setMethod(".leftBracket", ## signature(toolkit="guiWidgetsToolkittcltk",x="gCheckboxgrouptcltk"), ## function(x, toolkit, i, j, ..., drop=TRUE) { ## cbg_widget <- x@R5widget ## items <- cbg_widget$get_items() ## if(missing(i)) ## items ## else ## items[i] ## }) ## assigns names ## setReplaceMethod("[", ## signature(x="gCheckboxgrouptcltk"), ## function(x, i, j,..., value) { ## .leftBracket(x, x@toolkit, i, j, ...) <- value ## return(x) ## }) ## setReplaceMethod(".leftBracket", ## signature(toolkit="guiWidgetsToolkittcltk",x="gCheckboxgrouptcltk"), ## function(x, toolkit, i, j, ..., value) { ## cbg_widget <- x@R5widget ## if(!missing(i)) { ## items <- cbg_widget$get_items() ## items[i] <- value ## value <- items ## } ## cbg_widget$set_items(value) ## return(x) ## }) ## setMethod(".length", ## signature(toolkit="guiWidgetsToolkittcltk",x="gCheckboxgrouptcltk"), ## function(x,toolkit) { ## cbg_widget <- x@R5widget ## cbg_widget$no_items() ## # length(tag(x,"items")) ## }) ## ## inherited enabled isn't workgin ## setReplaceMethod(".enabled", ## signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgrouptcltk"), ## function(obj, toolkit, ..., value) { ## cbg_widget <- obj@R5widget ## cbg_widget$set_enabled(value) ## return(obj) ## }) ## This handler code is common to gradio and gcheckboxgroup. Should abstract out into a superclass. ## IF we do that, we should also use CheckButton bit setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgrouptcltk"), function(obj, toolkit, handler, action=NULL, ...) { cbg_widget <- obj@R5widget user.data=list(obj=obj, handler=handler, action=action) ## id <- cbg_widget$add_handler("", id <- cbg_widget$add_handler("command", handler=function(user.data) { h <- user.data[c("obj", "action")] user.data$handler(h) }, user.data=user.data) invisible(id) }) ## clicked is changed setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gCheckboxgrouptcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerclicked(obj, toolkit, handler, action, ...) }) gWidgetstcltk/R/gdroplist.R0000644000176000001440000002424012103734633015460 0ustar ripleyusers## editable has entry widget that can be edited setClass("gDroplisttcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setMethod(".gdroplist", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, items, selected = 1, # use 0 for blank editable=FALSE, coerce.with = NULL, handler=NULL, action=NULL, container=NULL, ... # do.quote = TRUE for quote of answer ) { force(toolkit) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } ## items can be vector of items or data frame with ## one col: items ## two cols: items, icons ## three cols: items, icons, tooltip ## four or more cols: toolkit specific if(inherits(items,"data.frame")) { items <- items[,1, drop=TRUE] } ## no icons, tooltip in tcltk ## items must be a vector here items = as.vector(items) # undoes factor items = unique(items) # unique theArgs = list(...) ## keep this, but don't advertise if(!is.null(theArgs$do.quote)) { coerce.with = function(x) paste("'",x,"'",sep="") # no space } if(editable) state <- "normal" else state <- "readonly" if(!is.null(theArgs$width)) width <- theArgs$width else if(length(items)) width <- max(sapply(items,nchar)) + 5 else width <- NULL tt <- getWidget(container) gp <- ttkframe(tt) cbVar <- tclVar() if(length(items) == 1) values <- as.tclObj(as.character(items)) else values <- as.character(items) cb <- ttkcombobox(gp, values = values, textvariable = cbVar, state = state) if(!is.null(width)) tkconfigure(cb, width=width) tkgrid(cb,row=0, column=0, sticky="we") # stretch horizontally. Use news for both tkgrid.columnconfigure(gp,0, weight=1) obj = new("gDroplisttcltk",block=gp,widget=cb, toolkit=toolkit,ID=getNewID(), e = new.env()) tag(obj,"coerce.with") <- coerce.with tag(obj,"editable") <- editable tag(obj,"tclVar") <- cbVar tag(obj,"items") <- items addDropTarget(obj, handler = function(h,...) svalue(obj) <- h$dropdata) add(container, obj, ...) if(!is.null(theArgs$width)) size(obj) <- c(theArgs$width,0) ## can add numeric or for Richie, a value if(is.numeric(selected)) { svalue(obj, index = TRUE) <- selected } else { svalue(obj) <- as.character(selected) } if (!is.null(handler)) { id <- addhandlerchanged(obj, handler, action) tag(obj, "handler.id") <- id } invisible(obj) }) ### methods ## value is for getting/setting the selected value setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gDroplisttcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { widget <- getWidget(obj) ind <- as.numeric(tclvalue(tcl(widget, "current"))) + 1 # 0-based ## if index if(!is.null(index) && index) { return(ind) } editable <- as.character(tkcget(widget, "-state")) != "readonly" if(editable) { val <- tclvalue(tcl(widget,"get")) } else { if(ind == 0) { ## no selection return(NA) } ## else get values from items -- not get to avoid conversion items <- tag(obj,"items") val <- items[ind] } ## add in an as.numeric flag, getwidget when editable theArgs = list(...) # deprecated coerce.with = tag(obj, "coerce.with") ## do we coerce return value? if(is.null(coerce.with)) return(val) else if(is.function(coerce.with)) return(coerce.with(val)) else if(is.character(coerce.with)) return(do.call(coerce.with,list(val))) else return(val) # what else? }) ## set the displayed value to value ## if index=TRUE and value=0, seet to no state setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gDroplisttcltk"), function(obj, toolkit, index=NULL, ..., value) { ## we can only handle vectors for value -- not data frame ## with value, label, icon info theArgs = list(...) widget <- getWidget(obj) tclVar <- tag(obj, "tclVar") n <- length(obj) if(n < 1) return(obj) if(is.null(index)) index <- FALSE index <- as.logical(index) ## if editable do differently ## editable not implented editable <- as.character(tkcget(widget, "-state")) != "readonly" ## if index, set if(index) { if(value > 0 && value <= n) tcl(widget,"current", as.numeric(value) - 1) else # set to no state tclvalue(tclVar) = "" ##tcl(widget,"set", "") # aka -1 for get } else { if(!is.null(editable) && editable) { ## editable tclvalue(tcl(widget,"set",as.character(value))) } else { ## not editable, check its there vals <- tag(obj,"items") if(value %in% vals) { tclvalue(tcl(widget,"set",as.character(value))) } else { message(sprintf("%s is not a valid item",value),"\n") } } } ## notify event handlers unless set to 0 if(!(index && value < 0)) tkevent.generate(getWidget(obj), "<>") return(obj) }) setMethod("length", signature(x="gDroplisttcltk"), function(x) { .length(x, x@toolkit) }) setMethod(".length", signature(toolkit="guiWidgetsToolkittcltk",x="gDroplisttcltk"), function(x, toolkit) { return(length(tag(x,"items"))) }) ## the methods [ and [<- refer to the pre-defined values in the drop list. ## [ setMethod("[", signature(x="gDroplisttcltk"), function(x, i, j, ..., drop=TRUE) { .leftBracket(x, x@toolkit, i, j, ..., drop=drop) }) setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gDroplisttcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { n = length(x) # no. items if(n == 0) character(0) # Thanks Yves items = tag(x,"items") if(missing(i)) return(items) else return(items[i]) }) ## replaces the values in droplist ## values is a vector of values -- not a dataframe #set.values.gDropList = function(obj, values, ...) { setReplaceMethod("[", signature(x="gDroplisttcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gDroplisttcltk"), function(x, toolkit, i, j, ..., value) { if(is.data.frame(value)) value <- value[,1,drop=TRUE] widget <- getWidget(x) ind <- svalue(x, index=TRUE) if(missing(i)) { if(length(value) == 1) tcl(widget,"configure",values=as.tclObj(value)) else tcl(widget,"configure",values=value) tag(x,"items") <- value if(ind > 0) svalue(x, index=TRUE) <- ind } else { items = x[] items[i] <- value x[] <- items ## recurse } return(x) }) ################################################### ### handlers setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gDroplisttcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addHandler(obj,toolkit,"<>",handler,action,...) editable <- as.character(tkcget(getWidget(obj), "-state")) != "readonly" if(editable) ## tag(obj,"editable")) .addHandler(obj, toolkit, signal="", handler, action) }) setMethod(".addhandlerclicked", signature(toolkit="guiWidgetsToolkittcltk",obj="gDroplisttcltk"), function(obj, toolkit, handler, action=NULL, ...) { .addhandlerchanged(obj,toolkit, handler,action) }) gWidgetstcltk/R/ghtml.R0000644000176000001440000000202411604711402014552 0ustar ripleyusers## Copyright (C) 2010 John Verzani ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## A copy of the GNU General Public License is available at ## http://www.r-project.org/Licenses/ ##' Should be basic html display widget ##' not implemented setMethod(".ghtml", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, x, handler = NULL, action=NULL, container=NULL, ...) { message("The ghtml widget is not implemented in gWidgetstcltk") return(NULL) }) gWidgetstcltk/R/gdfnotebook.R0000644000176000001440000000173611646163460015764 0ustar ripleyuserssetClass("gDfNotebooktcltk", representation = representation( gnotebook="guiWidget" ), contains="gNotebooktcltk" ) setMethod(".gdfnotebook", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, items = NULL, container = NULL, ... # passed to Group, gnotebook = nb, # notebook = nb$notebook) ) { force(toolkit) return(glabel("gdfnotebook not available", container=container)@widget) }) ################################################## ## ## gWidgetMethods (inherits others from gnotebook ## object is name of R object *or* file ## REWRITE me to dispatch on value. This first part is ugly and broken setMethod(".add", signature(toolkit="guiWidgetsToolkittcltk",obj="gDfNotebooktcltk"), function(obj, toolkit, value, ...) { }) gWidgetstcltk/R/gslider.R0000644000176000001440000001227412102501554015077 0ustar ripleyusers## FIX up for non-integer values setClass("gSlidertcltk", contains="gComponenttcltk", prototype=prototype(new("gComponenttcltk")) ) setMethod(".gslider", signature(toolkit="guiWidgetsToolkittcltk"), function(toolkit, from=0, to=100, by = 1, value=from, horizontal=TRUE, handler=NULL, action=NULL, container=NULL, ...) { force(toolkit) ## if from a single value, then from, to ,by specify sequence if(length(from) == 1) x <- seq(from, to, by) else x <- from ## x needs sorting, make unique x <- sort(unique(x)) # do I need to do for different types ind <- seq_along(x) value <- which(as.character(value) == as.character(x)) if(is(container,"logical") && container) container = gwindow() if(!is(container,"guiWidget")) { warning("Container is not correct. No NULL containers possible\n" ) return() } if(horizontal) orientation <- "horizontal" else orientation <- "vertical" tt <- getWidget(container) SliderValue <- tclVar(as.character(value)) ## ## use old school. ttk:::scale doesn't allow steps, using other values. ## slider <- tkscale(tt, from=1L, to=length(x), ## showvalue=FALSE, variable=SliderValue, ## resolution=1L, orient=orientation) slider <- tkwidget(tt, "ttk::scale", from=1L, to=length(x), variable=SliderValue, orient=orientation) obj <- new("gSlidertcltk",block=slider, widget=slider, toolkit=toolkit, ID=getNewID(), e = new.env()) tag(obj,"..tclVar") <- SliderValue tag(obj, "..byIndexValues") <- x ## ## modify label ## modifyLabel <- function() { ## tkconfigure(slider, label=format(svalue(obj), digts=3)) ## } ## modifyLabel() ## tkbind(slider, "", modifyLabel) add(container, obj,...) if (!is.null(handler)) { id <- addhandlerchanged(obj, handler, action) } return(obj) }) ### methods setMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gSlidertcltk"), function(obj, toolkit, index=NULL, drop=NULL, ...) { rbValue = tag(obj,"..tclVar") val <- as.numeric(tclvalue(rbValue)) if(is.null(index) || !index) { x <- tag(obj, "..byIndexValues") val <- x[val] } return(val) }) setReplaceMethod(".svalue", signature(toolkit="guiWidgetsToolkittcltk",obj="gSlidertcltk"), function(obj, toolkit, index=NULL, ..., value) { ## can set by index or match if(is.null(index) || index==FALSE) { value <- match(value, tag(obj, "..byIndexValues")) } else { value <- value } n <- length(tag(obj, "..byIndexValues")) if(!is.na(value) && value >= 1 && value <= n) tclvalue(tag(obj,"..tclVar")) <- value ## ## update label ## tkconfigure(getWidget(obj), label=format(svalue(obj), digts=3)) return(obj) }) ##' return values setMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gSlidertcltk"), function(x, toolkit, i, j, ..., drop=TRUE) { tag(x, "..byIndexValues") }) ## Method to replace values of spin button setReplaceMethod("[", signature(x="gSlidertcltk"), function(x, i, j,..., value) { .leftBracket(x, x@toolkit, i, j, ...) <- value return(x) }) ## Method to replace values of spin button setReplaceMethod(".leftBracket", signature(toolkit="guiWidgetsToolkittcltk",x="gSlidertcltk"), function(x, toolkit, i, j, ..., value) { obj <- x widget <- getWidget(obj) curVal <- svalue(obj) value <- sort(unique(value)) tag(obj, "..byIndexValues") <- value tkconfigure(widget, from=1, to=length(value)) svalue(obj) <- curVal return(obj) }) ### handlers setMethod(".addhandlerchanged", signature(toolkit="guiWidgetsToolkittcltk",obj="gSlidertcltk"), function(obj, toolkit, handler, action=NULL, ...) { # .addHandler(obj,toolkit, signal="",handler,action) .addHandler(obj,toolkit, signal="command",handler,action) }) gWidgetstcltk/MD50000644000176000001440000002677313652212707013455 0ustar ripleyusers16e2811b7ad836223b70a45ff66b3b23 *ChangeLog 08ec9887a9d11ff4d82888b00df1ec3c *DESCRIPTION 96fe55e47f7cbab1421dab9ab4ee67ea *NAMESPACE c0ed2a34359af76ba37b26e411e302f2 *NEWS b143517f22048be2e371884192f954ae *R/aaaGenerics.R 33fa0464b097c1c0ab9a239ad1d7b86b *R/aaaHandlers.R ab1bb62d720466496ff228c9e326d12f *R/aaaR5classes.R cec1dbf30b519a2ec100b45f70fd72ce *R/aabClasses.R 7669c565a441a9086be33b260454f502 *R/common.R f06257b170fc59efd38c266245043ee9 *R/dnd.R 056a02db3fa5b6f6085750d67aa1d569 *R/gaction.R b3547536d0c3f472b5ebedd30e5dc053 *R/gbutton.R a360eb0a40eda6b5076dc5af7d7cb592 *R/gcalendar.R 444d1fc562e847a797145dbacbf75fda *R/gcheckbox.R 65110a762e09f36a01b447a78390baa6 *R/gcheckboxgroup.R c9b0dd6c7bc6345257c8a9f12db59c79 *R/gcheckboxgrouptable.R b91d05cd3ca7fc059e1128f0f510cfe0 *R/gdf.R 5ce4d6f4decdcfe0c2c1c7adac31db6a *R/gdfnotebook.R 1b7e6e5f9d5c1bc3f7ae8fc6810c285f *R/gdialogs.R 35d016bbb02df13912f6485804799ba4 *R/gdroplist.R 1e79477cd15c461c2b89567a1223f144 *R/gedit.R 31182c3fc869e09b1a7337e5e477f69d *R/gexpandgroup.R f91f0e2eae79a1782d14597dbbad9a64 *R/gfile.R 390a6d0ada3003e74d5fb1e5a68ee179 *R/gframe.R 01946635aae49c1120a8451755aea243 *R/ggraphics.R a9545073a95806ac0ba52133a80b3bea *R/ggraphicsnotebook.R 15844ce35775667519d87b5279358c14 *R/ggroup.R 7b7f343af5e020ee9c4f8d51da900452 *R/ghtml.R c5ba78b359787d56d8481c18610252ca *R/gimage.R 4c15976822fb4e0c1f07584fea00d12b *R/glabel.R 38146b34bac8277e5faa050a713822c9 *R/glayout.R 4f4fd94b233e5c84ac53af78ce31962a *R/gmenu.R d2120c1415f3a4cbffd7c8830b73b3b3 *R/gnotebook.R b024bf11ca621e4b4424706a1d3a41fb *R/gpanedgroup.R e937097029966cf4f047a507273194b6 *R/gradio.R 61a5906cb1e93be839f6da99b6ff0196 *R/gseparator.R 4ad27be0cd06d3961d800c8f137460a7 *R/gslider.R eaa0905a4ffd2f9fbde1cd06570a15d1 *R/gspinbutton.R 120a2a78983fd80fbb2badb83a60a5ba *R/gstatusbar.R 5d62dd8bf3f09546aba9e39e1c1e8a69 *R/gtable.R b170f58a441d4bed0e2b4798b2afc368 *R/gtext.R dfc839ada8a514d1cb6d2eea3fe7fb8b *R/gtoolbar.R 03251076c0b5f8cacc2968302a30e8fe *R/gtree.R 967d76025c48e3b17f89bcc22befbc05 *R/gvarbrowser.R 9ea82b77131d3ae23aaa98b23cde9a47 *R/gwindow.R a5e20902ae6fcd0a0a5ea3a48d751ce1 *R/tcltkFuns.R 052ceb1d20f8685e2d4eca72f39e41b5 *R/zzz.R babd4e95870f4d89f744c86b7cc95589 *inst/ChangeLog fced6d9b00c198b56df95a3a1b1d0179 *inst/example.tcl 393f798c2e3903867b6a1bf749d2931f *inst/images/README 8c593636751673167cd9a9dfbee3b0c2 *inst/images/character.gif 5bc0d733855fc0da3057426162687e65 *inst/images/checkbutton-off.gif dd8db27ca7fdda407cba92b51fb4743b *inst/images/checkbutton-on.gif 5c244c0db2bb605d04987c17f3c67b50 *inst/images/directory.gif 27d8d228d738cb6aa5723e80265e6ebe *inst/images/factor.gif 5dc4d4833a81f3c78d6d96de7847f55b *inst/images/file.gif 8e205f886e0dd4d2b2d91aa5ace867cd *inst/images/function.gif a4fd90676c3d5759048a4a85294a094a *inst/images/integer.gif a6bc0802be6722f10f5acdfc0dab1e85 *inst/images/logical.gif 94084c86c0c98fadf979976b40ba04f7 *inst/images/matrix.gif a4fd90676c3d5759048a4a85294a094a *inst/images/numeric.gif 2b5ea1425c6cde8d1470e82e05d7a0ba *inst/pkgIndex.tcl c8b2e64639a2c2aab8a175e08f8c16c1 *inst/tcl/autoscroll.tcl fa0312a34e5a105f3b2062dd0d524b27 *inst/tklibs/autoscroll.tcl babd4e95870f4d89f744c86b7cc95589 *inst/tklibs/autoscroll1.1/ChangeLog 38c7afbebe82c3ad1c85965dc02285b7 *inst/tklibs/autoscroll1.1/autoscroll.man fa0312a34e5a105f3b2062dd0d524b27 *inst/tklibs/autoscroll1.1/autoscroll.tcl fced6d9b00c198b56df95a3a1b1d0179 *inst/tklibs/autoscroll1.1/example.tcl 2b5ea1425c6cde8d1470e82e05d7a0ba *inst/tklibs/autoscroll1.1/pkgIndex.tcl 4e7f967fb867fbb2698e465a2b7ca431 *inst/tklibs/tablelist5.6/CHANGES.txt 69e99b648d0e178e35437ca71df22ead *inst/tklibs/tablelist5.6/COPYRIGHT.txt fc0d45bb385cd199845b24f3017acdf4 *inst/tklibs/tablelist5.6/README.txt 179965706e08ff30b5cc9c3a34597811 *inst/tklibs/tablelist5.6/demos/browse.tcl 7b0291e5e95d41e0a8469e5a7b0aee19 *inst/tklibs/tablelist5.6/demos/browseTree.tcl 5d3636f8c9c2310a8dc6b2b47995bd46 *inst/tklibs/tablelist5.6/demos/browseTree_tile.tcl 0cc65f819b40e1797ee9a695eaf35f2f *inst/tklibs/tablelist5.6/demos/browse_tile.tcl a5b5cbb4205d754b2c94c3f68d84e848 *inst/tklibs/tablelist5.6/demos/bwidget.tcl 4e8a4601f84e343a7b91c7fcbd7d70aa *inst/tklibs/tablelist5.6/demos/bwidget_tile.tcl 22456e4a77435e1675ef0b3dc528b39d *inst/tklibs/tablelist5.6/demos/checked.gif 4df7db78524a423513439d25413c9751 *inst/tklibs/tablelist5.6/demos/clsdFolder.gif 6aefbc14425fcc736890faf4e0fcc4c0 *inst/tklibs/tablelist5.6/demos/comp.xbm 3233332d4626ef49592f5be3b1d9f0f1 *inst/tklibs/tablelist5.6/demos/config.tcl ff54f94baefdeae46e8eb36a9709e8b2 *inst/tklibs/tablelist5.6/demos/config_tile.tcl 792d67ae6373a62b1453f742b2473e6e *inst/tklibs/tablelist5.6/demos/dirViewer.tcl 2243593cd1d44feecbe7d2bf621bf581 *inst/tklibs/tablelist5.6/demos/dirViewer_tile.tcl 40c924b5497836470cbf01a3acbc5f63 *inst/tklibs/tablelist5.6/demos/embeddedWindows.tcl 66ca63ffd4d03bb8b13a5f207e6bd3c5 *inst/tklibs/tablelist5.6/demos/embeddedWindows_tile.tcl 968e0a50b6b3403b2e3878570fd421f0 *inst/tklibs/tablelist5.6/demos/file.gif a7009fe2842f172016bdca16b7edba6f *inst/tklibs/tablelist5.6/demos/images.tcl 666c9892fae81cd75bcfd9d9d23e3378 *inst/tklibs/tablelist5.6/demos/iwidgets.tcl 5bc42f461f0196973993b52198a4186c *inst/tklibs/tablelist5.6/demos/iwidgets_tile.tcl 74960254326fbe29e04d21dfff2ad49e *inst/tklibs/tablelist5.6/demos/leaf.xbm 30401cfeebae620fb37ac1d6fc9c5251 *inst/tklibs/tablelist5.6/demos/miscWidgets.tcl d64a8c468505e7146d917d5c4a3efbdf *inst/tklibs/tablelist5.6/demos/miscWidgets_tile.tcl cca41fe36464b914c302162afabf9e5a *inst/tklibs/tablelist5.6/demos/open.gif 8c49e887f463c31f6f60a2396446b0f6 *inst/tklibs/tablelist5.6/demos/openFolder.gif 136b48a71004418beea3873abc744023 *inst/tklibs/tablelist5.6/demos/option.tcl 4ceed9c62184554706162b6f75884324 *inst/tklibs/tablelist5.6/demos/option_tile.tcl c082211f4e4a36788bdef56c3ee0ce73 *inst/tklibs/tablelist5.6/demos/styles.tcl 923fe0251bc34916b7855cb9419c5100 *inst/tklibs/tablelist5.6/demos/styles_tile.tcl e841c2784551b74c2786812ef618075f *inst/tklibs/tablelist5.6/demos/tileWidgets.tcl 9d5e3918b17e87902fb38113ff34002d *inst/tklibs/tablelist5.6/demos/unchecked.gif 279b1e0b413739d775eb0bcc450401af *inst/tklibs/tablelist5.6/doc/adwaita.png a8ab68a79087a48f95a8498f5c91300f *inst/tklibs/tablelist5.6/doc/ambiance.png 59ba3b797160de166b25d9350c2e56e4 *inst/tklibs/tablelist5.6/doc/aqua.png 73e61839e4cced56a2a1f39f3b3dab91 *inst/tklibs/tablelist5.6/doc/arrowStyles.png 0667ddf6d7dc0f09921d7dab49b361ee *inst/tklibs/tablelist5.6/doc/baghira.png 1af9a1ed70833aa78f8b53a52faa1d9f *inst/tklibs/tablelist5.6/doc/browse.png 150baa543989543fc2e2c8ad46095ffd *inst/tklibs/tablelist5.6/doc/browseTree.png a592bd58e24ccac02ee27720c453cd02 *inst/tklibs/tablelist5.6/doc/bwidget.png a34ef57ceb405d6817ca2f9591442d25 *inst/tklibs/tablelist5.6/doc/config.png c1a52dfb02353c483188fb7e42e99027 *inst/tklibs/tablelist5.6/doc/dirViewer.png 04c0873a335d838fbbe009b85891f71b *inst/tklibs/tablelist5.6/doc/dust.png 0eaac5acff20b147d4218093f6b61a40 *inst/tklibs/tablelist5.6/doc/dustSand.png 14f19616b19b99a0c20125994a785281 *inst/tklibs/tablelist5.6/doc/embeddedWindows.png 034255f88080d4332c7ee654c83182b9 *inst/tklibs/tablelist5.6/doc/embeddedWindows_tile.png fead90fa401e0a08225160157c48dcb0 *inst/tklibs/tablelist5.6/doc/gtk.png f8fc85ab03e31b5f219b3fbb9f2ce5ac *inst/tklibs/tablelist5.6/doc/index.html 04adde9ee237ed28e70f900c3809803a *inst/tklibs/tablelist5.6/doc/klearlooks.png e29634b169bad4151beb6aa33c37074f *inst/tklibs/tablelist5.6/doc/mint.png 2d7785e6dfac0d98d1668d5275fcd84d *inst/tklibs/tablelist5.6/doc/newWave.png 928860526560e9af86c385440a42edbe *inst/tklibs/tablelist5.6/doc/oxygen1.png aed3758569a08090cb1222a9bac98782 *inst/tklibs/tablelist5.6/doc/oxygen2.png 6d4e705d6200bf18d5d885490d6deaae *inst/tklibs/tablelist5.6/doc/phase.png bc77c1d03b1e011e73025e53c3e5dd91 *inst/tklibs/tablelist5.6/doc/plastik.png fbb8fbcb76d89fb3dabdaa4cdc4c8704 *inst/tklibs/tablelist5.6/doc/plastique.png a89e4d5ea9a3bd01d14c2d469211a75e *inst/tklibs/tablelist5.6/doc/radiance.png bac4d0139f85d132982710aa0926a1fa *inst/tklibs/tablelist5.6/doc/styles.png 614ad9524d226c33958f2e0f42709475 *inst/tklibs/tablelist5.6/doc/tablelist.html e6a61537b7aad57dc39c2300ec6647eb *inst/tklibs/tablelist5.6/doc/tablelistBWidget.html a908ea93c2b489732ba0c7cc4f587345 *inst/tklibs/tablelist5.6/doc/tablelistBinding.html 9b62dcfbf830fc046cf628becca67369 *inst/tklibs/tablelist5.6/doc/tablelistColSort.html bdd8c0d62deac5e2ee91ddf172a515cd *inst/tklibs/tablelist5.6/doc/tablelistCombobox.html d0edc262b1f09b986b204d77e8c38b9b *inst/tklibs/tablelist5.6/doc/tablelistIwidgets.html e9e1ce5f182886e4e81bf3eca61bc08f *inst/tklibs/tablelist5.6/doc/tablelistMentry.html f2c418ac57b925159470234bfb59b37f *inst/tklibs/tablelist5.6/doc/tablelistThemes.html 799dd81fb340b0c4b5739f436b0ebd07 *inst/tklibs/tablelist5.6/doc/tablelistTile.html 96c7660e98abacf616a38f642a6cd497 *inst/tklibs/tablelist5.6/doc/tablelistTkCore.html 2a891ca84f23956e475de8bd5d727804 *inst/tklibs/tablelist5.6/doc/tablelistWidget.html bc9fe5773824f860e2e533ba708aa48d *inst/tklibs/tablelist5.6/doc/tileWidgets.png b97bff024215de188d98a6a72be0f6e5 *inst/tklibs/tablelist5.6/doc/ubuntu.png 83ad9267c065389a4a5cbd5ea1f9872a *inst/tklibs/tablelist5.6/doc/vistaAero.png d5748462e7fa6acec144f42c95f5afd3 *inst/tklibs/tablelist5.6/doc/vistaClassic.png 3c4507d675fbd8063eff64d6ba833495 *inst/tklibs/tablelist5.6/doc/win7Aero.png 7da0ecf6deb70bdc33a2b5c2b33f1ab5 *inst/tklibs/tablelist5.6/doc/win7Classic.png 840b4ae01ea6ca78f96e303459369e6a *inst/tklibs/tablelist5.6/doc/winnative.png bca6de079fd0658dcbaf89e37b7500af *inst/tklibs/tablelist5.6/doc/winxpBlue.png 9f8b2b125f16cb1029eea1877d56a4d2 *inst/tklibs/tablelist5.6/doc/winxpOlive.png 64d7b376be752e6039860ae37c5dfb6f *inst/tklibs/tablelist5.6/doc/winxpSilver.png 4c6119953f24db581fb62c866394aca1 *inst/tklibs/tablelist5.6/pkgIndex.tcl 94c0d32c4d5a0ee1ab3b800b68e6c3cf *inst/tklibs/tablelist5.6/scripts/mwutil.tcl f4edda78c75865dac6fd17bf882a11a0 *inst/tklibs/tablelist5.6/scripts/repair.tcl 8317cbc9b18b483f12b13538537df814 *inst/tklibs/tablelist5.6/scripts/tablelistBind.tcl 40111a681d8898c47eaabc7b46baaacb *inst/tklibs/tablelist5.6/scripts/tablelistConfig.tcl 0bfad332f0b0105d984c2677c1291f6f *inst/tklibs/tablelist5.6/scripts/tablelistEdit.tcl ab54030f52eda528a7e778a6c89e5d99 *inst/tklibs/tablelist5.6/scripts/tablelistImages.tcl 1b4275899954c88c333d6f60a888be61 *inst/tklibs/tablelist5.6/scripts/tablelistMove.tcl f8cd5ce1bd10174137c5f724c659d7d4 *inst/tklibs/tablelist5.6/scripts/tablelistSort.tcl 69033d030dc506f8bb0e8a68ca802a43 *inst/tklibs/tablelist5.6/scripts/tablelistThemes.tcl c70992e7533667b0dd01d55b6bebd7ae *inst/tklibs/tablelist5.6/scripts/tablelistUtil.tcl 65bfa58182045bc1128c13e05c0618f4 *inst/tklibs/tablelist5.6/scripts/tablelistWidget.tcl 4dcaa28258f1bc2e67b0885ede33b8e0 *inst/tklibs/tablelist5.6/scripts/tclIndex fb4cfe4061325333438be00cf100cf63 *inst/tklibs/tablelist5.6/tablelist.tcl c9aeb6fbd6b3cd9be5037706627f10a2 *inst/tklibs/tablelist5.6/tablelistPublic.tcl fa68a99fd160294d05abff6e6b46efdb *inst/tklibs/tablelist5.6/tablelist_tile.tcl c5dd38a3f8b533757c6417eb4f9dcea5 *inst/tklibs/tooltip1.4/ChangeLog 73c54d3ef51cab32eb47a06f733c2c4a *inst/tklibs/tooltip1.4/example.tcl 6067060a52863bfe47a41b8996a2ac8f *inst/tklibs/tooltip1.4/pkgIndex.tcl e0f81d760f20c8b550bd584e6f9590df *inst/tklibs/tooltip1.4/tipstack.tcl 554febc374a3d1dbb8d864d4c0a764d8 *inst/tklibs/tooltip1.4/tooltip.man 051452f302d59a0475b1dec54ad916fa *inst/tklibs/tooltip1.4/tooltip.tcl e8cac862b7349a6fad254108b97c79ef *man/gWidgetstcltk-package.Rd 5f44340a5788eafed42fa6e47749ec06 *man/gWidgetstcltk-undocumented.Rd 111618cdedead3bf38c7738dc9f4170b *tests/RunTests.R 5dde361fa38321fdaa459adbc9a2949c *tests/runRUnit.R gWidgetstcltk/inst/0000755000176000001440000000000012350164246014101 5ustar ripleyusersgWidgetstcltk/inst/pkgIndex.tcl0000644000176000001440000000114311350417656016362 0ustar ripleyusers# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if { ![package vsatisfies [package provide Tcl] 8.2] } { return } package ifneeded autoscroll 1.1 [list source [file join $dir autoscroll.tcl]] gWidgetstcltk/inst/tklibs/0000755000176000001440000000000012275245142015372 5ustar ripleyusersgWidgetstcltk/inst/tklibs/tooltip1.4/0000755000176000001440000000000012275245142017307 5ustar ripleyusersgWidgetstcltk/inst/tklibs/tooltip1.4/pkgIndex.tcl0000644000176000001440000000024611350417656021572 0ustar ripleyusers# -*- tcl -*- package ifneeded tooltip 1.4.4 [list source [file join $dir tooltip.tcl]] package ifneeded tipstack 1.0.1 [list source [file join $dir tipstack.tcl]] gWidgetstcltk/inst/tklibs/tooltip1.4/ChangeLog0000644000176000001440000000671511350417656021076 0ustar ripleyusers2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2008-12-01 Jeff Hobbs * tooltip.man, pkgIndex.tcl: Increment to 1.4.4 * tooltip.tcl (::tooltip::register): Added support for multiple items in -item (now -items) for listbox and canvas items, to allow canvas tagOrIds that return multiple items. 2008-11-04 Pat Thoyts * tooltip.tcl: Added support for listbox items. * tooltip.man: * pkgIndex.tcl: Incremented to 1.4.3 2008-08-08 Pat Thoyts * tooltip.tcl (::tooltip::tagTip): Cancel outstanding after events on tags when setting a new one to avoid visual glitches when moving the cursor across a set of tags (ie: tkchat userlist) 2008-07-14 Jeff Hobbs * pkgIndex.tcl: bump to 1.4.2. [Bug 2015992] * tooltip.tcl (::tooltip::enableTag, ::tooltip::enableCanvas): Protect bind enablers to only add themselves once. 2008-03-12 Jeff Hobbs * pkgIndex.tcl: bump to 1.4.1 * tooltip.tcl (::tooltip::show): check window exists before any other ops. [Bug 1879622] 2007-10-31 Jeff Hobbs * tooltip.tcl (::tooltip::clear): Withdraw the tooltip if we clear the current contained item. [Bug 1547729] * tooltip.tcl: added fading (default on for Win32/Aqua) of tooltip * tooltip.man: instead of just withdraw. [Bug 1641071] 2007-09-22 Pat Thoyts * tooltip.tcl (::tooltip::show): Left align the tooltip text * pkgIndex.tcl: (reported by Peter Caffin) * tooltip.man: Bumped to 1.4 Generally improved the manual to fix bug #1800296. 2007-05-18 Jeff Hobbs * tooltip.man, pkgIndex.tcl: bumped version to 1.3 * tooltip.tcl (::tooltip::show): Use late-binding msgcat (lazy translation) to support programs that allow on-the-fly l10n changes. Requires msgcat package (Tk uses this already). (poser) 2007-02-07 Pat Thoyts * tooltip.tcl: Added support for tooltips on text widget tags (useful for tkchat url links). Fixed menu tooltips. * tooltip.man: Added documentation. * pkgIndex.tcl: Incremented version to 1.2 2006-08-02 Jeff Hobbs * tooltip.tcl (::tooltip::show): better handle boundary case considering Tk's odd multi-monitor screen dimension handling. AS bug 48498. 2006-03-31 Andreas Kupries * tipstack.tcl (::tipstack::clearsub): Superfluous argument to call of 'clear' removed. 2005-11-21 Jeff Hobbs * tooltip.tcl (::tooltip::show): focus back to previous item, not the widget we are over. 2005-11-10 Andreas Kupries * * Released and tagged Tklib 0.4.1 ======================== * 2005-11-02 Andreas Kupries * * Released and tagged Tklib 0.4 ======================== * 2005-08-12 Andreas Kupries * tooltip.man: Added module/title descriptions to the manpage. 2005-08-11 Jeff Hobbs * tooltip.tcl (::tooltip::show): prevent aqua help focus theft 2005-04-29 Andreas Kupries * tooltip.man: Fixed syntax errors in the documentation. 2005-04-02 Aaron Faupell * initial import gWidgetstcltk/inst/tklibs/tooltip1.4/example.tcl0000644000176000001440000000167711350417656021465 0ustar ripleyusers# Demonstrate widget tooltip #package require tooltip source ./tooltip.tcl pack [label .l -text "label"] tooltip::tooltip .l "This is a label widget" # Demonstrate menu tooltip #package require tooltip . configure -menu [menu .menu] .menu add cascade -label Test -menu [menu .menu.test -tearoff 0] .menu.test add command -label Tooltip tooltip::tooltip .menu.test -index 0 "This is a menu tooltip" # Demonstrate canvas item tooltip #package require tooltip pack [canvas .c] set item [.c create rectangle 10 10 80 80] tooltip::tooltip .c -item $item "Canvas item tooltip" # Demonstrate listbox item tooltip #package require tooltip pack [listbox .lb] .lb insert 0 "item one" tooltip::tooltip .lb -item 0 "Listbox item tooltip" # Demonstrate text tag tooltip #package require tooltip pack [text .txt] .txt tag configure TIP-1 -underline 1 tooltip::tooltip .txt -tag TIP-1 "tooltip one text" .txt insert end "An example of a " {} "tooltip" TIP-1 " tag.\n" {}gWidgetstcltk/inst/tklibs/tooltip1.4/tipstack.tcl0000644000176000001440000000766511350417656021657 0ustar ripleyusers# tipstack.tcl -- # # Based on 'tooltip', provides a dynamic stack of tip texts per # widget. This allows dynamic transient changes to the tips, for # example to temporarily replace a standard epxlanation with an # error message. # # Copyright (c) 2003 ActiveState Corporation. # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tipstack.tcl,v 1.4 2009/01/09 05:46:12 andreas_kupries Exp $ # # ### ######### ########################### # Requisites package require tooltip namespace eval ::tipstack {} # ### ######### ########################### # Public API # ## Basic syntax for all commands having a widget reference: # ## tipstack::command .w ... ## tipstack::command .m -index foo ... # ### ######### ########################### ## Push new text for a widget (or menu) proc ::tipstack::push {args} { if {([llength $args] != 2) && (([llength $args] != 4))} { return -code error "wrong#args: expected w ?-index index? text" } # Extract valueable parts. set text [lindex $args end] set wref [lrange $args 0 end-1] # Remember new data (setup/extend db) variable db if {![info exists db($wref)]} { set db($wref) [list $text] } else { lappend db($wref) $text } # Forward to standard tooltip package. eval [linsert [linsert $wref end $text] 0 tooltip::tooltip] return } # ### ######### ########################### ## Pop text from stack of tip for widget. ## ! Keeps the bottom-most entry. proc ::tipstack::pop {args} { if {([llength $args] != 1) && (([llength $args] != 3))} { return -code error "wrong#args: expected w ?-index index?" } # args == wref (see 'push'). set wref $args # Pop top information form the database. Except if the # text is the last in the stack. Then we will keep it, it # is the baseline for the widget. variable db if {![info exists db($wref)]} { set text "" } else { set data $db($wref) if {[llength $data] == 1} { set text [lindex $data 0] } else { set data [lrange $data 0 end-1] set text [lindex $data end] set db($wref) $data } } # Forward to standard tooltip package. eval [linsert [linsert $wref end $text] 0 tooltip::tooltip] return } # ### ######### ########################### ## Clears out all data about a widget (or menu). proc ::tipstack::clear {args} { if {([llength $args] != 1) && (([llength $args] != 3))} { return -code error "wrong#args: expected w ?-index index?" } # args == wref (see 'push'). set wref $args # Remove data about widget. variable db catch {unset db($wref)} eval [linsert [linsert $wref end ""] 0 tooltip::tooltip] return } # ### ######### ########################### ## Convenient definition of tooltips for multiple ## independent widgets. No menus possible proc ::tipstack::def {defs} { foreach {path text} $defs { push $path $text } return } # ### ######### ########################### ## Convenient definition of tooltips for multiple ## widgets in a containing widget. No menus possible. ## This is for megawidgets. proc ::tipstack::defsub {base defs} { foreach {subpath text} $defs { push $base$subpath $text } return } # ### ######### ########################### ## Convenient clearage of tooltips for multiple ## widgets in a containing widget. No menus possible. ## This is for megawidgets. proc ::tipstack::clearsub {base} { variable db foreach k [array names db ${base}*] { # Danger. Will fail if 'base' matches a menu reference. clear $k } return } # ### ######### ########################### # Internal commands -- None # ### ######### ########################### ## Data structures namespace eval ::tipstack { # Map from widget references to stack of tooltips. variable db array set db {} } # ### ######### ########################### # Ready package provide tipstack 1.0.1 gWidgetstcltk/inst/tklibs/tooltip1.4/tooltip.man0000644000176000001440000000771011350417656021507 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin tooltip n 1.4.4] [copyright {1996-2008, Jeffrey Hobbs}] [moddesc {Tooltip management}] [titledesc {Tooltip management}] [require Tcl 8.4] [require msgcat 1.3] [require tooltip [opt 1.4.4]] [description] [para] This package provides tooltips, small text messages that can be displayed when the mouse hovers over a widget, menu item, canvas item, listbox item or text widget tag. [section {COMMANDS}] [list_begin definitions] [call [cmd ::tooltip::tooltip] [arg command] [opt [arg options]]] Manage the tooltip package using the following subcommands. [list_begin options] [opt_def clear [arg index]] Prevents the specified widgets from showing tooltips. [arg pattern] is a glob pattern and defaults to matching all widgets. [opt_def delay [opt [arg millisecs]]] Query or set the hover delay. This is the interval that the pointer must remain over the widget before the tooltip is displayed. The delay is specified in milliseconds and must be greater than 50ms. With no argument the current delay is returned. [opt_def fade [opt [arg boolean]]] Enable or disable fading of the tooltip. The is enabled by default on Win32 and Aqua. The tooltip will fade away on Leave events instead disappearing. [opt_def disable] [opt_def off] Disable all tooltips [opt_def enable] [opt_def on] Enables tooltips for defined widgets. [list_end] [nl] [call [cmd ::tooltip::tooltip] \ [arg pathName] [opt [arg "option arg"]] [arg message]] This command arranges for widget [arg pathName] to display a tooltip with message [arg message]. The tooltip uses a late-binding msgcat call on the passed in message to allow for on-the-fly language changes in an application. If the widget specified is a menu, canvas or text widget then additional options are used to tie the tooltip to specific menu entries, canvas items or text tags. [list_begin options] [opt_def -index [arg index]] This option is used to set a tooltip on a menu item. The index may be either the entry index or the entry label. The widget must be a menu widget but the entries do not have to exists when the tooltip is set. [opt_def -items [arg name]] This option is used to set a tooltip for canvas widget or listbox items. For the canvas widget, the item must already be present in the canvas widget and will be found with a [cmd "find withtag"] lookup. For listbox widgets the item(s) may be created later but the programmer is responsible for managing the link between the listbox item index and the corresponding tooltip. If the listbox items are re-ordered, the tooltips will need amending. [nl] If the widget is not a canvas or listbox then an error is raised. [opt_def -tag [arg name]] The [option -tag] option can be used to set a tooltip for a text widget tag. The tag should already be present when this command is called or an error will be returned. The widget must also be a text widget. [list_end] [list_end] [section EXAMPLE] [example { # Demonstrate widget tooltip package require tooltip pack [label .l -text "label"] tooltip::tooltip .l "This is a label widget" }] [example { # Demonstrate menu tooltip package require tooltip . configure -menu [menu .menu] .menu add cascade -label Test -menu [menu .menu.test -tearoff 0] .menu.test add command -label Tooltip tooltip::tooltip .menu.test -index 0 "This is a menu tooltip" }] [example { # Demonstrate canvas item tooltip package require tooltip pack [canvas .c] set item [.c create rectangle 10 10 80 80] tooltip::tooltip .c -item $item "Canvas item tooltip" }] [example { # Demonstrate listbox item tooltip package require tooltip pack [listbox .lb] .lb insert 0 "item one" tooltip::tooltip .lb -item 0 "Listbox item tooltip" }] [example { # Demonstrate text tag tooltip package require tooltip pack [text .txt] .txt tag configure TIP-1 -underline 1 tooltip::tooltip .txt -tag TIP-1 "tooltip one text" .txt insert end "An example of a " {} "tooltip" TIP-1 " tag.\n" {} }] [keywords tooltip hover balloon help] [manpage_end] gWidgetstcltk/inst/tklibs/tooltip1.4/tooltip.tcl0000644000176000001440000003361311350417656021517 0ustar ripleyusers# tooltip.tcl -- # # Balloon help # # Copyright (c) 1996-2007 Jeffrey Hobbs # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tooltip.tcl,v 1.16 2008/12/01 23:37:16 hobbs Exp $ # # Initiated: 28 October 1996 package require Tk 8.4 package require msgcat #------------------------------------------------------------------------ # PROCEDURE # tooltip::tooltip # # DESCRIPTION # Implements a tooltip (balloon help) system # # ARGUMENTS # tooltip