##' @include gtk-misc.R
NULL
## Base classes. These are *not* exported, rather each toolkit implementation needs
## to (mostly) provide these same basic classes:
## GComponent
## - GWidget
## - GButton
## - GLabel
## - Others matching the constructors
## -GContainer
## - GWindow
## - GGroup
## - GFrame
## - GExpandGroup
## - GLayout
## - GNotebook
## - GStacked
## - GPanedGroup
##' Base Class for widgets and containers
##'
##' GComponent is a parent class for both GContainer and GWidget and
##' inherits its primary interface from
##' gWidgets2::BasicToolkitInterface.
##' @rdname gWidgets2RGtk2-package
##' @export GComponent
GComponent <- setRefClass("GComponent",
contains="BasicToolkitInterface",
fields=list(
handler_id="ANY",
.e="environment", # for tag
..invalid="logical",
..invalid_reason="character",
coerce_with="FunctionOrNULL"
),
methods=list(
initialize=function(toolkit=guiToolkit(), ...,
expand, fill, anchor, label # should be gobbled prior, but don't want to pass on
) {
initFields(toolkit=toolkit,
.e=new.env()
)
if(is(handler_id, "uninitializedField"))
handler_id <<- NULL
if(is(default_expand, "uninitializedField"))
default_expand <<- NULL
if(is(default_fill, "uninitializedField"))
default_fill <<- NULL
callSuper(...)
},
show = function() {
cat(sprintf("Object of class %s\n", class(.self)[1]))
},
## length
get_length = function(...) {
"Get length of object. Needed for sapply."
1
},
## visible
get_visible = function() widget$getVisible(),
set_visible = function(value) widget$setVisible(as.logical(value)),
## focus
get_focus = function() widget$hasFocus(),
set_focus = function(value) {
"If we can focus, do so, then raise"
if(value) {
if(block$getCanFocus())
block$grabFocus()
block$getWindow()$raise()
}
},
## enabled
get_enabled = function() widget$getSensitive(),
set_enabled = function(value) widget$setSensitive(as.logical(value)),
## tooltip
get_tooltip = function(...) widget$getTooltipText(),
set_tooltip = function(value) widget$setTooltipText(paste(value, collapse="\n")),
## font
set_font = function(value) {
set_rgtk2_font(getWidget(widget), value)
},
set_rgtk2_font = function(obj, value) {
"Set font on a gtkWidget instance"
if(!is(obj, "GtkWidget"))
stop("Font setting called with object of class", class(obj))
if(!is.list(value))
value <- sapply(value, identity, simplify=FALSE)
font_desc <- pangoFontDescriptionNew()
for(key in names(value)) {
val <- value[[key]]
switch(key,
"weight"= font_desc$setWeight(PangoWeight[val]),
"style" = font_desc$setStyle(PangoStyle[val]),
"size" = font_desc$setSize(val * PANGO_SCALE),
"scale" = font_desc$setAbsoluteSize(10 * PangoScale[val] * PANGO_SCALE),
"family" = font_desc$setFamily(val),
"color" = obj$modifyFg(GtkStateType["normal"], val),
"foreground" = obj$modifyFg(GtkStateType["normal"], val),
"background" = obj$modifyBg(GtkStateType["normal"], val),
)
}
obj$modifyFont(font_desc)
},
## tag
get_attr = function(key) {
if(missing(key))
ls(.e)
else
attr(.e, key)
},
set_attr = function(key, value) {
tmp <- .e
attr(tmp, key) <- value
},
## still there?
is_extant = function() {
"Is widget still available?"
if(is(block, "<invalid>"))
return(FALSE)
else
TRUE
},
## size
get_size=function(...) {
alloc <- getBlock(.self)$getAllocation()$allocation
c(width=alloc$width, height=alloc$height)
},
set_size=function(value, ...) {
"Set widget size (size request), value=c(width=-1, height=-1)"
if(is.list(value))
value <- unlist(value) # list is named components
if(length(value) >= 2) {
width <- value[1]; height <- value[2]
} else if(names(value) == "height") {
width <- -1; height <- value
} else {
width <- value; height <- -1
}
getBlock(.self)$SetSizeRequest(width,height)
},
set_invalid=function(value, msg) {
"Set widget as invalid or not"
if(as.logical(value)) {
..invalid <<- TRUE
..invalid_reason <<- msg
} else {
..invalid <<- FALSE
..invalid_reason <<- ""
}
},
is_invalid=function(...) {
"Is widget in an invalid state"
if(length(..invalid) == 0)
..invalid <<- FALSE
..invalid
},
##
## Work with containers
##
set_parent = function(parent) {
"Assign parent to parent property"
parent <<- parent
},
add_to_parent = function(parent, child, expand=NULL, fill=NULL, anchor=NULL, ...) {
"Add a child to parent if it is ia container and non null. Dispatches to add_child method of parent"
if(missing(parent) || is.null(parent))
return()
## return here. This is for tcltk compliance
if(is(parent, "GLayout"))
return()
if(!is(parent, "GContainer") && is.logical(parent) && parent) {
tmp <- gwindow(toolkit=toolkit)
tmp$add_child(child, expand, fill, anchor, ...)
return()
}
if(!is(parent, "GContainer")) {
message("parent is not a container")
return()
}
parent$add_child(child, expand, fill, anchor, ...)
},
##
## Drag and drop
##
handler_widget = function() widget, # allow override for block (e.g., glabel)
add_drop_source=function(handler, action=NULL, data.type="text", ...) {
"Specify widget is a drag source"
gtkDragSourceSet(handler_widget(),
start.button.mask=c("button1-mask", "button3-mask"),
targets=widgetTargetTypes[[data.type]],
actions="copy")
if(data.type == "text") {
f <- function(h, widget, context, sel, tType, eTime) {
#message("get drag data")
val <- handler(h) # returns text
if (length(val) == 0)
val <- ""
sel$setText(val, -1)
}
}
else if(data.type == "object") {
key <- digest(.self)
f <- function(h, widget, context, sel, tType, eTime) {
#message("get drag data object")
val <- handler(h) ## returns an object
.dnd.env[[key]] <- val
sel$setText(key)
}
}
gSignalConnect(handler_widget(), "drag-data-get", f= f,
data=list(obj=.self, action=action), user.data.first=TRUE)
if(data.type == "object") {
gSignalConnect(handler_widget(), "drag-end", f=function(key, ...) {
## message("drag end")
.dnd.env[[key]] <- NULL # clean up
}, data=digest(.self), user.data.first=TRUE)
}
},
add_drop_target=function(handler, action=NULL, ...) {
"Specify that widget is a drop target"
gtkDragDestSet(handler_widget(),
flags="all",
targets=widgetTargetTypes,
actions="copy")
gSignalConnect(handler_widget(), "drag-data-received",
function(h, widget, context, x, y, sel, data.type, event.time) {
## this call fixed in recent RGtk2 versions so we wrap in try()
try(gSignalStopEmission(widget, "drag-data-received"), silent=TRUE)
gtkDragFinish(context, TRUE, FALSE, time=event.time)
target <- context$getTargets()[[3]] # GdkAtom instance
target <- attr(target, "name")
## do different things depending on context
if(target == "TEXT") {
h$dropdata <- rawToChar(sel$getText())
} else if(as.integer(target) == TARGET.TYPE.TEXT) {
h$dropdata <- rawToChar(sel$getText())
} else if(as.integer(target) == TARGET.TYPE.OBJECT) {
key <- rawToChar(sel$getText())
h$dropdata <- .dnd.env[[key]];
}
handler(h, widget=widget, context=context, x=x, y=y, sel=sel, data.type=data.type, event.time=event.time)
return(TRUE)
}, data=list(obj=.self, action=action), user.data.first=TRUE)
},
add_drag_motion=function(handler, action=NULL, ...) {
"Called when motion over widget occurs"
## avoid add-handler, here we do directly, as above.
gSignalConnect(handler_widget(), "drag-motion", f=function(h, ...) {
handler(h, ...)
}, data=list(obj=.self, action=action), user.data.first=TRUE)
}
)
)
## GComponentObservable adds the observable interface
##
## @param ... passed to constructor
GComponentObservable <- setRefClass("GComponentObservable",
fields=list(
change_signal="character", # what signal is default change signal
connected_signals="list"
),
contains="GComponent",
methods=list(
## Some decorators for handlers
## these wrap the handler to satisfy or fill the h object or return value
event_decorator=function(handler) {
"Decorator for basic event"
force(handler)
f <- function(.self, ...) {
out <- handler(.self, ...)
if(is.atomic(out) && is.logical(out) && out[1])
out[1]
else
FALSE # need logical
}
f
},
key_release_decorator=function(handler) {
force(handler)
f <- function(.self, widget, event,...) {
key <- event$getString() # XXX This is bad -- no locale, ...
state <- gdkEventKeyGetState(event)
if(state == 0)
modifier <- NULL
else
modifier <- gsub("-mask", "", names(which(state == GdkModifierType)))
handler(.self, key=key, modifier=modifier, state=state, event=event)
}
event_decorator(f)
},
button_press_decorator = function(handler) {
"Add in position information to 'h' component"
force(handler)
f <- function(.self, widget, event, ...) {
## stuff in some event information
x <- event$getX(); X <- event$getXRoot()
y <- event$getY(); Y <- event$getYRoot()
state <- gsub("-mask", "", names(which(event$getState() == GdkModifierType)))
button <- event$getButton()
handler(.self, x=x,X=X, y=y, Y=Y, state=state, button=button, ...)
}
event_decorator(f)
},
button_press_decorator_filter = function(handler, modifier_type) {
"call handler if Modifier type is correct"
force(handler)
f <- function(.self, widget, event, ...) {
if(event$getState() == modifier_type) {
handler(.self,...)
}
}
event_decorator(f)
},
button_press_decorator_filter_shift = function(handler) {
## catch only shift masked events
button_press_decorator_filter(handler, GdkModifierType[["shift-mask"]])
},
button_press_decorator_filter_control = function(handler) {
## catch control masked events
button_press_decorator_filter(handler, GdkModifierType[["shift-mask"]] + GdkModifierType[["control-mask"]])
},
## code for integrating observable interface with RGtk2
is_handler=function(handler) {
"Helper to see if handler is a handler"
!missing(handler) && !is.null(handler) && is.function(handler)
},
##
## Adding a handler means to
## a) create an observer and add an observer for the given signal
##
## b) create a call back which
## calls the notify observer
## method when the widget
## actualy emits the signal
add_handler=function(signal, handler, action=NULL, decorator, emitter) {
"Uses Observable framework for events. Adds observer, then call connect signal method. Override last if done elsewhere"
if(is_handler(handler)) {
o <- gWidgets2:::observer(.self, handler, action)
connect_to_toolkit_signal(signal, decorator, emitter=emitter)
invisible(add_observer(o, signal))
}
},
add_event_handler=function(handler, action=NULL, ..., decorator) {
add_handler(handler, action=NULL, decorator=.self$event_decorator, ...)
},
connect_to_toolkit_signal=function(
signal, # which signal (gSignalConnect)
decorator,
emitter=.self$handler_widget() # can override here
) {
"Connect signal of toolkit to notify observer"
f=function(self, ...) { # notify observer in Gtk callback
self$notify_observers(signal=signal, ...)
}
if(!missing(decorator))
f <- decorator(f)
## only connect once
if(is.null(connected_signals[[signal, exact=TRUE]]))
gSignalConnect(handler_widget(), signal, f, data=.self, user.data.first=TRUE, after=FALSE)
connected_signals[[signal]] <<- TRUE
},
## initiate a handler (emit signal)
invoke_handler=function(signal, ...) {
"Bypasses gSignalEmit which crashes R for me.
Invoke observers listening to signal"
notify_observers(..., signal=signal)
},
invoke_change_handler=function(...) {
"Generic change handler invoker."
if(!is(change_signal, "uninitializedField") && length(change_signal))
invoke_handler(signal=change_signal, ...)
},
## block and unblock
block_handlers=function() {
"Block all handlers."
## default is to block the observers.
block_observers()
},
block_handler=function(ID) {
"Block a handler by ID"
block_observer(ID)
},
unblock_handlers=function() {
"unblock blocked observer. May need to be called more than once to clear block"
unblock_observers()
},
unblock_handler=function(ID) {
"unblock a handler by ID"
unblock_observer(ID)
},
remove_handlers=function() {
"Remove all observers"
remove_observers()
},
remove_handler=function(ID) {
"remove a handler by ID"
remove_observer(ID)
},
## basic set of handlers
add_handler_changed=function(handler, action=NULL,...) {
if(!is(change_signal, "uninitializedField") && length(change_signal)) {
add_handler(change_signal, handler, action, ...)
} else {
stop("No change_signal defined for widget")
}
},
## Defind add_handler_EVENT methods
## basically passes down to add_handler or add_event_handler as needed
## by the RGtk2 event we bind the handler to.
## we have to check is handler is missing or a function when we apply a decorator
add_handler_keystroke=function(handler, action=NULL, ...) {
"Keystroke handler. Defined for all, but might restrict to only gedit, gtext"
add_handler("key-release-event", handler, action, .self$key_release_decorator, ...)
},
add_handler_clicked = function(handler, action=NULL, ...) {
add_handler("clicked", handler, action, ...)
},
add_handler_control_clicked = function(handler, action=NULL, ...) {
add_handler("button-press-event", handler, action,
.self$button_press_decorator_filter_control, ...)
},
add_handler_shift_clicked = function(handler, action=NULL, ...) {
add_handler("button-press-event", handler, action,
.self$button_press_decorator_filter_shift, ...)
},
add_handler_button_press=function(handler, action=NULL, ...) {
add_handler("button-press-event", handler, action, .self$button_press_decorator, ...)
},
add_handler_button_release=function(handler, action=NULL, ...) {
add_handler("button-release-event", handler, action, .self$button_press_decorator, ...)
},
add_handler_focus=function(handler, action=NULL, ...) {
add_handler("focus-in-event", handler, action, .self$event_decorator, ...)
},
add_handler_blur=function(handler, action=NULL, ...) {
add_handler("focus-out-event", handler, action, .self$event_decorator, ...)
},
# add_handler_mouse_motion=function(handler, action=NULL, ...) {
# add_handler("motion-notify-event", handler, action, .self$event_decorator, ...)
# },
## XXX add stibs for others
##
add_popup_menu = function(menulist, action=NULL, ...) {
if(is(menulist, "list"))
mb <- gmenu(menulist, popup=TRUE)
else
mb <- menulist
if(!is(mb, "GMenuPopup"))
stop("Pass in popupmenu or list defining one")
f <- function(w, e, ...) {
## Fixed count in newest RGtk2
if(e$button == 1 && e$type == GdkEventType['button-press']) {
mb$widget$popup(button=e$button, activate.time=e$time)
}
FALSE
}
gSignalConnect(handler_widget(), "button-press-event", f)
},
add_3rd_mouse_popup_menu=function(menulist, action=NULL, ...) {
if(is(menulist, "list"))
mb <- gmenu(menulist, popup=TRUE)
else
mb <- menulist
if(!is(mb, "GMenuPopup"))
stop("Pass in popupmenu or list defining one")
f <- function(w, e, ...) {
## make work wih mac and right mouse!!!
if(isRightMouseClick(e)) {
mb$widget$popup(button=e$button, activate.time=e$time)
}
FALSE
}
gSignalConnect(handler_widget(), "button-press-event", f)
}
))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.