R/gmenu.R

In jverzani/gWidgets2RGtk2: Implementation of gWidgets2 for the RGtk2 Package

##' @include GWidget.R
NULL

##' Toolkit constructor
##'
##' @export
##' @rdname gWidgets2RGtk2-undocumented
##' @method .gmenu guiWidgetsToolkitRGtk2
## @export .gmenu guiWidgetsToolkitRGtk2
.gmenu.guiWidgetsToolkitRGtk2 <-  function(toolkit,
                                           menu.list=list(),
                                           popup=FALSE,
                                           container = NULL,
                                           ... ) {
  if(popup)
    GMenuPopup$new(toolkit, menu.list=menu.list,  ...)
  else
    GMenuBar$new(toolkit, menu.list=menu.list, container = container, ...)
}


## Toplevel menu bar
GMenuBar <- setRefClass("GMenuBar",
                     contains="GWidget",
                     fields=list(
                       menu_list="list"
                       ),
                     methods=list(
                       initialize=function(toolkit=NULL,
                         menu.list=list(),
                         container=NULL, ...) {

                         if(is(widget, "uninitializedField")) {
                           widget <<- gtkMenuBarNew()
                           initFields(block=widget)
                           
                           menu_list <<- list()
                           set_value(menu.list)
                           add_to_parent(container, .self, ...)
                         }
                         callSuper(toolkit)
                       },
                       ## add items
                       add_menu_items=function(sub_menu, items) {
                         sapply(items, function(item) {
                           ## do dispatch based on class
                           if(is(item, "list")) {
                             ## get name by looking up and matching
                             add_submenu(sub_menu, item, nm=names(Filter(function(x) identical(x, item), items)))
                           } else if(is(item, "GAction")) {
                             add_gaction_menuitem(sub_menu, item)
                           } else if(is(item, "GSeparator")) {
                             add_gseparator_menuitem(sub_menu, item)
                           } else if(is(item, "GRadio")) {
                             add_radio_menuitem(sub_menu, item)
                           } else if(is(item, "GCheckbox")) {
                             add_checkbutton_menuitem(sub_menu, item)
                           } else {
                             add_widget_menuitem(sub_menu, item)
                           }
                         })
                         sub_menu$show()
                       },
                       add_submenu=function(sub_menu, items, nm) {
                         item <- gtkMenuItem(nm)
                         sub_menu$append(item)
                         sub_menu <- gtkMenu()
                         add_menu_items(sub_menu, items)
                         item$setSubmenu(sub_menu)
                       },
                       add_gaction_menuitem=function(sub_menu, item) {
                         action <- item$widget
                         item <- gtkImageMenuItem("")
                         if("always-show-image" %in% names(item))
                           item['always-show-image'] <- TRUE
                         sub_menu$append(item)
                         item$setRelatedAction(action)
                       },
                       add_gseparator_menuitem=function(sub_menu, item) {
                         item <- gtkSeparatorMenuItem()
                         sub_menu$append(item)
                       },
                       add_radio_menuitem=function(sub_menu, item) {
                         rb <- item
                         cur <- svalue(rb, index=TRUE)
                         nms <- rb[]
                         ## do this the *hard* way using check menu items, simple way failed
                         ## as I didn't know how to start gtkRadioMenuItem group off.
                         rbs <- sapply(nms, function(i) {
                           item <- gtkCheckMenuItemNewWithLabel(i)
                           item$setDrawAsRadio(TRUE)
                           sub_menu$append(item)
                           item
                         })
                         rbs[[cur]]$setActive(TRUE)
                         sapply(rbs, gSignalConnect, signal="toggled", f=function(w, ...) {
                           if(w$getActive()) {
                             ind <- sapply(rbs, identical, w)
                             sapply(which(!ind), function(i) rbs[[i]]$setActive(FALSE))
                             svalue(rb, index=TRUE) <- which(ind)
                           }
                         })
                       },
                       add_checkbutton_menuitem=function(sub_menu, item) {
                         cb <- item
                         item <- gtkCheckMenuItemNewWithLabel(cb[1])
                         item$setActive(svalue(cb))
                         gSignalConnect(item, "toggled", function(w, ...) {
                           cur <- w$getActive()
                           svalue(cb) <- cur
                         })
                         sub_menu$append(item)
                       },
                       add_widget_menuitem=function(sub_menu, item) {
                         "Add an arbitrary widget, though likely not a good thing to do."
                         mitem <- gtkMenuItemNew()
                         mitem$add(getBlock(item))
                         sub_menu$append(mitem)
                       },
                       clear_menubar=function() {
                         "Clear out menu items"
                         sapply(rev(widget$getChildren()), widget$remove)
                         widget$hide()
                       },
                       ##
                       get_value=function( ...) {
                         menu_list
                       },
                       set_value=function(value, ...) {
                         clear_menubar()
                         menu_list <<- value
                         add_menu_items(widget, value)
                         widget$show()
                       },
                       append_value=function(items) {
                         "Append to menu list"
                         menu_list <<- gWidgets2:::merge.list(menu_list, items)
                         add_menu_items(widget, items)
                       }
                       ))


## Popup class
GMenuPopup <- setRefClass("GMenuPopup",
                            contains="GMenuBar",
                            methods=list(
                              initialize=function(toolkit=NULL,
                                menu.list=list(),
                                ...) {
                                widget <<- gtkMenuNew()
                                initFields(block=widget)
                                menu_list <<- menu.list
                                add_menu_items(widget, menu.list)
                                callSuper(toolkit)
                              }
                              ))