##' @include GWidget.R
NULL
## @usage \method{.gcheckboxgroup}{guiWidgetsToolkitRGtk2}(toolkit=NULL, items, checked = FALSE, horizontal = FALSE, use.table = FALSE, handler = NULL, action = NULL, container = NULL, ...)
##' Toolkit constructor
##'
##' @export
##' @rdname gWidgets2RGtk2-undocumented
##' @method .gcheckboxgroup guiWidgetsToolkitRGtk2
## @export .gcheckboxgroup guiWidgetsToolkitRGtk2
.gcheckboxgroup.guiWidgetsToolkitRGtk2 <- function(toolkit=NULL,
items, checked = FALSE, horizontal = FALSE,
use.table=FALSE, handler = NULL,
action = NULL, container = NULL, ... ) {
if(use.table)
GCheckboxGroupTable$new(toolkit, items, checked = checked,
handler = handler,action = action, container = container, ...)
else
GCheckboxGroup$new(toolkit,
items, checked = checked, horizontal = horizontal,
handler = handler, action = action, container = container, ...)
}
## checkbox group class
GCheckboxGroup <- setRefClass("GCheckboxGroup",
contains="GWidgetWithItems",
methods=list(
initialize=function(toolkit,
items, checked = FALSE, horizontal = FALSE,
handler = NULL,
action = NULL, container = NULL, ... ) {
if(horizontal)
block <<- gtkHBox()
else
block <<- gtkVBox()
widget <<- NULL
initFields(widgets = list(),
change_signal="toggled"
)
set_items(value=items)
set_index(checked)
add_to_parent(container, .self, ...)
handler_id <<- add_handler_changed(handler, action)
callSuper(toolkit)
},
get_value=function(drop=TRUE, ...) {
items <- get_items()
items[get_index()]
},
set_value=function(value, drop=TRUE, ...) {
## value may be logical
items <- get_items()
if(is.logical(value) && !is.logical(items)) {
set_index(value)
} else {
ind <- pmatch(value, items)
set_index(ind)
}
},
get_index = function(...) {
"Return indices, not logical"
which(sapply(widgets, function(i) i$getActive()))
},
set_index=function(value, ...) {
block_observer()
if(is.logical(value))
value <- rep(value, length=get_length())
if(is.numeric(value)) {
value <- is.element(seq_len(get_length()), value)
}
mapply(gtkToggleButtonSetActive, object=widgets, is.active=value)
unblock_observer()
notify_observers(signal="toggled")
invisible()
},
get_items = function(i, ...) {
items <- sapply(widgets, function(i) i[[1]]$getLabel())[i]
setNames(items, NULL) # drop names
},
set_items = function(value, i, ...) {
## make widgets
widgets <<- sapply(value, gtkCheckButtonNewWithLabel)
## layout widgets
sapply(block$getChildren(), gtkContainerRemove, object=block) # remove old
sapply(widgets, gtkBoxPackStart, object=block, expand=FALSE, padding=1)
## connec widgets
sapply(widgets, gSignalConnect, signal="toggled", f=function(self, widget, event, ...) {
self$notify_observers(signal="toggled", ...)
}, data=.self, user.data.first=TRUE)
invisible()
},
get_length = function() {
length(widgets)
},
set_font=function(value) {
sapply(widgets, function(bg) {
set_rgtk2_font(bg$child, value)
})
}
))
## uses table for checkboxes
GCheckboxGroupTable <- setRefClass("GCheckboxGroupTable",
contains="GWidget",
methods=list(
initialize=function(toolkit,
items, checked = FALSE,
handler = NULL,
action = NULL, container = NULL, ... ) {
widget <<- gtkTreeViewNew(TRUE)
widget$SetRulesHint(TRUE) # shade
block <<- gtkScrolledWindowNew()
block$SetPolicy("GTK_POLICY_AUTOMATIC","GTK_POLICY_AUTOMATIC")
block$Add(widget)
store <- rGtkDataFrame(make_items())
widget$setModel(store)
widget$setHeadersVisible(FALSE)
## set up the view columns
vc <- gtkTreeViewColumnNew()
widget$insertColumn(vc, 0)
cr <- gtkCellRendererToggle()
vc$PackStart(cr, TRUE)
cr['activatable'] <- TRUE # needed
vc$addAttribute(cr, "active", 1)
item.toggled <- function(tbl, cell, path, data) {
store <- tbl$getModel()
row <- as.numeric(path) + 1
store[row,2] <- !store[row, 2]
}
gSignalConnect(cr, "toggled", item.toggled, data=widget, user.data.first=TRUE)
cr <- gtkCellRendererTextNew()
vc <- gtkTreeViewColumnNew()
vc$PackStart(cr, TRUE)
vc$addAttribute(cr, "text", 0)
widget$insertColumn(vc, 1)
## icons, tooltips???
initFields(change_signal="toggled")
set_items(value=items)
set_index(checked)
add_to_parent(container, .self, ...)
handler_id <<- add_handler_changed(handler, action)
callSuper(toolkit)
},
## helper function
make_items = function(items, icons, tooltips, checked=rep(FALSE, length(items))) {
if(missing(items) ||
(is.data.frame(items) && nrow(items) == 0) ||
(length(items) == 0)
) {
out <- data.frame(items=character(0),
checked=logical(0),
icons=character(0),
tooltips=character(0),
stringsAsFactors=FALSE)
} else if(is.data.frame(items)) {
## check
out <- items
if(ncol(out) == 1)
out$checked <- as.logical(rep(checked, length=nrow(items)))
if(ncol(out) == 2)
out$icons <- rep("", nrow(items))
if(ncol(out) == 3)
out$tooltip <- rep("", nrow(items))
} else {
## piece together
items <- as.character(items)
if(missing(icons))
icons <- ""
icons <- rep(icons, length=length(items))
if(missing(tooltips))
tooltips <- ""
icons <- rep(tooltips, length=length(items))
checked <- rep(checked, length=length(items))
out <- data.frame(items=items, checked=checked, icons=icons, tooltips=tooltips,
stringsAsFactors=FALSE)
}
return(out)
},
get_value=function(drop=TRUE, ...) {
get_items(get_index())
},
set_value=function(value, drop=TRUE, ...) {
ind <- match(value, get_items())
ind <- ind[!is.na(ind)]
set_index(ind)
},
get_index = function(...) {
store <- widget$getModel()
vals <- store[,2, drop=TRUE]
which(vals)
},
set_index=function(value, ...) {
if(is.numeric(value)) {
value <- is.element(seq_len(get_length()), value)
}
store <- widget$getModel()
store[,2] <- value
invoke_change_handler()
## how to get view of model to update? (toggle signal of cell renderer?)
},
get_items = function(i, ...) {
store <- widget$getModel()
items <- store[,1, drop=TRUE]
items[i]
},
set_items = function(value, i, ...) {
items <- make_items(value)
if(missing(i)) {
## replace the store
newStore <- rGtkDataFrame(items)
widget$setModel(newStore)
} else {
if(is.logical(i))
i <- which(i)
store[i,] <- items
}
invoke_change_handler()
},
get_length = function() {
"Number of items to choose from"
length(get_items())
},
## handlers
handler_widget=function() {
## put handler on cell renderer, not widget
view_column <- widget$getColumn(0)
cell_renderer <- view_column$getCellRenderers()[[1]]
cell_renderer
}
))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.