Nothing
R/aaaGenerics.R
In gWidgetsRGtk2: Toolkit Implementation of gWidgets for RGtk2
Defines functions
addPopupMenuWithSignal
add3rdMousePopupMenuWithSignal
as.gWidgetsRGtk2
as.gWidgetsRGtk2.default
Documented in
as.gWidgetsRGtk2
## toolkit class
## register classes here for toolkits
## setClass("guiWidgetsToolkitRGtk2",
## contains="guiWidgetsToolkit",
## prototype=prototype(new("guiWidgetsToolkit"))
## )
##################################################
## put S3 classes from RGtk2 into S4 classes
## got these from apropos("New") -> try(class(do.call(i,list())))
oldClasses =
c(
"AtkNoOpObjectFactory",
"AtkObjectFactory",
"AtkRelationSet",
"AtkStateSet",
"GBoxed",
"GObject",
"GScanner",
"GdkDragContext",
"GdkPixbufLoader",
"GdkRegion",
"GtkAboutDialog",
"GtkAccelGroup",
"GtkAccelLabel",
"GtkAction",
"GtkActionGroup",
"GtkAdjustment",
"GtkAlignment",
"GtkArrow",
"GtkAspectFrame",
"GtkBin",
"GtkBox",
"GtkButton",
"GtkButtonBox",
"GtkCList",
"GtkCTree",
"GtkCalendar",
"GtkCellRenderer",
"GtkCellRendererCombo",
"GtkCellRendererPixbuf",
"GtkCellRendererProgress",
"GtkCellRendererText",
"GtkCellRendererToggle",
"GtkCellView",
"GtkCheckButton",
"GtkCheckMenuItem",
"GtkColorButton",
"GtkColorSelection",
"GtkColorSelectionDialog",
"GtkCombo",
"GtkComboBox",
"GtkComboBoxEntry",
"GtkContainer",
"GtkCurve",
"GtkDialog",
"GtkDrawingArea",
"GtkEntry",
"GtkEntryCompletion",
"GtkEventBox",
"GtkExpander",
"GtkFileFilter",
"GtkFileSelection",
"GtkFileChooserWidget",
"GtkFixed",
"GtkFontButton",
"GtkFontSelection",
"GtkFontSelectionDialog",
"GtkFrame",
"GtkGammaCurve",
"GtkHBox",
"GtkHButtonBox",
"GtkHPaned",
"GtkHRuler",
"GtkHScale",
"GtkHScrollbar",
"GtkHSeparator",
"GtkHandleBox",
"GtkIMContext",
"GtkIMContextSimple",
"GtkIMMulticontext",
"GtkIconFactory",
"GtkIconSet",
"GtkIconSource",
"GtkIconTheme",
"GtkIconView",
"GtkImage",
"GtkImageMenuItem",
"GtkInfoBar",
"GtkInputDialog",
"GtkInvisible",
"GtkItem",
"GtkLabel",
"GtkLayout",
"GtkList",
"GtkListItem",
"GtkMenu",
"GtkMenuBar",
"GtkMenuItem",
"GtkMenuShell",
"GtkMisc",
"GtkNotebook",
"GtkObject",
"GtkOptionMenu",
"GtkPaned",
"GtkProgress",
"GtkProgressBar",
"GtkRadioAction",
"GtkRadioButton",
"GtkRange",
"GtkRcStyle",
"GtkRuler",
"GtkScale",
"GtkScrollbar",
"GtkScrolledWindow",
"GtkSeparator",
"GtkSeparatorMenuItem",
"GtkSeparatorToolItem",
"GtkSizeGroup",
"GtkSocket",
"GtkSpinButton",
"GtkStatusbar",
"GtkStyle",
"GtkTable",
"GtkTearoffMenuItem",
"GtkTextAttributes",
"GtkTextBuffer",
"GtkTextChildAnchor",
"GtkTextTag",
"GtkTextTagTable",
"GtkTextView",
"GtkTipsQuery",
"GtkToggleAction",
"GtkToggleButton",
"GtkToggleToolButton",
"GtkToolButton",
"GtkToolItem",
"GtkToolbar",
"GtkTooltips",
"GtkTreeModelSort",
"GtkTreePath",
"GtkTreeStore",
"GtkTreeView",
"GtkTreeViewColumn",
"GtkUIManager",
"GtkVBox",
"GtkVButtonBox",
"GtkVPaned",
"GtkVRuler",
"GtkVScale",
"GtkVScrollbar",
"GtkVSeparator",
"GtkViewport",
"GtkWidget",
"GtkWindow",
"GtkWindowGroup",
##
"PangoAttrList",
"PangoCairoFcFontMap",
"PangoCoverage",
"PangoFcFontMap",
"PangoFontDescription",
"PangoFontMap",
"PangoGlyphString",
"PangoItem",
"GObject",
"RGtkDataFrame",
## add in others that come up
"GtkTreeSelection"
)
setOldClass("RGtkObject")
lapply(oldClasses, function(i) {
setOldClass(i)
setIs(i,"RGtkObject")
})
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
setClass("gWidgetRGtk")
## this worked in 2.4.0 but not later, remove
##setIs("guiWidget","guiWidgetORgWidgetRGtkORRGtkObject")
##setIs("gWidgetRGtk","guiWidgetORgWidgetRGtkORRGtkObject")
##setIs("RGtkObject","guiWidgetORgWidgetRGtkORRGtkObject")
setClassUnion("guiWidgetORgWidgetRGtkORRGtkObject",
c("guiWidget","gWidgetRGtk","RGtkObject"))
## subclss
## This behaviour changed in R as of 2.7.0. We throw in the towel here and use "ANY and not the preferred guiWidgetORgWidgetRGtkORRGtkObject
##.Rversion <- R.Version()
##if(.Rversion$major == "2" && .Rversion$minor == "7.0" ) {
setClass("gComponentRGtk",
representation(
block="ANY",
widget="ANY",
toolkit="guiWidgetsToolkit"
),
contains="gWidgetRGtk",
)
setClass("gContainerRGtk",
representation(
block="ANY",
widget="ANY",
toolkit="guiWidgetsToolkit"
),
contains="gWidgetRGtk",
)
## } else {
## setClass("gComponentRGtk",
## representation(
## block="guiWidgetORgWidgetRGtkORRGtkObject",
## widget="guiWidgetORgWidgetRGtkORRGtkObject",
## toolkit="guiWidgetsToolkit"
## ),
## contains="gWidgetRGtk",
## )
## setClass("gContainerRGtk",
## representation(
## block="guiWidgetORgWidgetRGtkORRGtkObject",
## widget="guiWidgetORgWidgetRGtkORRGtkObject",
## toolkit="guiWidgetsToolkit"
## ),
## contains="gWidgetRGtk",
## )
## }
##################################################
### 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="gWidgetRGtk"),
function(obj, index=NULL, drop=NULL, ...) {
.svalue(obj, obj@toolkit, index=index, drop=drop, ...)
})
## svalue
## need method for character
setMethod("svalue",signature(obj="character"),
function(obj, index=NULL, drop=NULL, ...) {
ifelse(length(obj) == 1,
return(getObjectFromString(obj)),
return(obj)
)
})
setMethod(".svalue",signature(toolkit = "guiWidgetsToolkitRGtk2", 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="gWidgetRGtk"),
function(obj, index=NULL, ...,value) {
.svalue(obj, obj@toolkit, index=index, ...) <- value
obj
})
## [
setMethod("[",
signature(x="gWidgetRGtk"),
function(x,i,j,...,drop=TRUE) {
return(.leftBracket(x, x@toolkit,i,j,...,drop=TRUE))
# if(missing(i) && missing(j))
# .leftBracket(x@widget, toolkit,,,...,drop=TRUE)
# else if(missing(j))
# .leftBracket(x@widget, toolkit,i,,...,drop=TRUE)
# else
# .leftBracket(x@widget, toolkit,i,j,...,drop=TRUE)
})
## [<-
setReplaceMethod("[",signature(x="gWidgetRGtk"),
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="gWidgetRGtk"),
function(obj, ...) {
return()
.size(obj, obj@toolkit,...)
})
setMethod(".size",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
## send to gWidgetRGtk2
.size(obj@widget, toolkit, ...)
})
setMethod(".size",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ...) {
## get from SizeAllocation()
val <- obj$GetAllocation()
return(c(width=val$width, height=val$height))
})
## not needed?
setMethod(".size",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="GtkWindow"),
function(obj, toolkit, ...) {
print("returning size information not yet implemented.")
})
## size<-
setReplaceMethod("size",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.size(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".size",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
if(length(value) >= 2) {
width <- value[1]; height <- value[2]
} else if(names(value) == "height") {
width <- -1; height <- value
} else {
width <- value; height <- -1
}
widget = obj@widget
widget$SetSizeRequest(width,height)
# widget$SetDefaultSize(width,height)
return(obj)
})
## visible
setMethod("visible",signature(obj="gWidgetRGtk"),
function(obj, set=NULL, ...) {
.visible(obj,obj@toolkit, set=set, ...)
})
setMethod(".visible",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, set=TRUE, ...) {
widget <- getWidget(obj)
if(is.null(set))
widget['visible']
else
if(as.logical(set))
widget$Show()
else
widget$Hide()
})
## visible<-
setReplaceMethod("visible",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.visible(obj, obj@toolkit, ...) <- value
return(obj)
})
setReplaceMethod(".visible",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
visible(obj, value)
return(obj)
})
## isExtant -- can we see the window
setMethod("isExtant",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.isExtant(obj,obj@toolkit, ...)
})
setMethod(".isExtant",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
widget = getWidget(obj)
if(is.null(widget)) return(FALSE)
!inherits(widget,"<invalid>") # test to see if destroyed
})
## enabled -- not implemeneted, don't know how to find sensitive. Would need to keep in
## in the widget using tag or somesuch
setMethod("enabled",signature(obj="gWidgetRGtk"),
function(obj, ...) {
warning("enable not defined, try enabled<-()")
return(NA)
.enabled(obj, obj@toolkit,...)
})
setMethod(".enabled",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
widget <- getWidget(obj)
if("sensitive" %in% names(widget))
widget['sensitive']
else
TRUE
})
setMethod(".enabled",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="GtkWindow"),
function(obj, toolkit, ...) {
print("returning enabled information not yet implemented.")
})
## enabled<-
setReplaceMethod("enabled",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.enabled(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".enabled",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
widget = getWidget(obj)
.enabled(widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod(".enabled",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ..., value) {
obj$SetSensitive(as.logical(value))
return(obj)
})
## editable -- can the widget be edited
setMethod("editable",signature(obj="gWidgetRGtk"),
function(obj, ...) {
return()
.editable(obj, obj@toolkit,...)
})
setMethod(".editable",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
message("no default editable method")
})
## editable<-
setReplaceMethod("editable",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.editable(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".editable",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
message("no default editable<- method")
return(obj)
})
## focus
setMethod("focus",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.focus(obj, obj@toolkit,...)
})
setMethod(".focus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) focus(obj) <- TRUE)
## focus<-
setReplaceMethod("focus",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.focus(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".focus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
focus(obj@widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod("focus",signature(obj="RGtkObject"),
function(obj, ..., value) {
.focus(obj, toolkit=guiToolkit("RGtk2"),...) <- value
return(obj)
})
## window
setReplaceMethod(".focus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="GtkWindow"),
function(obj, toolkit, ..., value) {
value = as.logical(value)
if(value)
obj$GetWindow()$Raise()
else
obj$GetWindow()$Lower()
return(obj)
})
## other objects
setReplaceMethod(".focus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ..., value) {
value = as.logical(value)
if(value) {
obj$GrabFocus()
obj$GetParentWindow()$Raise()
} else {
obj$GetParentWindow()$Lower()
}
return(obj)
})
## tooltip<-
setReplaceMethod("tooltip",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.tooltip(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".tooltip",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
tooltip(obj@widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod("tooltip",signature(obj="RGtkObject"),
function(obj, ..., value) {
## set the tip.
obj$setTooltipText(paste(value, collapse="\n"))
## deprecated
## tooltipGroup <- try(gtkTooltips(), silent = TRUE)
## if(inherits(tooltipGroup, "try-error"))
## return(obj)
## ## some widgets don't allow a tooltip (glabel, ...)
## ## right check is widget.flags()>k.NO_WINDOW
## try(tooltipGroup$setTip(obj, tip.text = value), silent=TRUE)
return(obj)
})
## default Widget
## defaultWidget
setMethod("defaultWidget",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.defaultWidget(obj, obj@toolkit,...)
})
setMethod(".defaultWidget",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...)
getWidget(obj)['has-default']
)
## defaultWidget<-
setReplaceMethod("defaultWidget",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.defaultWidget(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod("defaultWidget",signature(obj="RGtkObject"),
function(obj, ..., value) {
.defaultWidget(obj, toolkit=guiToolkit("RGtk2"),...) <- value
return(obj)
})
setReplaceMethod(".defaultWidget",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
widget <- getWidget(obj)
.defaultWidget(widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod(".defaultWidget",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ..., value) {
value = as.logical(value)
obj['can-default'] <- value
obj$grabDefault()
# obj['receives-default'] <- value
return(obj)
})
## fonts
.font.styles = list(
family = c("normal","sans","serif","monospace"),
style = c("normal","oblique","italic"),
weight = c("ultra-light","light","normal","bold","ultra-bold","heavy"),
colors = c("black","blue","red","green","brown","yellow","pink")
)
## font sizes ## old defs for .PangoScale are no longer valid as of 10.4
fontSizes <- c(
"xx-large"= PANGO_SCALE_XX_LARGE,
"x-large" = PANGO_SCALE_X_LARGE,
"large" = PANGO_SCALE_LARGE,
"medium" = PANGO_SCALE_MEDIUM,
"small" = PANGO_SCALE_SMALL,
"x-small" = PANGO_SCALE_X_SMALL,
"xx-small" = PANGO_SCALE_XX_SMALL
)
setMethod("font",signature(obj="gWidgetRGtk"),
function(obj, ...) {
warning("font() not defined. Set fonts with font<-")
return()
.font(obj, obj@toolkit,...)
})
setMethod(".font",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="GtkWindow"),
function(obj, toolkit, ...) {
print("returning font information not yet implemented.")
})
## font<-
setReplaceMethod("font",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.font(obj, obj@toolkit,...) <- .fixFontMessUp(value)
return(obj)
})
setReplaceMethod(".font",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
.font(obj@widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod(".font",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ..., value) {
## value might be a vector, we use a list -- from .fixFontMessUp
if(!is.list(value)) {
tmp = value
value = list()
for(i in names(tmp)) value[[i]] = tmp[i]
}
string = ""
## do family, weight, style
for(i in c("family", "weight", "style")) {
if(!is.null(value[[i]])) {
x <- .font.styles[[i]]
ind <- charmatch(value[[i]], x)
if(!is.na(ind)) {
string <- paste(string, x[ind[1]], sep=" ")
if(i == "family")
string <- paste(string,",", sep="")
}
}
}
## size can be integer or name -- relative to 12pt
if(!is.null(value$size)) {
## is it numeric or character?
warn <- getOption("warn"); options(warn=2) # hack to avoid warning -- we want an error here
out <- try(as.integer(value[['size']]), silent=TRUE)
options(warn=warn)
if(!inherits(out, "try-error"))
string <- Paste(string," ",out)
else if (!is.na(ind <- charmatch(value[['size']], names(fontSizes)))) # fuzzy match?
string <- Paste(string, " ", paste(ceiling(12*fontSizes[ind[1]]),"px", sep=""))
}
string <- gsub(",$","",string) # strip , if present
if(string != "") {
fontDescr = pangoFontDescriptionFromString(string)
obj$ModifyFont(fontDescr)
}
## colors
if(!is.null(value$color))
obj$modifyFg(GtkStateType["normal"], value[['color']])
return(obj)
})
## tag, tag<-
setMethod("tag",signature(obj="gWidgetRGtk"),
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="RGtkObject"),
function(obj,i,drop=TRUE, ...) {
if(missing(drop)) drop <- TRUE
.tag(obj, guiToolkit("RGtk2"),i, drop=drop,...)
})
setMethod(".tag", signature(toolkit="guiWidgetsToolkitRGtk2",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="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, i, drop=TRUE, ...) {
if(missing(i)) i = NULL
if(missing(drop)) drop <- TRUE
.tag( obj@block,toolkit, i, drop=drop, ...)
})
setMethod(".tag", signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, i, drop=TRUE, ...) {
if(missing(i)) i = NULL
lst = obj$GetData(".tagKey")
if(is.null(i))
return(lst)
if(drop) {
if(length(i) == 1)
return(lst[[i]])
else
return(sapply(i, function(j) lst[j]))
} else {
return(sapply(i, function(j) lst[j]))
}
})
## tag <-
setReplaceMethod("tag",signature(obj="gWidgetRGtk"),
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="RGtkObject"),
function(obj,i, replace=TRUE, ..., value) {
.tag(obj, guiToolkit("RGtk2"),i, replace, ...) <- value
return(obj)
})
## objects can be in many different flavors: guiWIdget, gWidgetRGtk2, RGtkObject
setReplaceMethod(".tag", signature(toolkit="guiWidgetsToolkitRGtk2",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="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, i, replace=TRUE, ..., value) {
if(missing(i)) i = NULL
.tag( obj@block, toolkit, i, replace, ...) <- value
return(obj)
})
setReplaceMethod(".tag", signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, i, replace=TRUE, ..., value) {
if(missing(i) || is.null(i)) {
warning("Need to specify a key to the 'i' argument of tag<-")
} else {
allData = obj$GetData(".tagKey")
if(is.null(allData)) allData = list()
if(as.logical(replace)) {
allData[[i]] <- value
} else {
allData[[i]] <- c(allData[[i]], value)
}
obj$SetData(".tagKey", allData)
}
return(obj)
})
##################################################
## id -- define for "ANY" as well
setMethod("id",signature(obj="gWidgetRGtk"),
function(obj, ...) {
tag(obj,".gtkID")
})
setMethod("id",signature(obj="RGtkObject"),
function(obj, ...) {
tag(obj, ".gtkID", ...)
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="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
tag(obj,".gtkID", ...)
})
setMethod(".id", signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ...) {
return(tag(obj,".gtkID"))
})
## id<-
setReplaceMethod("id",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
tag(obj,".gtkID", ...) <- value
return(obj)
})
## dispatch in *this* toolkit, not present in obj
setReplaceMethod("id",signature(obj="RGtkObject"),
function(obj, ..., value) {
tag(obj, ".gtkID", ...) <- 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="guiWidgetsToolkitRGtk2",
obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
id(obj, ...) <- value
return(obj)
})
## add method is biggie
## we have several levels of classes here guiWidget -- gWidgetRGkt -- RGtkObject, when
## we get down to that level we can finally add
setMethod("add",signature(obj="gWidgetRGtk"),
function(obj, value, ...) {
.add(obj, obj@toolkit,value,...)
})
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",
obj="guiWidget", value="ANY"),
function(obj, toolkit, value, ...) {
cat(gettext("Can't add without a value\n"))
})
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",
obj="gWidgetRGtk", value="try-error"),
function(obj, toolkit, value, ...) {
gmessage(paste("Error:",value), title="Error adding oject",
icon="error")
})
## pushdonw
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",
obj="guiWidget", value="guiWidgetORgWidgetRGtkORRGtkObject"),
function(obj, toolkit, value, ...) {
.add(obj@widget, toolkit, value, ...)
})
## for gWindow
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",
obj="gContainerRGtk", value="guiWidget"),
function(obj, toolkit, value, ...) {
.add(obj, toolkit, value@widget, ...)
})
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk", value="gWidgetRGtk"),
function(obj, toolkit, value, ...) {
.add(obj, toolkit, value@block, ...)
})
## addSPring, addSpace
setMethod("addSpring",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.addSpring(obj, obj@toolkit,...)
})
setMethod(".addSpring",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk"),
function(obj, toolkit, ...) {
obj@widget$PackStart(gtkHBoxNew(),TRUE,TRUE,0) # expand and fill set to TRUE
})
setMethod("addSpace",signature(obj="gWidgetRGtk"),
function(obj, value, ...) {
.addSpace(obj,obj@toolkit,value,...)
})
setMethod(".addSpace",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk"),
function(obj, toolkit, value, ...) {
theArgs = list(...)
horizontal = ifelse(is.null(theArgs$horizontal),
TRUE,
as.logical(theArgs$horizontal))
if(horizontal) {
tmp = ggroup(); size(tmp) <- c(value,1)
} else {
tmp = ggroup(); size(tmp) <- c(1, value)
}
add(obj, tmp)
})
## delete -- get down to two RGtkObjects
setMethod("delete",signature(obj="gWidgetRGtk"),
function(obj, widget, ...) {
.delete(obj, obj@toolkit,widget,...)
})
## push down to RGtk vs RGtk. Can be 9 possiblities!
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk",widget="guiWidget"),
function(obj, toolkit, widget, ...) {
.delete(obj, toolkit, widget@widget, ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk",widget="gWidgetRGtk"),
function(obj, toolkit, widget, ...) {
.delete(obj@widget, toolkit, widget, ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject",widget="gWidgetRGtk"),
function(obj, toolkit, widget, ...) {
.delete(obj, toolkit, getBlock(widget), ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject",widget="guiWidget"),
function(obj, toolkit, widget, ...) {
.delete(obj, toolkit, widget@widget, ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk",widget="RGtkObject"),
function(obj, toolkit, widget, ...) {
.delete(obj@widget, toolkit, widget, ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject",widget="RGtkObject"),
function(obj, toolkit, widget, ...) {
## Remove after checking
if(!inherits(obj, "<invalid>") &&
!inherits(widget, "<invalid>") &&
widget$getParent() == obj) {
obj$Remove(widget)
}
return(TRUE)
})
## dispose -- delete the parent window, or something else
setMethod("dispose",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.dispose(obj, obj@toolkit,...)
})
setMethod(".dispose",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
widget = getWidget(obj)
if(inherits(widget,"GtkWindow")) {
widget$Destroy()
return(TRUE)
} else {
widget = widget$GetParentWindow()
if(inherits(widget,"<invalid>"))
return(FALSE)
else
widget$Destroy()
return(TRUE)
}
})
## update
setMethod("update",signature(object="gWidgetRGtk"),
function(object, ...) {
.update(object, object@toolkit, ...)
})
setMethod(".update",
signature(toolkit="guiWidgetsToolkitRGtk2",object="gComponentRGtk"),
function(object, toolkit, ...) {
object@widget$QueueDraw()
})
##
##
##################################################
##################################################
## handlers
##
## basic handler for adding with a signal. Now exported.
setGeneric("addhandler", function(obj, signal, handler, action=NULL, ...)
standardGeneric("addhandler"))
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="gWidgetRGtk"),
function(obj, signal, handler, action=NULL, ...) {
.addHandler(obj, obj@toolkit, signal, handler, action, ...)
})
setMethod("addhandler",signature(obj="RGtkObject"),
function(obj, signal, handler, action=NULL, ...) {
.addHandler(obj, guiToolkit("RGtk2"), signal, handler, action, ...)
})
setMethod("addHandler",signature(obj="gWidgetRGtk"),
function(obj, signal, handler, action=NULL, ...) {
.addHandler(obj@widget, obj@toolkit, signal, handler, action, ...)
})
setMethod(".addhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, signal, handler, action=NULL, ...) {
.addHandler(obj, obj@toolkit, signal, handler, action, ...)
})
## method for dispatch
setGeneric(".addHandler",
function(obj, toolkit,
signal, handler, action=NULL, ...)
standardGeneric(".addHandler"))
setMethod(".addHandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="guiWidget"),
function(obj, toolkit,
signal, handler, action=NULL, ...) {
.addHandler(obj@widget, toolkit, signal, handler, action, ...)
})
setMethod(".addHandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
signal, handler, action=NULL, ...) {
## need to return logical when an event, not always,
## but gives trouble if not
modifyHandler = function(...) {
val <- handler(...)
if(!is.logical(val))
return(TRUE)
else
return(val)
}
theArgs = list(...)
## fix value passed into gWidgets handlers
h <- list()
h$obj <- obj
if(!is.null(theArgs$actualobj)) {
h$obj <- theArgs$actualobj
theArgs$actualobj <- NULL
}
if(length(theArgs))
for(i in names(theArgs))
h[[i]] <- theArgs[[i]]
h$action <- action
callbackID <- gtktry(connectSignal(getWidget(obj), ### issue: getWidget(obj),
signal=signal,
f=modifyHandler,
data=h,
user.data.first = TRUE,
after = FALSE), silent=FALSE)
if(inherits(callbackID,"try-error")) {
gwCat(sprintf("Couldn't add signal %s for object of class %s",
signal, class(obj)[1]),"\n")
return(NA)
} else {
## now put handler into object
handler.ID = tag(obj, "handler.id")
if(is.null(handler.ID))
handler.ID =list()
handler.ID[[length(handler.ID)+1]] = callbackID
tag(obj, "handler.id") <- handler.ID
##
## addhandlerdestroy(obj, handler=function(h,...)
## removehandler(h$obj,h$action),
## action=ID)
## return ID
invisible(callbackID)
}
})
setMethod(".addHandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, signal, handler, action=NULL, ..., after=FALSE) {
theArgs = list(...)
## need to return FALSE to propogate to next handler on events
modifyHandler = function(h,...) {
handler(h,...)
return(FALSE)
}
## fix value passed into gWidgets handlers
h <- list()
h$obj <- obj
if(!is.null(theArgs$actualobj)) {
h$obj <- theArgs$actualobj
theArgs$actualobj <- NULL
}
## pass in extra values, eg addHandlerClicked(obj, f=FUN, extra=value) will h$extra key
if(length(theArgs))
for(i in names(theArgs))
h[[i]] <- theArgs[[i]]
h$action <- action
callbackID <- gtktry(gSignalConnect(obj,
signal=signal,
f=modifyHandler,
data=h,
user.data.first = TRUE,
after = after),
silent=TRUE)
## can't' stuff in handler IDS
if(inherits(callbackID,"try-error")) {
gwCat(sprintf("Couldn't connect signal: %s for object of class %s\n",
signal, class(obj)[1]))
return(NA)
} else {
## store ID into list
lst <- obj$getData("handler.id")
if(is.null(lst)) lst <- list()
lst <- c(lst,callbackID)
obj$setData("handler.id", lst)
invisible(callbackID)
}
})
## removehandler
setMethod("removehandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.removehandler(obj, obj@toolkit, ID, ...)
})
setMethod("removehandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.removehandler(obj, guiToolkit("RGtk2"), ID, ...)
})
### JV: Need to consolidate this and the next, The difference is the callbackIDS?
setMethod(".removehandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ID=NULL, ...) {
if(missing(ID))
callbackIDs = .tag(obj,toolkit,"handler.id")
else
callbackIDs = ID
## timeout handler?
if(class(callbackIDs) == "GTimeoutId") {
out <- sapply(callbackIDs, function(i) {
class(i) <- "GTimeoutId" # sapply strips attributes!
gSourceRemove(i)
})
return(out)
}
if(!is.null(callbackIDs)) {
if(!is.list(callbackIDs)) {
callbackIDs = list(callbackIDs)
}
widget = obj@widget
retval = logical(length(callbackIDs))
for(i in 1:length(callbackIDs)) {
if(is.list(callbackIDs[[i]])) # recurse if a list
for(i in callbackIDs[[i]]) .removehandler(obj, toolkit, i)
isCallbackID = gtktry(checkPtrType(callbackIDs[[i]],"CallbackID"),silent=TRUE)
if(!inherits(isCallbackID,"try-error")) {
retval[i] = gtktry(gSignalHandlerDisconnect(widget, callbackIDs[[1]]), silent=TRUE)
# retval[i] = gtktry(gtkObjectDisconnectCallbackHack(widget, callbackIDs[[i]]),
# silent=TRUE)
} else {
gwCat("DEBUG: ID not of callbackID\n")
retval[i] = FALSE
}
}
for(i in rev(which(retval==TRUE)))
callbackIDs[[i]] <- NULL
.tag(obj,toolkit, "handler.id", replace=FALSE) <- callbackIDs
return(retval)
} else {
return(FALSE)
}
})
## for RGtkObject
setMethod(".removehandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ID=NULL, ...) {
if(missing(ID))
callbackIDs = .tag(obj,toolkit,"handler.id")
else
callbackIDs = ID
if(!is.null(callbackIDs)) {
if(!is.list(callbackIDs)) {
callbackIDs = list(callbackIDs)
}
widget = obj
retval = c()
for(i in 1:length(callbackIDs)) {
if(is.list(callbackIDs[[i]])) # recurse if a list
for(i in callbackIDs[[i]]) .removehandler(obj, toolkit, i)
isCallbackID = gtktry(checkPtrType(callbackIDs[[i]],"CallbackID"),silent=TRUE)
if(!inherits(isCallbackID,"try-error")) {
retval[i] = widget$disconnectCallback(callbackIDs[[i]]) #gtkObjectDisconnectCallbackHack(widget, callbackIDs[[i]])
} else {
gwCat("DEBUG: ID not of callbackID\n")
retval[i] = FALSE
}
}
for(i in rev(which(retval==TRUE)))
callbackIDs[[i]] <- NULL
.tag(obj,toolkit, "handler.id", replace=FALSE) <- callbackIDs
return(retval)
} else {
return(FALSE)
}
})
## blockhandler
setMethod("blockhandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.blockhandler(obj, obj@toolkit, ID, ...)
})
setMethod("blockhandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.blockhandler(obj, guiToolkit("RGtk2"), ID, ...)
})
## caps
setMethod("blockHandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.blockhandler(obj, obj@toolkit, ID, ...)
})
setMethod("blockHandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.blockhandler(obj, guiToolkit("RGtk2"), ID, ...)
})
setMethod(".blockhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ID=NULL, ...) {
.blockhandler(getWidget(obj),toolkit,ID,...)
})
setMethod(".blockhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ID=NULL, ...) {
if(is.null(ID))
ID <- tag(obj,"handler.id")
lapply(ID, function(i)
gSignalHandlerBlock(obj,i))
return()
})
## unblock handler
setMethod("unblockhandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.unblockhandler(obj, obj@toolkit, ID, ...)
})
setMethod("unblockhandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.unblockhandler(obj, guiToolkit("RGtk2"), ID, ...)
})
## camelcase
setMethod("unblockHandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.unblockhandler(obj, obj@toolkit, ID, ...)
})
setMethod("unblockHandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.unblockhandler(obj, guiToolkit("RGtk2"), ID, ...)
})
setMethod(".unblockhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ID=NULL, ...) {
.unblockhandler(getWidget(obj),toolkit,ID,...)
})
setMethod(".unblockhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ID=NULL, ...) {
if(is.null(ID))
ID <- tag(obj,"handler.id")
sapply(ID, function(i)
gSignalHandlerUnblock(obj,i))
return()
})
## addhandlerchanged
setMethod("addhandlerchanged",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerchanged(obj, obj@toolkit, handler, action, ...)
})
setMethod("addhandlerchanged",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerchanged(obj, guiToolkit("RGtk2"), handler, action, ...)
})
setMethod("addhandlerchanged",signature(obj="ANY"),
function(obj, handler=NULL, action=NULL, ...) {
warning("No method addhandlerchanged for object of class",class(obj),"\n")
})
## caps
setMethod("addHandlerChanged",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerchanged(obj, obj@toolkit, handler, action, ...)
})
setMethod("addHandlerChanged",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerchanged(obj, guiToolkit("RGtk2"), handler, action, ...)
})
setMethod(".addhandlerchanged",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="changed",
handler=handler, action=action, ...)
})
## expose: expose-event or realize
setMethod("addhandlerexpose",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerexpose(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerexpose",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerexpose(obj, guiToolkit("RGtk2"), handler, action, ...)
})
setMethod(".addhandlerexpose",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="expose-event",
handler=handler, action=action, ...)
})
setMethod(".addhandlerexpose",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gComponentRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj,toolkit, signal="realize",
handler=handler, action=action, ...)
})
## unrealize: unrealize
setMethod("addhandlerunrealize",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerunrealize(obj, obj@toolkit,handler, action, ...)
})
setMethod("addhandlerunrealize",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerunrealize(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerunrealize",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="unrealize",
handler=handler, action=action, ...)
})
## destroy: destroy
setMethod("addhandlerdestroy",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdestroy(obj, obj@toolkit,handler, action, ...)
})
setMethod("addhandlerdestroy",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdestroy(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerdestroy",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
## See
## http://www.moeraki.com/pygtktutorial/pygtk2tutorial/sec-SteppingThroughHelloWorld.html
## for difference between "destroy" and "delete-event"
.addHandler(obj, toolkit, signal="destroy",
handler=handler, action=action, ...)
})
## keystroke: changed
setMethod("addhandlerkeystroke",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerkeystroke(obj, obj@toolkit,handler, action, ...)
})
setMethod("addhandlerkeystroke",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerkeystroke(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerkeystroke",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="changed",
handler=handler, action=action, ...)
})
## clicked: clicked
setMethod("addhandlerclicked",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerclicked(obj, obj@toolkit,handler, action, ...)
})
setMethod("addhandlerclicked",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerclicked(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## caps
setMethod("addHandlerClicked",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerclicked(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerClicked",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerclicked(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerclicked",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="clicked",
handler=handler, action=action, ...)
})
setMethod(".addhandlerclicked",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="clicked",
handler=handler, action=action, ...)
})
## doubleclick: no default
setMethod("addhandlerdoubleclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdoubleclick(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerdoubleclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdoubleclick(obj,guiToolkit("RGtk2"),handler, action, ...)
})
## caps
setMethod("addHandlerDoubleclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdoubleclick(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerDoubleclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdoubleclick(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerdoubleclick",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
warning("No default handler for double click")
})
## rightclick: button-press-event -- handle separately
setMethod("addhandlerrightclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerrightclick(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerrightclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerrightclick(obj,guiToolkit("RGtk2"),handler, action, ...)
})
## caps
setMethod("addHandlerRightclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerrightclick(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerRightclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerrightclick(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## use actualobj=obj to pass in a different obj to h$obj
## use actualobj=obj to pass in a different obj to h$obj
setMethod(".addhandlerrightclick",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addhandlerrightclick(getWidget(obj), toolkit, handler, action, actualobj=obj,...)
})
setMethod(".addhandlerrightclick",
# signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit,
handler, action=NULL, ..., after=FALSE) {
theArgs = list(...)
## fix value passed into gWidgets handlers
h <- list()
h$handler <- handler
h$obj <- obj
if(!is.null(theArgs$actualobj)) {
h$obj <- theArgs$actualobj
theArgs$actualobj <- NULL
}
## pass in extra values, eg addHandlerClicked(obj, f=FUN, extra=value) will h$extra key
if(length(theArgs))
for(i in names(theArgs))
h[[i]] <- theArgs[[i]]
h$action <- action
gtktry(connectSignal(getWidget(obj),
signal = "button-press-event",
f = function(h, w, eventButton,...) {
if(isRightMouseClick(eventButton)) {
h$handler(h,w, eventButton, ...)
}
return(FALSE) # stop propagation
},
data = h,
user.data.first = TRUE,
after = after
),
silent=TRUE)
})
### Column click things
## click: no default
setMethod("addhandlercolumnclicked",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnclicked(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlercolumnclicked",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnclicked(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod("addHandlerColumnClicked",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnclicked(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerColumnClicked",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnclicked(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## doubleclick: no default
setMethod("addhandlercolumndoubleclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumndoubleclick(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlercolumndoubleclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumndoubleclick(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod("addHandlerColumnDoubleclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumndoubleclick(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerColumnDoubleclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumndoubleclick(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## rightclick
setMethod("addhandlercolumnrightclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnrightclick(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlercolumnrightclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnrightclick(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod("addHandlerColumnRightclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnrightclick(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerColumnRightclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnrightclick(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## focus -- on focus call this
setMethod("addhandlerfocus",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerfocus(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerfocus",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerfocus(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerfocus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj,toolkit,
signal="focus-in-event",
handler, action, ...)
})
## blur -- leave focus
setMethod("addhandlerblur",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerblur(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerblur",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerblur(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerblur",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
## blur handler should return FALSE
f <- function(h,...) {
handler(h,...)
return(FALSE)
}
.addHandler(obj,toolkit,
signal="focus-out-event",
f, action, ...)
})
##
## mousemotion -- like mouseover
setMethod("addhandlermousemotion",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlermousemotion(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlermousemotion",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlermousemotion(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlermousemotion",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj,guiToolkit("RGtk2"),
signal="enter-notify-event",
handler, action, ...)
})
## idle
setMethod("addhandleridle",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, interval=1000, ...) {
.addhandleridle(obj, obj@toolkit,
handler=handler, action=action, interval=interval, ...)
})
setMethod("addhandleridle",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, interval=1000, ...) {
.addhandleridle(obj, guiToolkit("RGtk2"),
handler=handler, action=action, interval=interval, ...)
})
setMethod(".addhandleridle",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler=NULL, action=NULL, interval=1000, ...) {
idlehandler = function(h,...) {
if(!is.null(h$handler) && is.function(h$handler))
h$handler(h,...)
invisible(TRUE)
}
## ID = gtkAddTimeout(
ID = gTimeoutAdd(
interval,
idlehandler,
data=list(obj=obj, action=action, handler=handler)
)
## tidy up when done
.addhandlerdestroy(obj,toolkit, handler=function(h,...) {
# gtkRemoveTimeout(h$action)
gSourceRemove(h$action)
},action=ID)
invisible(ID)
})
## addpopumenu
setMethod("addpopupmenu",signature(obj="gWidgetRGtk"),
function(obj, menulist, action=NULL, ...) {
.addpopupmenu(obj, obj@toolkit,menulist, action, ...)
})
setMethod("addpopupmenu",signature(obj="RGtkObject"),
function(obj, menulist, action=NULL, ...) {
.addpopupmenu(obj, guiToolkit("RGtk2"), menulist, action, ...)
})
## this does not get exported
addPopupMenuWithSignal = function(obj, toolkit, menulist, action=NULL, signal="button-press-event", ...) {
theArgs = list(...)
f = function(h, ...) {
mb = gmenu(h$action, popup = TRUE)
event = gdkEventNew(GdkEventType["button-press"])
mb = tag(mb,"mb") # the real menu bar
gtkMenuPopupHack(mb, button = event$GetButton(),
activate.time=event$GetTime()
)
}
## .addhandler not exported
callbackID = .addHandler(obj,toolkit, signal = signal,handler=f, action=menulist)
invisible(callbackID)
}
add3rdMousePopupMenuWithSignal = function(obj, toolkit, menulist, action=NULL, signal="button-press-event", ...) {
f = function(h, widget, event,...) {
## Mac use ctrl - button 1
if(isRightMouseClick(event)) {
mb = gmenu(h$action$menulist, popup = TRUE, action=h$action$passedaction)
mb = tag(mb,"mb") # actual widget
gtkMenuPopupHack(mb,button = event$GetButton(),
activate.time=event$GetTime()
)
return(FALSE)
} else {
return(FALSE)
}
}
callbackID = .addHandler(obj,toolkit, signal = "button-press-event",handler=f, action=list(menulist=menulist, passedaction=action))
invisible(callbackID)
}
### need to deal with action
setMethod(".addpopupmenu",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, menulist, action=NULL, ...) {
addPopupMenuWithSignal(obj, toolkit, menulist, ...)
})
## add3rdmousepopupmenu
setMethod("add3rdmousepopupmenu",signature(obj="gWidgetRGtk"),
function(obj, menulist, action=NULL, ...) {
.add3rdmousepopupmenu(obj, obj@toolkit,menulist, action, ...)
})
setMethod("add3rdmousepopupmenu",signature(obj="RGtkObject"),
function(obj, menulist, action=NULL,...) {
.add3rdmousepopupmenu(obj, guiToolkit("RGtk2"),menulist, action,...)
})
setMethod(".add3rdmousepopupmenu",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, menulist,action=NULL, ...) {
add3rdMousePopupMenuWithSignal(obj, toolkit,
menulist, action, ...)
})
setMethod(".add3rdmousepopupmenu",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, menulist, action=NULL, ...) {
add3rdMousePopupMenuWithSignal(obj, toolkit,
menulist, action, ...)
})
## "dotmethods" defined in dnd.R
## adddropsource
setMethod("adddropsource",signature(obj="gWidgetRGtk"),
function(obj, targetType="text", handler=NULL, action=NULL, ...) {
.adddropsource(obj, obj@toolkit,targetType=targetType,
handler=handler, action=action, ...)
})
setMethod("adddropsource",signature(obj="RGtkObject"),
function(obj, targetType="text", handler=NULL, action=NULL, ...) {
.adddropsource(obj, guiToolkit("RGtk2"),targetType=targetType,
handler=handler, action=action, ...)
})
## adddropmotion
setMethod("adddropmotion",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.adddropmotion(obj, obj@toolkit,
handler=handler, action=action, ...)
})
setMethod("adddropmotion",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.adddropmotion(obj, guiToolkit("RGtk2"),
handler=handler, action=action, ...)
})
## adddroptarget
setMethod("adddroptarget",signature(obj="gWidgetRGtk"),
function(obj, targetType="text", handler=NULL, action=NULL, ...) {
.adddroptarget(obj, obj@toolkit,targetType=targetType,
handler=handler, action=action, ...)
})
setMethod("adddroptarget",signature(obj="RGtkObject"),
function(obj, targetType="text", handler=NULL, action=NULL, ...) {
.adddroptarget(obj, guiToolkit("RGtk2"),targetType=targetType,
handler=handler, action=action, ...)
})
## R Methods
setMethod("dim", "gWidgetRGtk", function(x) .dim(x,x@toolkit))
setMethod("length", "gWidgetRGtk", function(x) .length(x,x@toolkit))
setMethod(".length",
signature(toolkit="guiWidgetsToolkitRGtk2",x="gWidgetRGtk"),
function(x,toolkit) {
return(NA)
gwCat(sprintf("Define length for x of class: %s\n", class(x)[1]))
})
setMethod("dimnames", "gWidgetRGtk", function(x) .dimnames(x,x@toolkit))
setReplaceMethod("dimnames",
signature(x="gWidgetRGtk"),
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", "gWidgetRGtk", function(x) .names(x,x@toolkit))
setReplaceMethod("names",
signature(x="gWidgetRGtk"),
function(x,value) {
.names(x,x@toolkit) <- value
return(x)
})
#### This may be useful to integrate gWidgets with glade
####
## S3 class for coercing to gWidget
as.gWidgetsRGtk2 <- function(widget,...) UseMethod("as.gWidgetsRGtk2")
as.gWidgetsRGtk2.default <- function(widget,...) {
print(sprintf("No coercion to gWidget available for object of class %s",class(widget)))
return(widget)
}
Try the gWidgetsRGtk2 package in your browser
Any scripts or data that you put into this service are public.
gWidgetsRGtk2 documentation built on May 2, 2019, 5:58 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions addPopupMenuWithSignal add3rdMousePopupMenuWithSignal as.gWidgetsRGtk2 as.gWidgetsRGtk2.default
Documented in as.gWidgetsRGtk2
## toolkit class
## register classes here for toolkits
## setClass("guiWidgetsToolkitRGtk2",
## contains="guiWidgetsToolkit",
## prototype=prototype(new("guiWidgetsToolkit"))
## )
##################################################
## put S3 classes from RGtk2 into S4 classes
## got these from apropos("New") -> try(class(do.call(i,list())))
oldClasses =
c(
"AtkNoOpObjectFactory",
"AtkObjectFactory",
"AtkRelationSet",
"AtkStateSet",
"GBoxed",
"GObject",
"GScanner",
"GdkDragContext",
"GdkPixbufLoader",
"GdkRegion",
"GtkAboutDialog",
"GtkAccelGroup",
"GtkAccelLabel",
"GtkAction",
"GtkActionGroup",
"GtkAdjustment",
"GtkAlignment",
"GtkArrow",
"GtkAspectFrame",
"GtkBin",
"GtkBox",
"GtkButton",
"GtkButtonBox",
"GtkCList",
"GtkCTree",
"GtkCalendar",
"GtkCellRenderer",
"GtkCellRendererCombo",
"GtkCellRendererPixbuf",
"GtkCellRendererProgress",
"GtkCellRendererText",
"GtkCellRendererToggle",
"GtkCellView",
"GtkCheckButton",
"GtkCheckMenuItem",
"GtkColorButton",
"GtkColorSelection",
"GtkColorSelectionDialog",
"GtkCombo",
"GtkComboBox",
"GtkComboBoxEntry",
"GtkContainer",
"GtkCurve",
"GtkDialog",
"GtkDrawingArea",
"GtkEntry",
"GtkEntryCompletion",
"GtkEventBox",
"GtkExpander",
"GtkFileFilter",
"GtkFileSelection",
"GtkFileChooserWidget",
"GtkFixed",
"GtkFontButton",
"GtkFontSelection",
"GtkFontSelectionDialog",
"GtkFrame",
"GtkGammaCurve",
"GtkHBox",
"GtkHButtonBox",
"GtkHPaned",
"GtkHRuler",
"GtkHScale",
"GtkHScrollbar",
"GtkHSeparator",
"GtkHandleBox",
"GtkIMContext",
"GtkIMContextSimple",
"GtkIMMulticontext",
"GtkIconFactory",
"GtkIconSet",
"GtkIconSource",
"GtkIconTheme",
"GtkIconView",
"GtkImage",
"GtkImageMenuItem",
"GtkInfoBar",
"GtkInputDialog",
"GtkInvisible",
"GtkItem",
"GtkLabel",
"GtkLayout",
"GtkList",
"GtkListItem",
"GtkMenu",
"GtkMenuBar",
"GtkMenuItem",
"GtkMenuShell",
"GtkMisc",
"GtkNotebook",
"GtkObject",
"GtkOptionMenu",
"GtkPaned",
"GtkProgress",
"GtkProgressBar",
"GtkRadioAction",
"GtkRadioButton",
"GtkRange",
"GtkRcStyle",
"GtkRuler",
"GtkScale",
"GtkScrollbar",
"GtkScrolledWindow",
"GtkSeparator",
"GtkSeparatorMenuItem",
"GtkSeparatorToolItem",
"GtkSizeGroup",
"GtkSocket",
"GtkSpinButton",
"GtkStatusbar",
"GtkStyle",
"GtkTable",
"GtkTearoffMenuItem",
"GtkTextAttributes",
"GtkTextBuffer",
"GtkTextChildAnchor",
"GtkTextTag",
"GtkTextTagTable",
"GtkTextView",
"GtkTipsQuery",
"GtkToggleAction",
"GtkToggleButton",
"GtkToggleToolButton",
"GtkToolButton",
"GtkToolItem",
"GtkToolbar",
"GtkTooltips",
"GtkTreeModelSort",
"GtkTreePath",
"GtkTreeStore",
"GtkTreeView",
"GtkTreeViewColumn",
"GtkUIManager",
"GtkVBox",
"GtkVButtonBox",
"GtkVPaned",
"GtkVRuler",
"GtkVScale",
"GtkVScrollbar",
"GtkVSeparator",
"GtkViewport",
"GtkWidget",
"GtkWindow",
"GtkWindowGroup",
##
"PangoAttrList",
"PangoCairoFcFontMap",
"PangoCoverage",
"PangoFcFontMap",
"PangoFontDescription",
"PangoFontMap",
"PangoGlyphString",
"PangoItem",
"GObject",
"RGtkDataFrame",
## add in others that come up
"GtkTreeSelection"
)
setOldClass("RGtkObject")
lapply(oldClasses, function(i) {
setOldClass(i)
setIs(i,"RGtkObject")
})
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
setClass("gWidgetRGtk")
## this worked in 2.4.0 but not later, remove
##setIs("guiWidget","guiWidgetORgWidgetRGtkORRGtkObject")
##setIs("gWidgetRGtk","guiWidgetORgWidgetRGtkORRGtkObject")
##setIs("RGtkObject","guiWidgetORgWidgetRGtkORRGtkObject")
setClassUnion("guiWidgetORgWidgetRGtkORRGtkObject",
c("guiWidget","gWidgetRGtk","RGtkObject"))
## subclss
## This behaviour changed in R as of 2.7.0. We throw in the towel here and use "ANY and not the preferred guiWidgetORgWidgetRGtkORRGtkObject
##.Rversion <- R.Version()
##if(.Rversion$major == "2" && .Rversion$minor == "7.0" ) {
setClass("gComponentRGtk",
representation(
block="ANY",
widget="ANY",
toolkit="guiWidgetsToolkit"
),
contains="gWidgetRGtk",
)
setClass("gContainerRGtk",
representation(
block="ANY",
widget="ANY",
toolkit="guiWidgetsToolkit"
),
contains="gWidgetRGtk",
)
## } else {
## setClass("gComponentRGtk",
## representation(
## block="guiWidgetORgWidgetRGtkORRGtkObject",
## widget="guiWidgetORgWidgetRGtkORRGtkObject",
## toolkit="guiWidgetsToolkit"
## ),
## contains="gWidgetRGtk",
## )
## setClass("gContainerRGtk",
## representation(
## block="guiWidgetORgWidgetRGtkORRGtkObject",
## widget="guiWidgetORgWidgetRGtkORRGtkObject",
## toolkit="guiWidgetsToolkit"
## ),
## contains="gWidgetRGtk",
## )
## }
##################################################
### 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="gWidgetRGtk"),
function(obj, index=NULL, drop=NULL, ...) {
.svalue(obj, obj@toolkit, index=index, drop=drop, ...)
})
## svalue
## need method for character
setMethod("svalue",signature(obj="character"),
function(obj, index=NULL, drop=NULL, ...) {
ifelse(length(obj) == 1,
return(getObjectFromString(obj)),
return(obj)
)
})
setMethod(".svalue",signature(toolkit = "guiWidgetsToolkitRGtk2", 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="gWidgetRGtk"),
function(obj, index=NULL, ...,value) {
.svalue(obj, obj@toolkit, index=index, ...) <- value
obj
})
## [
setMethod("[",
signature(x="gWidgetRGtk"),
function(x,i,j,...,drop=TRUE) {
return(.leftBracket(x, x@toolkit,i,j,...,drop=TRUE))
# if(missing(i) && missing(j))
# .leftBracket(x@widget, toolkit,,,...,drop=TRUE)
# else if(missing(j))
# .leftBracket(x@widget, toolkit,i,,...,drop=TRUE)
# else
# .leftBracket(x@widget, toolkit,i,j,...,drop=TRUE)
})
## [<-
setReplaceMethod("[",signature(x="gWidgetRGtk"),
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="gWidgetRGtk"),
function(obj, ...) {
return()
.size(obj, obj@toolkit,...)
})
setMethod(".size",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
## send to gWidgetRGtk2
.size(obj@widget, toolkit, ...)
})
setMethod(".size",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ...) {
## get from SizeAllocation()
val <- obj$GetAllocation()
return(c(width=val$width, height=val$height))
})
## not needed?
setMethod(".size",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="GtkWindow"),
function(obj, toolkit, ...) {
print("returning size information not yet implemented.")
})
## size<-
setReplaceMethod("size",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.size(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".size",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
if(length(value) >= 2) {
width <- value[1]; height <- value[2]
} else if(names(value) == "height") {
width <- -1; height <- value
} else {
width <- value; height <- -1
}
widget = obj@widget
widget$SetSizeRequest(width,height)
# widget$SetDefaultSize(width,height)
return(obj)
})
## visible
setMethod("visible",signature(obj="gWidgetRGtk"),
function(obj, set=NULL, ...) {
.visible(obj,obj@toolkit, set=set, ...)
})
setMethod(".visible",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, set=TRUE, ...) {
widget <- getWidget(obj)
if(is.null(set))
widget['visible']
else
if(as.logical(set))
widget$Show()
else
widget$Hide()
})
## visible<-
setReplaceMethod("visible",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.visible(obj, obj@toolkit, ...) <- value
return(obj)
})
setReplaceMethod(".visible",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
visible(obj, value)
return(obj)
})
## isExtant -- can we see the window
setMethod("isExtant",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.isExtant(obj,obj@toolkit, ...)
})
setMethod(".isExtant",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
widget = getWidget(obj)
if(is.null(widget)) return(FALSE)
!inherits(widget,"<invalid>") # test to see if destroyed
})
## enabled -- not implemeneted, don't know how to find sensitive. Would need to keep in
## in the widget using tag or somesuch
setMethod("enabled",signature(obj="gWidgetRGtk"),
function(obj, ...) {
warning("enable not defined, try enabled<-()")
return(NA)
.enabled(obj, obj@toolkit,...)
})
setMethod(".enabled",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
widget <- getWidget(obj)
if("sensitive" %in% names(widget))
widget['sensitive']
else
TRUE
})
setMethod(".enabled",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="GtkWindow"),
function(obj, toolkit, ...) {
print("returning enabled information not yet implemented.")
})
## enabled<-
setReplaceMethod("enabled",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.enabled(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".enabled",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
widget = getWidget(obj)
.enabled(widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod(".enabled",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ..., value) {
obj$SetSensitive(as.logical(value))
return(obj)
})
## editable -- can the widget be edited
setMethod("editable",signature(obj="gWidgetRGtk"),
function(obj, ...) {
return()
.editable(obj, obj@toolkit,...)
})
setMethod(".editable",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
message("no default editable method")
})
## editable<-
setReplaceMethod("editable",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.editable(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".editable",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
message("no default editable<- method")
return(obj)
})
## focus
setMethod("focus",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.focus(obj, obj@toolkit,...)
})
setMethod(".focus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) focus(obj) <- TRUE)
## focus<-
setReplaceMethod("focus",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.focus(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".focus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
focus(obj@widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod("focus",signature(obj="RGtkObject"),
function(obj, ..., value) {
.focus(obj, toolkit=guiToolkit("RGtk2"),...) <- value
return(obj)
})
## window
setReplaceMethod(".focus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="GtkWindow"),
function(obj, toolkit, ..., value) {
value = as.logical(value)
if(value)
obj$GetWindow()$Raise()
else
obj$GetWindow()$Lower()
return(obj)
})
## other objects
setReplaceMethod(".focus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ..., value) {
value = as.logical(value)
if(value) {
obj$GrabFocus()
obj$GetParentWindow()$Raise()
} else {
obj$GetParentWindow()$Lower()
}
return(obj)
})
## tooltip<-
setReplaceMethod("tooltip",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.tooltip(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod(".tooltip",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
tooltip(obj@widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod("tooltip",signature(obj="RGtkObject"),
function(obj, ..., value) {
## set the tip.
obj$setTooltipText(paste(value, collapse="\n"))
## deprecated
## tooltipGroup <- try(gtkTooltips(), silent = TRUE)
## if(inherits(tooltipGroup, "try-error"))
## return(obj)
## ## some widgets don't allow a tooltip (glabel, ...)
## ## right check is widget.flags()>k.NO_WINDOW
## try(tooltipGroup$setTip(obj, tip.text = value), silent=TRUE)
return(obj)
})
## default Widget
## defaultWidget
setMethod("defaultWidget",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.defaultWidget(obj, obj@toolkit,...)
})
setMethod(".defaultWidget",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...)
getWidget(obj)['has-default']
)
## defaultWidget<-
setReplaceMethod("defaultWidget",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.defaultWidget(obj, obj@toolkit,...) <- value
return(obj)
})
setReplaceMethod("defaultWidget",signature(obj="RGtkObject"),
function(obj, ..., value) {
.defaultWidget(obj, toolkit=guiToolkit("RGtk2"),...) <- value
return(obj)
})
setReplaceMethod(".defaultWidget",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
widget <- getWidget(obj)
.defaultWidget(widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod(".defaultWidget",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ..., value) {
value = as.logical(value)
obj['can-default'] <- value
obj$grabDefault()
# obj['receives-default'] <- value
return(obj)
})
## fonts
.font.styles = list(
family = c("normal","sans","serif","monospace"),
style = c("normal","oblique","italic"),
weight = c("ultra-light","light","normal","bold","ultra-bold","heavy"),
colors = c("black","blue","red","green","brown","yellow","pink")
)
## font sizes ## old defs for .PangoScale are no longer valid as of 10.4
fontSizes <- c(
"xx-large"= PANGO_SCALE_XX_LARGE,
"x-large" = PANGO_SCALE_X_LARGE,
"large" = PANGO_SCALE_LARGE,
"medium" = PANGO_SCALE_MEDIUM,
"small" = PANGO_SCALE_SMALL,
"x-small" = PANGO_SCALE_X_SMALL,
"xx-small" = PANGO_SCALE_XX_SMALL
)
setMethod("font",signature(obj="gWidgetRGtk"),
function(obj, ...) {
warning("font() not defined. Set fonts with font<-")
return()
.font(obj, obj@toolkit,...)
})
setMethod(".font",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="GtkWindow"),
function(obj, toolkit, ...) {
print("returning font information not yet implemented.")
})
## font<-
setReplaceMethod("font",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
.font(obj, obj@toolkit,...) <- .fixFontMessUp(value)
return(obj)
})
setReplaceMethod(".font",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
.font(obj@widget, toolkit, ...) <- value
return(obj)
})
setReplaceMethod(".font",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ..., value) {
## value might be a vector, we use a list -- from .fixFontMessUp
if(!is.list(value)) {
tmp = value
value = list()
for(i in names(tmp)) value[[i]] = tmp[i]
}
string = ""
## do family, weight, style
for(i in c("family", "weight", "style")) {
if(!is.null(value[[i]])) {
x <- .font.styles[[i]]
ind <- charmatch(value[[i]], x)
if(!is.na(ind)) {
string <- paste(string, x[ind[1]], sep=" ")
if(i == "family")
string <- paste(string,",", sep="")
}
}
}
## size can be integer or name -- relative to 12pt
if(!is.null(value$size)) {
## is it numeric or character?
warn <- getOption("warn"); options(warn=2) # hack to avoid warning -- we want an error here
out <- try(as.integer(value[['size']]), silent=TRUE)
options(warn=warn)
if(!inherits(out, "try-error"))
string <- Paste(string," ",out)
else if (!is.na(ind <- charmatch(value[['size']], names(fontSizes)))) # fuzzy match?
string <- Paste(string, " ", paste(ceiling(12*fontSizes[ind[1]]),"px", sep=""))
}
string <- gsub(",$","",string) # strip , if present
if(string != "") {
fontDescr = pangoFontDescriptionFromString(string)
obj$ModifyFont(fontDescr)
}
## colors
if(!is.null(value$color))
obj$modifyFg(GtkStateType["normal"], value[['color']])
return(obj)
})
## tag, tag<-
setMethod("tag",signature(obj="gWidgetRGtk"),
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="RGtkObject"),
function(obj,i,drop=TRUE, ...) {
if(missing(drop)) drop <- TRUE
.tag(obj, guiToolkit("RGtk2"),i, drop=drop,...)
})
setMethod(".tag", signature(toolkit="guiWidgetsToolkitRGtk2",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="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, i, drop=TRUE, ...) {
if(missing(i)) i = NULL
if(missing(drop)) drop <- TRUE
.tag( obj@block,toolkit, i, drop=drop, ...)
})
setMethod(".tag", signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, i, drop=TRUE, ...) {
if(missing(i)) i = NULL
lst = obj$GetData(".tagKey")
if(is.null(i))
return(lst)
if(drop) {
if(length(i) == 1)
return(lst[[i]])
else
return(sapply(i, function(j) lst[j]))
} else {
return(sapply(i, function(j) lst[j]))
}
})
## tag <-
setReplaceMethod("tag",signature(obj="gWidgetRGtk"),
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="RGtkObject"),
function(obj,i, replace=TRUE, ..., value) {
.tag(obj, guiToolkit("RGtk2"),i, replace, ...) <- value
return(obj)
})
## objects can be in many different flavors: guiWIdget, gWidgetRGtk2, RGtkObject
setReplaceMethod(".tag", signature(toolkit="guiWidgetsToolkitRGtk2",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="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, i, replace=TRUE, ..., value) {
if(missing(i)) i = NULL
.tag( obj@block, toolkit, i, replace, ...) <- value
return(obj)
})
setReplaceMethod(".tag", signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, i, replace=TRUE, ..., value) {
if(missing(i) || is.null(i)) {
warning("Need to specify a key to the 'i' argument of tag<-")
} else {
allData = obj$GetData(".tagKey")
if(is.null(allData)) allData = list()
if(as.logical(replace)) {
allData[[i]] <- value
} else {
allData[[i]] <- c(allData[[i]], value)
}
obj$SetData(".tagKey", allData)
}
return(obj)
})
##################################################
## id -- define for "ANY" as well
setMethod("id",signature(obj="gWidgetRGtk"),
function(obj, ...) {
tag(obj,".gtkID")
})
setMethod("id",signature(obj="RGtkObject"),
function(obj, ...) {
tag(obj, ".gtkID", ...)
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="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
tag(obj,".gtkID", ...)
})
setMethod(".id", signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ...) {
return(tag(obj,".gtkID"))
})
## id<-
setReplaceMethod("id",signature(obj="gWidgetRGtk"),
function(obj, ..., value) {
tag(obj,".gtkID", ...) <- value
return(obj)
})
## dispatch in *this* toolkit, not present in obj
setReplaceMethod("id",signature(obj="RGtkObject"),
function(obj, ..., value) {
tag(obj, ".gtkID", ...) <- 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="guiWidgetsToolkitRGtk2",
obj="gWidgetRGtk"),
function(obj, toolkit, ..., value) {
id(obj, ...) <- value
return(obj)
})
## add method is biggie
## we have several levels of classes here guiWidget -- gWidgetRGkt -- RGtkObject, when
## we get down to that level we can finally add
setMethod("add",signature(obj="gWidgetRGtk"),
function(obj, value, ...) {
.add(obj, obj@toolkit,value,...)
})
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",
obj="guiWidget", value="ANY"),
function(obj, toolkit, value, ...) {
cat(gettext("Can't add without a value\n"))
})
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",
obj="gWidgetRGtk", value="try-error"),
function(obj, toolkit, value, ...) {
gmessage(paste("Error:",value), title="Error adding oject",
icon="error")
})
## pushdonw
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",
obj="guiWidget", value="guiWidgetORgWidgetRGtkORRGtkObject"),
function(obj, toolkit, value, ...) {
.add(obj@widget, toolkit, value, ...)
})
## for gWindow
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",
obj="gContainerRGtk", value="guiWidget"),
function(obj, toolkit, value, ...) {
.add(obj, toolkit, value@widget, ...)
})
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk", value="gWidgetRGtk"),
function(obj, toolkit, value, ...) {
.add(obj, toolkit, value@block, ...)
})
## addSPring, addSpace
setMethod("addSpring",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.addSpring(obj, obj@toolkit,...)
})
setMethod(".addSpring",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk"),
function(obj, toolkit, ...) {
obj@widget$PackStart(gtkHBoxNew(),TRUE,TRUE,0) # expand and fill set to TRUE
})
setMethod("addSpace",signature(obj="gWidgetRGtk"),
function(obj, value, ...) {
.addSpace(obj,obj@toolkit,value,...)
})
setMethod(".addSpace",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk"),
function(obj, toolkit, value, ...) {
theArgs = list(...)
horizontal = ifelse(is.null(theArgs$horizontal),
TRUE,
as.logical(theArgs$horizontal))
if(horizontal) {
tmp = ggroup(); size(tmp) <- c(value,1)
} else {
tmp = ggroup(); size(tmp) <- c(1, value)
}
add(obj, tmp)
})
## delete -- get down to two RGtkObjects
setMethod("delete",signature(obj="gWidgetRGtk"),
function(obj, widget, ...) {
.delete(obj, obj@toolkit,widget,...)
})
## push down to RGtk vs RGtk. Can be 9 possiblities!
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk",widget="guiWidget"),
function(obj, toolkit, widget, ...) {
.delete(obj, toolkit, widget@widget, ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gContainerRGtk",widget="gWidgetRGtk"),
function(obj, toolkit, widget, ...) {
.delete(obj@widget, toolkit, widget, ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject",widget="gWidgetRGtk"),
function(obj, toolkit, widget, ...) {
.delete(obj, toolkit, getBlock(widget), ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject",widget="guiWidget"),
function(obj, toolkit, widget, ...) {
.delete(obj, toolkit, widget@widget, ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk",widget="RGtkObject"),
function(obj, toolkit, widget, ...) {
.delete(obj@widget, toolkit, widget, ...)
})
setMethod(".delete",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject",widget="RGtkObject"),
function(obj, toolkit, widget, ...) {
## Remove after checking
if(!inherits(obj, "<invalid>") &&
!inherits(widget, "<invalid>") &&
widget$getParent() == obj) {
obj$Remove(widget)
}
return(TRUE)
})
## dispose -- delete the parent window, or something else
setMethod("dispose",signature(obj="gWidgetRGtk"),
function(obj, ...) {
.dispose(obj, obj@toolkit,...)
})
setMethod(".dispose",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ...) {
widget = getWidget(obj)
if(inherits(widget,"GtkWindow")) {
widget$Destroy()
return(TRUE)
} else {
widget = widget$GetParentWindow()
if(inherits(widget,"<invalid>"))
return(FALSE)
else
widget$Destroy()
return(TRUE)
}
})
## update
setMethod("update",signature(object="gWidgetRGtk"),
function(object, ...) {
.update(object, object@toolkit, ...)
})
setMethod(".update",
signature(toolkit="guiWidgetsToolkitRGtk2",object="gComponentRGtk"),
function(object, toolkit, ...) {
object@widget$QueueDraw()
})
##
##
##################################################
##################################################
## handlers
##
## basic handler for adding with a signal. Now exported.
setGeneric("addhandler", function(obj, signal, handler, action=NULL, ...)
standardGeneric("addhandler"))
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="gWidgetRGtk"),
function(obj, signal, handler, action=NULL, ...) {
.addHandler(obj, obj@toolkit, signal, handler, action, ...)
})
setMethod("addhandler",signature(obj="RGtkObject"),
function(obj, signal, handler, action=NULL, ...) {
.addHandler(obj, guiToolkit("RGtk2"), signal, handler, action, ...)
})
setMethod("addHandler",signature(obj="gWidgetRGtk"),
function(obj, signal, handler, action=NULL, ...) {
.addHandler(obj@widget, obj@toolkit, signal, handler, action, ...)
})
setMethod(".addhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, signal, handler, action=NULL, ...) {
.addHandler(obj, obj@toolkit, signal, handler, action, ...)
})
## method for dispatch
setGeneric(".addHandler",
function(obj, toolkit,
signal, handler, action=NULL, ...)
standardGeneric(".addHandler"))
setMethod(".addHandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="guiWidget"),
function(obj, toolkit,
signal, handler, action=NULL, ...) {
.addHandler(obj@widget, toolkit, signal, handler, action, ...)
})
setMethod(".addHandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
signal, handler, action=NULL, ...) {
## need to return logical when an event, not always,
## but gives trouble if not
modifyHandler = function(...) {
val <- handler(...)
if(!is.logical(val))
return(TRUE)
else
return(val)
}
theArgs = list(...)
## fix value passed into gWidgets handlers
h <- list()
h$obj <- obj
if(!is.null(theArgs$actualobj)) {
h$obj <- theArgs$actualobj
theArgs$actualobj <- NULL
}
if(length(theArgs))
for(i in names(theArgs))
h[[i]] <- theArgs[[i]]
h$action <- action
callbackID <- gtktry(connectSignal(getWidget(obj), ### issue: getWidget(obj),
signal=signal,
f=modifyHandler,
data=h,
user.data.first = TRUE,
after = FALSE), silent=FALSE)
if(inherits(callbackID,"try-error")) {
gwCat(sprintf("Couldn't add signal %s for object of class %s",
signal, class(obj)[1]),"\n")
return(NA)
} else {
## now put handler into object
handler.ID = tag(obj, "handler.id")
if(is.null(handler.ID))
handler.ID =list()
handler.ID[[length(handler.ID)+1]] = callbackID
tag(obj, "handler.id") <- handler.ID
##
## addhandlerdestroy(obj, handler=function(h,...)
## removehandler(h$obj,h$action),
## action=ID)
## return ID
invisible(callbackID)
}
})
setMethod(".addHandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, signal, handler, action=NULL, ..., after=FALSE) {
theArgs = list(...)
## need to return FALSE to propogate to next handler on events
modifyHandler = function(h,...) {
handler(h,...)
return(FALSE)
}
## fix value passed into gWidgets handlers
h <- list()
h$obj <- obj
if(!is.null(theArgs$actualobj)) {
h$obj <- theArgs$actualobj
theArgs$actualobj <- NULL
}
## pass in extra values, eg addHandlerClicked(obj, f=FUN, extra=value) will h$extra key
if(length(theArgs))
for(i in names(theArgs))
h[[i]] <- theArgs[[i]]
h$action <- action
callbackID <- gtktry(gSignalConnect(obj,
signal=signal,
f=modifyHandler,
data=h,
user.data.first = TRUE,
after = after),
silent=TRUE)
## can't' stuff in handler IDS
if(inherits(callbackID,"try-error")) {
gwCat(sprintf("Couldn't connect signal: %s for object of class %s\n",
signal, class(obj)[1]))
return(NA)
} else {
## store ID into list
lst <- obj$getData("handler.id")
if(is.null(lst)) lst <- list()
lst <- c(lst,callbackID)
obj$setData("handler.id", lst)
invisible(callbackID)
}
})
## removehandler
setMethod("removehandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.removehandler(obj, obj@toolkit, ID, ...)
})
setMethod("removehandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.removehandler(obj, guiToolkit("RGtk2"), ID, ...)
})
### JV: Need to consolidate this and the next, The difference is the callbackIDS?
setMethod(".removehandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ID=NULL, ...) {
if(missing(ID))
callbackIDs = .tag(obj,toolkit,"handler.id")
else
callbackIDs = ID
## timeout handler?
if(class(callbackIDs) == "GTimeoutId") {
out <- sapply(callbackIDs, function(i) {
class(i) <- "GTimeoutId" # sapply strips attributes!
gSourceRemove(i)
})
return(out)
}
if(!is.null(callbackIDs)) {
if(!is.list(callbackIDs)) {
callbackIDs = list(callbackIDs)
}
widget = obj@widget
retval = logical(length(callbackIDs))
for(i in 1:length(callbackIDs)) {
if(is.list(callbackIDs[[i]])) # recurse if a list
for(i in callbackIDs[[i]]) .removehandler(obj, toolkit, i)
isCallbackID = gtktry(checkPtrType(callbackIDs[[i]],"CallbackID"),silent=TRUE)
if(!inherits(isCallbackID,"try-error")) {
retval[i] = gtktry(gSignalHandlerDisconnect(widget, callbackIDs[[1]]), silent=TRUE)
# retval[i] = gtktry(gtkObjectDisconnectCallbackHack(widget, callbackIDs[[i]]),
# silent=TRUE)
} else {
gwCat("DEBUG: ID not of callbackID\n")
retval[i] = FALSE
}
}
for(i in rev(which(retval==TRUE)))
callbackIDs[[i]] <- NULL
.tag(obj,toolkit, "handler.id", replace=FALSE) <- callbackIDs
return(retval)
} else {
return(FALSE)
}
})
## for RGtkObject
setMethod(".removehandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ID=NULL, ...) {
if(missing(ID))
callbackIDs = .tag(obj,toolkit,"handler.id")
else
callbackIDs = ID
if(!is.null(callbackIDs)) {
if(!is.list(callbackIDs)) {
callbackIDs = list(callbackIDs)
}
widget = obj
retval = c()
for(i in 1:length(callbackIDs)) {
if(is.list(callbackIDs[[i]])) # recurse if a list
for(i in callbackIDs[[i]]) .removehandler(obj, toolkit, i)
isCallbackID = gtktry(checkPtrType(callbackIDs[[i]],"CallbackID"),silent=TRUE)
if(!inherits(isCallbackID,"try-error")) {
retval[i] = widget$disconnectCallback(callbackIDs[[i]]) #gtkObjectDisconnectCallbackHack(widget, callbackIDs[[i]])
} else {
gwCat("DEBUG: ID not of callbackID\n")
retval[i] = FALSE
}
}
for(i in rev(which(retval==TRUE)))
callbackIDs[[i]] <- NULL
.tag(obj,toolkit, "handler.id", replace=FALSE) <- callbackIDs
return(retval)
} else {
return(FALSE)
}
})
## blockhandler
setMethod("blockhandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.blockhandler(obj, obj@toolkit, ID, ...)
})
setMethod("blockhandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.blockhandler(obj, guiToolkit("RGtk2"), ID, ...)
})
## caps
setMethod("blockHandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.blockhandler(obj, obj@toolkit, ID, ...)
})
setMethod("blockHandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.blockhandler(obj, guiToolkit("RGtk2"), ID, ...)
})
setMethod(".blockhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ID=NULL, ...) {
.blockhandler(getWidget(obj),toolkit,ID,...)
})
setMethod(".blockhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ID=NULL, ...) {
if(is.null(ID))
ID <- tag(obj,"handler.id")
lapply(ID, function(i)
gSignalHandlerBlock(obj,i))
return()
})
## unblock handler
setMethod("unblockhandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.unblockhandler(obj, obj@toolkit, ID, ...)
})
setMethod("unblockhandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.unblockhandler(obj, guiToolkit("RGtk2"), ID, ...)
})
## camelcase
setMethod("unblockHandler", signature("gWidgetRGtk"),
function(obj, ID=NULL, ...) {
.unblockhandler(obj, obj@toolkit, ID, ...)
})
setMethod("unblockHandler", signature("RGtkObject"),
function(obj, ID=NULL, ...) {
.unblockhandler(obj, guiToolkit("RGtk2"), ID, ...)
})
setMethod(".unblockhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, ID=NULL, ...) {
.unblockhandler(getWidget(obj),toolkit,ID,...)
})
setMethod(".unblockhandler",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, ID=NULL, ...) {
if(is.null(ID))
ID <- tag(obj,"handler.id")
sapply(ID, function(i)
gSignalHandlerUnblock(obj,i))
return()
})
## addhandlerchanged
setMethod("addhandlerchanged",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerchanged(obj, obj@toolkit, handler, action, ...)
})
setMethod("addhandlerchanged",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerchanged(obj, guiToolkit("RGtk2"), handler, action, ...)
})
setMethod("addhandlerchanged",signature(obj="ANY"),
function(obj, handler=NULL, action=NULL, ...) {
warning("No method addhandlerchanged for object of class",class(obj),"\n")
})
## caps
setMethod("addHandlerChanged",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerchanged(obj, obj@toolkit, handler, action, ...)
})
setMethod("addHandlerChanged",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerchanged(obj, guiToolkit("RGtk2"), handler, action, ...)
})
setMethod(".addhandlerchanged",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="changed",
handler=handler, action=action, ...)
})
## expose: expose-event or realize
setMethod("addhandlerexpose",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerexpose(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerexpose",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerexpose(obj, guiToolkit("RGtk2"), handler, action, ...)
})
setMethod(".addhandlerexpose",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="expose-event",
handler=handler, action=action, ...)
})
setMethod(".addhandlerexpose",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gComponentRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj,toolkit, signal="realize",
handler=handler, action=action, ...)
})
## unrealize: unrealize
setMethod("addhandlerunrealize",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerunrealize(obj, obj@toolkit,handler, action, ...)
})
setMethod("addhandlerunrealize",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerunrealize(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerunrealize",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="unrealize",
handler=handler, action=action, ...)
})
## destroy: destroy
setMethod("addhandlerdestroy",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdestroy(obj, obj@toolkit,handler, action, ...)
})
setMethod("addhandlerdestroy",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdestroy(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerdestroy",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
## See
## http://www.moeraki.com/pygtktutorial/pygtk2tutorial/sec-SteppingThroughHelloWorld.html
## for difference between "destroy" and "delete-event"
.addHandler(obj, toolkit, signal="destroy",
handler=handler, action=action, ...)
})
## keystroke: changed
setMethod("addhandlerkeystroke",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerkeystroke(obj, obj@toolkit,handler, action, ...)
})
setMethod("addhandlerkeystroke",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerkeystroke(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerkeystroke",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="changed",
handler=handler, action=action, ...)
})
## clicked: clicked
setMethod("addhandlerclicked",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerclicked(obj, obj@toolkit,handler, action, ...)
})
setMethod("addhandlerclicked",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerclicked(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## caps
setMethod("addHandlerClicked",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerclicked(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerClicked",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerclicked(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerclicked",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="clicked",
handler=handler, action=action, ...)
})
setMethod(".addhandlerclicked",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj, toolkit, signal="clicked",
handler=handler, action=action, ...)
})
## doubleclick: no default
setMethod("addhandlerdoubleclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdoubleclick(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerdoubleclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdoubleclick(obj,guiToolkit("RGtk2"),handler, action, ...)
})
## caps
setMethod("addHandlerDoubleclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdoubleclick(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerDoubleclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerdoubleclick(obj, guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerdoubleclick",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
warning("No default handler for double click")
})
## rightclick: button-press-event -- handle separately
setMethod("addhandlerrightclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerrightclick(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerrightclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerrightclick(obj,guiToolkit("RGtk2"),handler, action, ...)
})
## caps
setMethod("addHandlerRightclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerrightclick(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerRightclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerrightclick(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## use actualobj=obj to pass in a different obj to h$obj
## use actualobj=obj to pass in a different obj to h$obj
setMethod(".addhandlerrightclick",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addhandlerrightclick(getWidget(obj), toolkit, handler, action, actualobj=obj,...)
})
setMethod(".addhandlerrightclick",
# signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit,
handler, action=NULL, ..., after=FALSE) {
theArgs = list(...)
## fix value passed into gWidgets handlers
h <- list()
h$handler <- handler
h$obj <- obj
if(!is.null(theArgs$actualobj)) {
h$obj <- theArgs$actualobj
theArgs$actualobj <- NULL
}
## pass in extra values, eg addHandlerClicked(obj, f=FUN, extra=value) will h$extra key
if(length(theArgs))
for(i in names(theArgs))
h[[i]] <- theArgs[[i]]
h$action <- action
gtktry(connectSignal(getWidget(obj),
signal = "button-press-event",
f = function(h, w, eventButton,...) {
if(isRightMouseClick(eventButton)) {
h$handler(h,w, eventButton, ...)
}
return(FALSE) # stop propagation
},
data = h,
user.data.first = TRUE,
after = after
),
silent=TRUE)
})
### Column click things
## click: no default
setMethod("addhandlercolumnclicked",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnclicked(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlercolumnclicked",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnclicked(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod("addHandlerColumnClicked",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnclicked(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerColumnClicked",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnclicked(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## doubleclick: no default
setMethod("addhandlercolumndoubleclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumndoubleclick(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlercolumndoubleclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumndoubleclick(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod("addHandlerColumnDoubleclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumndoubleclick(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerColumnDoubleclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumndoubleclick(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## rightclick
setMethod("addhandlercolumnrightclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnrightclick(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlercolumnrightclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnrightclick(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod("addHandlerColumnRightclick",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnrightclick(obj, obj@toolkit,handler, action, ...)
})
setMethod("addHandlerColumnRightclick",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlercolumnrightclick(obj, guiToolkit("RGtk2"),handler, action, ...)
})
## focus -- on focus call this
setMethod("addhandlerfocus",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerfocus(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerfocus",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerfocus(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerfocus",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj,toolkit,
signal="focus-in-event",
handler, action, ...)
})
## blur -- leave focus
setMethod("addhandlerblur",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerblur(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlerblur",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlerblur(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlerblur",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
## blur handler should return FALSE
f <- function(h,...) {
handler(h,...)
return(FALSE)
}
.addHandler(obj,toolkit,
signal="focus-out-event",
f, action, ...)
})
##
## mousemotion -- like mouseover
setMethod("addhandlermousemotion",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlermousemotion(obj,obj@toolkit,handler, action, ...)
})
setMethod("addhandlermousemotion",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.addhandlermousemotion(obj,guiToolkit("RGtk2"),handler, action, ...)
})
setMethod(".addhandlermousemotion",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler, action=NULL, ...) {
.addHandler(obj,guiToolkit("RGtk2"),
signal="enter-notify-event",
handler, action, ...)
})
## idle
setMethod("addhandleridle",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, interval=1000, ...) {
.addhandleridle(obj, obj@toolkit,
handler=handler, action=action, interval=interval, ...)
})
setMethod("addhandleridle",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, interval=1000, ...) {
.addhandleridle(obj, guiToolkit("RGtk2"),
handler=handler, action=action, interval=interval, ...)
})
setMethod(".addhandleridle",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit,
handler=NULL, action=NULL, interval=1000, ...) {
idlehandler = function(h,...) {
if(!is.null(h$handler) && is.function(h$handler))
h$handler(h,...)
invisible(TRUE)
}
## ID = gtkAddTimeout(
ID = gTimeoutAdd(
interval,
idlehandler,
data=list(obj=obj, action=action, handler=handler)
)
## tidy up when done
.addhandlerdestroy(obj,toolkit, handler=function(h,...) {
# gtkRemoveTimeout(h$action)
gSourceRemove(h$action)
},action=ID)
invisible(ID)
})
## addpopumenu
setMethod("addpopupmenu",signature(obj="gWidgetRGtk"),
function(obj, menulist, action=NULL, ...) {
.addpopupmenu(obj, obj@toolkit,menulist, action, ...)
})
setMethod("addpopupmenu",signature(obj="RGtkObject"),
function(obj, menulist, action=NULL, ...) {
.addpopupmenu(obj, guiToolkit("RGtk2"), menulist, action, ...)
})
## this does not get exported
addPopupMenuWithSignal = function(obj, toolkit, menulist, action=NULL, signal="button-press-event", ...) {
theArgs = list(...)
f = function(h, ...) {
mb = gmenu(h$action, popup = TRUE)
event = gdkEventNew(GdkEventType["button-press"])
mb = tag(mb,"mb") # the real menu bar
gtkMenuPopupHack(mb, button = event$GetButton(),
activate.time=event$GetTime()
)
}
## .addhandler not exported
callbackID = .addHandler(obj,toolkit, signal = signal,handler=f, action=menulist)
invisible(callbackID)
}
add3rdMousePopupMenuWithSignal = function(obj, toolkit, menulist, action=NULL, signal="button-press-event", ...) {
f = function(h, widget, event,...) {
## Mac use ctrl - button 1
if(isRightMouseClick(event)) {
mb = gmenu(h$action$menulist, popup = TRUE, action=h$action$passedaction)
mb = tag(mb,"mb") # actual widget
gtkMenuPopupHack(mb,button = event$GetButton(),
activate.time=event$GetTime()
)
return(FALSE)
} else {
return(FALSE)
}
}
callbackID = .addHandler(obj,toolkit, signal = "button-press-event",handler=f, action=list(menulist=menulist, passedaction=action))
invisible(callbackID)
}
### need to deal with action
setMethod(".addpopupmenu",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, menulist, action=NULL, ...) {
addPopupMenuWithSignal(obj, toolkit, menulist, ...)
})
## add3rdmousepopupmenu
setMethod("add3rdmousepopupmenu",signature(obj="gWidgetRGtk"),
function(obj, menulist, action=NULL, ...) {
.add3rdmousepopupmenu(obj, obj@toolkit,menulist, action, ...)
})
setMethod("add3rdmousepopupmenu",signature(obj="RGtkObject"),
function(obj, menulist, action=NULL,...) {
.add3rdmousepopupmenu(obj, guiToolkit("RGtk2"),menulist, action,...)
})
setMethod(".add3rdmousepopupmenu",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gWidgetRGtk"),
function(obj, toolkit, menulist,action=NULL, ...) {
add3rdMousePopupMenuWithSignal(obj, toolkit,
menulist, action, ...)
})
setMethod(".add3rdmousepopupmenu",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="RGtkObject"),
function(obj, toolkit, menulist, action=NULL, ...) {
add3rdMousePopupMenuWithSignal(obj, toolkit,
menulist, action, ...)
})
## "dotmethods" defined in dnd.R
## adddropsource
setMethod("adddropsource",signature(obj="gWidgetRGtk"),
function(obj, targetType="text", handler=NULL, action=NULL, ...) {
.adddropsource(obj, obj@toolkit,targetType=targetType,
handler=handler, action=action, ...)
})
setMethod("adddropsource",signature(obj="RGtkObject"),
function(obj, targetType="text", handler=NULL, action=NULL, ...) {
.adddropsource(obj, guiToolkit("RGtk2"),targetType=targetType,
handler=handler, action=action, ...)
})
## adddropmotion
setMethod("adddropmotion",signature(obj="gWidgetRGtk"),
function(obj, handler=NULL, action=NULL, ...) {
.adddropmotion(obj, obj@toolkit,
handler=handler, action=action, ...)
})
setMethod("adddropmotion",signature(obj="RGtkObject"),
function(obj, handler=NULL, action=NULL, ...) {
.adddropmotion(obj, guiToolkit("RGtk2"),
handler=handler, action=action, ...)
})
## adddroptarget
setMethod("adddroptarget",signature(obj="gWidgetRGtk"),
function(obj, targetType="text", handler=NULL, action=NULL, ...) {
.adddroptarget(obj, obj@toolkit,targetType=targetType,
handler=handler, action=action, ...)
})
setMethod("adddroptarget",signature(obj="RGtkObject"),
function(obj, targetType="text", handler=NULL, action=NULL, ...) {
.adddroptarget(obj, guiToolkit("RGtk2"),targetType=targetType,
handler=handler, action=action, ...)
})
## R Methods
setMethod("dim", "gWidgetRGtk", function(x) .dim(x,x@toolkit))
setMethod("length", "gWidgetRGtk", function(x) .length(x,x@toolkit))
setMethod(".length",
signature(toolkit="guiWidgetsToolkitRGtk2",x="gWidgetRGtk"),
function(x,toolkit) {
return(NA)
gwCat(sprintf("Define length for x of class: %s\n", class(x)[1]))
})
setMethod("dimnames", "gWidgetRGtk", function(x) .dimnames(x,x@toolkit))
setReplaceMethod("dimnames",
signature(x="gWidgetRGtk"),
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", "gWidgetRGtk", function(x) .names(x,x@toolkit))
setReplaceMethod("names",
signature(x="gWidgetRGtk"),
function(x,value) {
.names(x,x@toolkit) <- value
return(x)
})
#### This may be useful to integrate gWidgets with glade
####
## S3 class for coercing to gWidget
as.gWidgetsRGtk2 <- function(widget,...) UseMethod("as.gWidgetsRGtk2")
as.gWidgetsRGtk2.default <- function(widget,...) {
print(sprintf("No coercion to gWidget available for object of class %s",class(widget)))
return(widget)
}
Try the gWidgetsRGtk2 package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.