R/gdf.R
In jverzani/gWidgets2RGtk2: Implementation of gWidgets2 for the RGtk2 Package
Defines functions
make_editable_cell_renderer.Date
make_editable_cell_renderer.logical
make_editable_cell_renderer.factor
make_editable_cell_renderer.default
make_editable_cell_renderer
add_editable_cell_renderer
my_date
my_logical
ensure_type.logical
ensure_type.integer
ensure_type.numeric
ensure_type.factor
ensure_type.character
ensure_type.default
ensure_type
.gdf.guiWidgetsToolkitRGtk2
Documented in
add_editable_cell_renderer
ensure_type
.gdf.guiWidgetsToolkitRGtk2
##' @include GWidget.R
##' @include gmenu.R
##' @include dialogs.R
##' @include gtable.R
NULL
## TODO
## * handlers
## * column drag and drop
## * size override for passing in column sizes through a list.
##' Toolkit constructor
##'
##' @export
##' @rdname gWidgets2RGtk2-undocumented
##' @method .gdf guiWidgetsToolkitRGtk2
## @export .gdf guiWidgetsToolkitRGtk2
.gdf.guiWidgetsToolkitRGtk2 <- function(toolkit,
items = NULL,
handler = NULL,action = NULL, container = NULL, ... ) {
GDf$new(toolkit,
items=items,
handler = handler, action = action, container = container, ...)
}
##' S3 generic to ensure we don't change data type when assigning into column
##'
##' @param x column values
##' @param value new value
##' @return coerced new value
ensure_type <- function(x, value) UseMethod("ensure_type")
ensure_type.default <- function(x, value) value
ensure_type.character <- function(x, value) as.character(value)
ensure_type.factor <- function(x, value) {x[length(x) + 1] <- value; utils::tail(x, n=1)}
ensure_type.numeric <- function(x, value) as.numeric(value)
ensure_type.integer <- function(x, value) as.integer(value)
ensure_type.logical <- function(x, value) as.logical(value)
my_logical <- function(x) {
y <- as.character(x)
y[is.na(y)] <- "NA"
y <- factor(y)
class(y) <- c("mylogical", "factor")
y
}
my_date <- function(x) {
y <- format(x)
y[is.na(y)] <- "NA"
class(y) <- c("mydate", "character")
y
}
##' make a view column for the given type of variable
##'
##' @param x variable
##' @param self reference to ModelView object
##' @param model_idx 1-based index in model of data to represent
##' @param view_col optional view column to reuse
##' @return a gtkTreeViewColumn with data "n", and "id" to block editable id
add_editable_cell_renderer <- function(x, self, model_idx, view_col) {
## Make column, set editable
if(missing(view_col))
view_col <- gtkTreeViewColumnNew()
else
view_col$clear()
make_editable_cell_renderer(x, self, model_idx, view_col)
event_box <- gtkEventBox()
event_box$SetVisibleWindow(FALSE)
label <- gtkLabel()
event_box$add(label)
event_box$setAboveChild(TRUE) # gets events to box
view_col$setWidget(event_box)
view_col
}
## Make cell renderer for above. Dispatches on x
make_editable_cell_renderer <- function(x, self, model_idx, view_col) UseMethod("make_editable_cell_renderer")
make_editable_cell_renderer.default <- function(x, self, model_idx, view_col) {
cr <- gtkCellRendererText()
cr['editable'] <- TRUE
cr$setData("editable", "editable")
cr$setData("view_col", view_col) # no lookup otherwise
view_col$setResizable(TRUE)
view_col$packStart(cr, TRUE)
view_col$addAttribute(cr, "text", model_idx - 1L)
## make editable
id <- gSignalConnect(cr,
signal="edited",
f=function(cr, path, newtext) {
visible <- self$get_visible()
i <- which(visible)[as.numeric(path) + 1]
view_col <- cr$getData("view_col")
j <- self$get_column_index(view_col)
self$cmd_set_cell(i, j, newtext)
})
view_col$setData("n", model_idx) # map to model
view_col$setData("edit.id", id) # use this to disable editing
}
make_editable_cell_renderer.factor <- function(x, self, model_idx, view_col) {
cr <- gtkCellRendererCombo()
model <- rGtkDataFrame(levels(x))
cr['model'] <- model
cr['text-column'] <- 0
cr['editable'] <- TRUE
cr$setData("editable", "editable")
cr$setData("view_col", view_col) # no lookup otherwise
view_col$setResizable(TRUE)
view_col$packStart(cr, TRUE)
view_col$addAttribute(cr, "text", model_idx - 1L)
## make editable
id <- gSignalConnect(cr,
signal="edited",
f=function(combo, path, newdata) {
visible <- self$get_visible()
i <- which(visible)[as.numeric(path) + 1]
view_col <- cr$getData("view_col")
j <- self$get_column_index(view_col)
self$cmd_set_cell(i, j, newdata) # toggle
})
view_col$setData("n", model_idx) # map to model
view_col$setData("edit.id", id) # use this to disable editing
}
make_editable_cell_renderer.logical <- function(x, self, model_idx, view_col) {
cr <- gtkCellRendererToggle()
cr['activatable'] <- TRUE
cr$setData("editable", "activatable")
cr$setData("view_col", view_col) # no lookup otherwise
view_col$setResizable(TRUE)
view_col$packStart(cr, TRUE)
view_col$addAttribute(cr, "active", model_idx - 1L)
## make editable
id <- gSignalConnect(cr,
signal="toggled",
f=function(cr, path, data) {
visible <- self$get_visible()
i <- which(visible)[as.numeric(path) + 1]
view_col <- cr$getData("view_col")
j <- self$get_column_index(view_col)
self$cmd_set_cell(i, j, !self$get_cell(i, j)) # toggle
})
view_col$setData("n", model_idx) # map to model
view_col$setData("edit.id", id) # use this to disable editing
}
make_editable_cell_renderer.Date <- function(x, self, model_idx, view_col) {
cr <- gtkCellRendererText()
cr['editable'] <- TRUE
cr$setData("editable", "editable")
cr$setData("view_col", view_col) # no lookup otherwise
view_col$setResizable(TRUE)
view_col$packStart(cr, TRUE)
view_col$addAttribute(cr, "text", model_idx - 1L)
view_col$setCellDataFunc(cr, function(vc, cr, model, iter, ...) {
## set cell value by formatting
col <- self$get_column_index(cr$getData("view_col"))
row <- as.numeric(model$getPath(iter)$toString()) + 1L
val <- self$get_cell(row, col)
cr["text"] <- format(val)
})
## make editable
id <- gSignalConnect(cr,
signal="edited",
f=function(cr, path, newtext) {
visible <- self$get_visible()
i <- which(visible)[as.numeric(path) + 1]
view_col <- cr$getData("view_col")
j <- self$get_column_index(view_col)
## calls ensure_type to format
self$cmd_set_cell(i, j, newtext)
})
view_col$setData("n", model_idx) # map to model
view_col$setData("edit.id", id) # use this to disable editing
}
make_editable_cell_renderer.POSIXt <- make_editable_cell_renderer.Date
## This is a bit convoluted due to the command framework. To do
## something, say set a cell value we have 3 methods! One is a
## gWidgets methods (\code{set_items(i,j,value)}), this in turn calls
## a command with undo/redo support (\code{cmd_set_cell}), the
## command relies on the third method to actual set the cell value
## (\code{set_cell(i,j,value)}). To make matters worse, there is an
## issue defining one-off reference classes within a reference class
## when the \code{<<-} operator is involved. As such, we have a
## fourth place things may be defined -- in reference class
## definitions appearing after the one for \code{GDf}. Be warned,
## this is a maintenance issue.
GDfBase <- setRefClass("GDfBase",
contains="GWidget",
fields=list(
model="ANY",
store="ANY",
freeze_attributes="character", # one of FALSE, TRUE, "row", or "column"
cmd_stack="ANY",
cell_popup_id="ANY"
),
methods=list(
set_frame=function(items) {
"Change data frame, update view, clear out stack"
clear_stack()
clear_view_columns()
## if any row is all NA, then we set the class to numeric
for (nm in names(items)) {
if(all(is.na(items[nm]))) {
items[nm] <- rep(NA_real_, nrow(items))
}
}
## turn logical into factor -- must turn back
inds <- which(sapply(items, function(x) is(x, "logical")))
for (i in inds)
items[[i]] <- my_logical(items[[i]])
## turn date into character -- must turn back
inds <- which(sapply(items, function(x) is(x, "Date")))
for (i in inds)
items[[i]] <- my_date(items[[i]])
mod_items <- cbind(`_visible`=rep(TRUE, nrow(items)),
`_deleted`=rep(FALSE, nrow(items)),
`_rownames`=I(rownames(items)),
items)
model$setFrame(mod_items)
add_view_columns()
},
save_data=function(nm, where) {
assign(nm, get_frame(), where)
cmd_stack$clear()
},
##
## View column methods
##
get_view_column=function(j) {
"Return view column in column j (1-based). Use j=0 for rownames column"
widget$getColumns()[[j + 1L]] # skip rownams
},
clear_view_columns=function() {
"Clear out all view columns from view"
sapply(rev(widget$getColumns()), widget$removeColumn)
},
add_view_columns=function() {
"Add view columns to treeview widget"
DF <- as.data.frame(model)
## add row names column
view_col<- add_editable_cell_renderer(as.character(DF[[3]]), self=.self, model_idx=3)
cr <- view_col$getCellRenderers()[[1]]; cr['font'] <- "Bold"
widget$insertColumn(view_col, -1L)
## add remaining columns
sapply(seq_along(DF[,-(1:3), drop=FALSE]), function(i) {
view_col <- add_editable_cell_renderer(DF[[i + 3L]], self=.self, model_idx=i + 3L)
widget$insertColumn(view_col, -1L)
if(!freeze_attributes %in% c("TRUE", "column"))
add_popup_to_view_col(view_col)
})
## set names
set_names(names(DF)[-(1:3)]) # remove first 3!
},
##
## Get the data
##
get_frame=function() {
"Get data frame from columns. Skips deleted rows, but returns non-visible ones"
columns <- widget$getColumns()[-1] # drop rownames
cols <- sapply(columns, function(vc) vc$getData("n"))
out <- as.data.frame(model)
## must convert character to Date before subsetting.
inds <- which(sapply(out, function(x) is(x, "mylogical")))
for (i in inds)
out[[i]] <- as.logical(out[[i]])
## convert mydate to date
inds <- which(sapply(out, function(x) is(x, "mydate")))
for (i in inds)
out[[i]] <- as.Date(out[[i]])
out <- out[not_deleted(),cols, drop=FALSE]
names(out) <- get_names()
rownames(out) <- make.unique(get_rownames())
out
},
## DND
## XXX This needs fleshing out
add_dnd_columns=function() {
## Hack to add in drag and drop to columns
remove_popup_menu()
add_dnd_to_vc <- function(vc) {
vc$setClickable(TRUE)
btn <- vc$getWidget()$getParent()$getParent()$getParent()
label <- vc$getWidget()$getChild()
gtkDragSourceSet(btn,
start.button.mask=c("button1-mask", "button3-mask"),
targets=widgetTargetTypes[["text"]],
actions="copy")
gSignalConnect(btn, "drag-data-get", function(data, widget, contet, sel, ty, tm, ...) {
sel$setText(data$getLabel(), -1)
}, label, user.data.first=TRUE)
}
QT <- Map(add_dnd_to_vc, widget$getColumns())
},
##
## Column methods
##
add_column=function(x, nm) {
"Add column to end of model, create new view column, set name to nm"
n <- get_dim()[2]
if(missing(nm))
nm <- sprintf("X%s", n)
frame <- as.data.frame(model)
frame[not_deleted(),ncol(frame) + 1] <- x
model$setFrame(frame)
model_n <- dim(model)[2]
view_col <- add_editable_cell_renderer(x, .self, model_n)
widget$insertColumn(view_col, -1)
add_popup_to_view_col(view_col)
j <- get_column_index(view_col)
set_name(j, nm)
model_n # return
},
insert_column=function(j, model_idx, nm) {
"Insert column j with model number model_idx and name name"
DF <- as.data.frame(model)
view_col <- add_editable_cell_renderer(DF[[model_idx]], .self, model_idx)
view_col$getWidget()$getChild()$setLabel(nm)
widget$insertColumn(view_col, j)
add_popup_to_view_col(view_col)
},
remove_column=function(j) {
"Remove column from view. Keeps data in model. Returns name and index in model to undo"
column <- get_view_column(j)
old_nm <- get_name(j)
model_idx <- column$getData("n") # model_idx is 1-based
widget$removeColumn(column)
invoke_change_handler()
## return info to reconstruct
invisible(list(nm=old_nm, model_idx=model_idx ))
},
move_column=function(from ,to) {
"Move a view column from j to i, shift others over. Does not effect model."
columns <- widget$getColumns()[] # includes rownames as 1, so no shift over
from_col <- columns[[from + 1L]]
to_col <- columns[[to]]
widget$moveColumnAfter(from_col, to_col)
},
hide_column=function(j, value) {
"Hide column j (view coordinates). Hiding column j does not remove it and j still refers to this column. That is view coordinates are different from what is in GUI"
column <- get_view_column(j)
column$setVisible(!as.logical(value))
invisible(!value)
},
unhide_column=function(j) {
column <- get_view_column(j)
column$setVisible(TRUE)
},
is_editable=function(j) {
column <- get_view_column(j)
cr <- column$getCellRenderers()[[1]]
cr[cr$getData("editable")]
},
block_editable_column=function(j) {
"Block that column j can be edited"
column <- get_view_column(j)
cr <- column$getCellRenderers()[[1]]
cr[cr$getData("editable")] <- FALSE
},
unblock_editable_column=function(j) {
"unblock that column j can be edited"
column <- get_view_column(j)
cr <- column$getCellRenderers()[[1]]
cr[cr$getData("editable")] <- TRUE
},
##
## Row methods
##
hide_row=function(i,value=TRUE) {
"Hide row i, i refers to non-deleted rows. value if TRUE to hide, FALSE to unhide"
i <- map_i(i)
model[i,1] <<- !as.logical(value)
invisible(!value) # return opposite for command framework
},
remove_row=function(i, value, model_index=FALSE) {
"Delete row"
## we don't actually delete, we just make not visible and deleted.
if(!model_index)
i <- map_i(i)
model[i,1] <<- !as.logical(value)
model[i,2] <<- as.logical(value)
invisible(i)
},
unremove_row=function(model_i) {
"Un delete row model_i."
model[model_i,1] <<- TRUE # show it
model[model_i,2] <<- FALSE
},
insert_row=function(i, value) {
"Insert new row after position i, i=0:nrow"
## we insert row into model. How depends on what i is.
DF <- as.data.frame(model)
if(i == 0) {
## first
new_DF <- DF[c(1, seq_len(nrow(DF))), ]
new_i <- 1
} else if(i >= get_dim()[1]) {
i <- get_dim()[1] # in case bigger
## end
new_DF <- DF[c(seq_len(nrow(DF)), 1), ]
new_i <- nrow(new_DF)
} else {
## middle
ii <- map_i(i)
new_DF <- DF[c(1:ii, 1, (ii+1):nrow(DF)), ]
new_i <- ii + 1
}
## clear
n <- ncol(new_DF)
new_DF[new_i,] <- lapply(1:n, function(i) NA)
new_DF[new_i, 1:3] <- list(TRUE, FALSE, "")
if(!missing(value)) {
ind <- sapply(widget$getColumns()[-1], function(vc) vc$getData("n"))
new_DF[new_i, ind] <- value
}
model$setFrame(new_DF)
return(new_i) # new column in model coordinates
},
## names
set_view_column_name=function(column, value) {
j <- get_column_index(column)
old_nm <- get_name(j)
column$getWidget()$getChild()$setLabel(value)
return(old_nm)
},
set_name = function(j, value) {
"Set view column's name"
old_nm <- get_name(j)
column <- get_view_column(j)
column$getWidget()$getChild()$setLabel(value)
invoke_change_handler()
return(old_nm)
},
get_name=function(j) {
column <- get_view_column(j)
column$getWidget()$getChild()$getLabel()
},
hide_names=function(value) {
"Toggle display of names by logical values"
widget$setHeadersVisible(as.logical(value))
},
set_row_name=function(i, value) {
i <- map_i(i)
old_value <- model[i, 3L]
model[i, 3L] <<- value
invisible(old_value)
},
hide_row_names=function(value) {
"Toggle display of row names by logical value"
hide_column(0, value)
},
##
## mappings between view columns and model
##
get_column_index=function(view_col) {
"Get view column index from view column"
columns <- widget$getColumns()[-1] # no reownames
Filter(function(i) identical(columns[[i]], view_col), seq_along(columns))
},
map_j=function(j) {
"get column in model from j"
column <- get_view_column(j) # skip rownames
n <- column$getData("n") # 0-based
n
},
not_deleted=function() {
"Return indices of non deleted model rows"
which(!model[,2L])
},
map_i=function(i) {
"Return model index from i (possibl sorted, removed, ...)"
## i is in order, but we skip over deleted -- but not filtered
not_deleted()[i]
},
##
## Values by cell, column
##
get_cell=function(i,j) {
"Get value in cell i,j using view coordinates"
model[map_i(i), map_j(j)]
},
set_cell=function(i, j, value) {
"set cell, i, j in view coordinates (including hidden). Return old_value"
n <- map_j(j)
old_value <- model[map_i(i), n]
model[map_i(i), n] <<- ensure_type(model[,n], value)
old_value
},
get_column_value=function(j) {
"Get data in model for jth column in view coordinates"
model[not_deleted(), map_j(j)]
},
##
## Selection methods. From gtable
##
get_selected=function() {
"Get selected indices or numeric(0)"
sel_model <- widget$getSelection()
x <- sapply(sel_model$getSelectedRows()$retval, gtkTreePathToString)
if(is.null(x))
x <- integer(0)
else
x <- as.numeric(x) + 1L
seq_len(nrow(model))[model[,1]][x] # not deleted
},
set_selected=function(ind) {
"Set selected rows by index"
old_ind <- get_selected()
ind <- seq_len(nrow(model))[!model[,2]][ind]
sel_model = widget$getSelection()
block_handlers()
sel_model$unselectAll()
lapply(ind, function(i) {
sel_model$selectPath(gtkTreePathNewFromString(i-1))
})
unblock_handlers()
},
set_selectmode=function(mode=c("none", "single", "browse", "multiple")) {
sel = widget$getSelection()
sel$setMode(match.arg(mode))
},
##
## Popup menu methods. From gtable (should be a subclass)
##
default_popup_menu=function(view_col) {
"Provide default popup menu (passed to gmenu(..., popup=TRUE))"
j <- get_column_index(view_col)
x <- get_column_value(j)
nm <- get_name(j)
## intercept row names
types <- c("other", "character", "factor", "numeric", "logical")
tmp <- function(x) UseMethod("tmp")
tmp.default <- function(x) ""
tmp.numeric <- function(x) "numeric"
tmp.factor <- function(x) "factor"
tmp.character <- function(x) "character"
tmp.logical <- function(x) "logical"
actions <- list(
gaction("Rename column", handler=function(h,...) {
out <- ginput(gettext("New column names:"), nm, title=gettext("Rename column"), parent=.self)
if(nchar(out))
cmd_set_column_name(j, out)
}),
gseparator(),
gaction("Insert column...", handler=function(h,...) {
## need x, nm
x <- character(get_dim()[1])
nm <- "Replace me"
cmd_insert_column(x, nm, j)
}),
gaction("Delete column", handler=function(h,...) {
cmd_remove_column(j)
}),
## gaction("Hide column", handler=function(h,...) {
## cmd_hide_column(j)
## }),
gseparator(),
## Coerce class of object
gradio(types, selected=getWithDefault(match(tmp(x), types), 1L), handler=function(h,...) {
ind <- svalue(h$obj, index=TRUE)
if(ind > 1)
cmd_coerce_column(j, get(sprintf("as.%s", types[ind])))
}),
gseparator(),
gaction("Edit factor levels...", handler=function(h, ...) {
collapseFactor <- function(f, parent = NULL) {
out <- character()
w <- gbasicdialog("Edit factor levels", parent = parent,
handler = function(h,...) {
new_f <- relf$get_value()
if(!is.factor(new_f))
new_f <- factor(new_f)
assign("out", new_f, inherits=TRUE)
})
size(w) <- c(600, 400)
g <- ggroup(cont = w)
relf <- CollapseFactor$new(f, cont = g)
visible(w, set = TRUE)
out
}
out <- collapseFactor(x)
if(length(out)) {
cmd_replace_column(out, j)
}
}),
gseparator(),
gcheckbox("Editable", checked=is_editable(j), handler=function(h,...) {
if(svalue(h$obj))
unblock_editable_column(j)
else
block_editable_column(j)
}),
gseparator(),
gaction("Apply function ...", handler=function(h,...) {
w <- gbasicdialog(gettext("Apply a function to values in the column"), parent=.self, handler=function(h,...) {
val <- svalue(txt)
new_x <- eval(parse(text=val), envir=list(x=x))
if(is.vector(new_x))
cmd_insert_column(new_x)
else
galert(gettext("Expression did not return a vector"), parent=.self)
})
txt <- gtext("sapply(x, function(i) {\n\n})", cont=w)
visible(w, TRUE)
})
)
enabled(actions[[8]]) <- is.factor(x)
actions
},
add_popup_menu=function(menulist) {
f <- function(...) menulist
add_popup(f)
},
add_popup=function(menu_fun=NULL) {
"Add a popup menu to the columns. Function should generate list of actions, ..."
sapply(widget$getColumns()[-1], function(view.col) {
add_popup_to_view_col(view.col, menu_fun)
})
},
add_popup_to_view_col=function(view.col, menu_fun) {
if(freeze_attributes %in% c("TRUE", "column")) {
return() # no popup menu if frozen
}
if(missing(menu_fun))
menu_fun <- .self$default_popup_menu
view.col$setClickable(TRUE)
event_box <- view.col$getWidget()
btn <- event_box$getParent()$getParent()$getParent()
id <- gSignalConnect(btn, "button-press-event", f=function(w, e, data, ...) {
if(isRightMouseClick(e)) {
popup <- gmenu(menu_fun(data), popup=TRUE, toolkit=toolkit)
## This is a *real* hack, as the following doesn't
## work when I use event_box. NOt sure why
## not, seems like the right combination of
## arguments is given
popup$widget$popup(button=e$button, activate.time=e$time)
}
FALSE
}, data=view.col)
btn$setData("popup_id", id)
},
remove_popup_menu=function() {
"remove popup menu from column headers"
sapply(widget$getColumns(), function(view.col) {
view.col$setClickable(FALSE)
btn <- view.col$getWidget()$getParent()$getParent()$getParent()
if(!is.null(id <- btn$getData("popup_id")))
gSignalHandlerDisconnect(btn, id)
})
},
default_cell_popup_menu=function() {
## returns a function of i,j which produces actions for a popup menu
## j=0 when rownames column
f <- function(self, i, j) {
if(j == 0) {
## rownames popup
actions <- list(
gaction("Insert row", handler=function(...) {
self$cmd_insert_row(i)
}),
gaction("Delete row", handler=function(...) {
self$cmd_remove_row(i)
})#,
## gaction("Hide row", handler=function(...) {
## self$cmd_hide_row(i)
## })
)
} else {
## No idea what to put here...
actions <- list(
gaction("cell popup")
)
}
}
return(f)
},
add_cell_popup=function(menu_fun) {
"Add cell popup, pass in function to produce menu or uses default"
if(missing(menu_fun))
menu_fun <- default_cell_popup_menu()
id <- gSignalConnect(widget, "button-press-event", f=function(w, e, self) {
if(isRightMouseClick(e)) {
path <- w$getPathAtPos(e$x, e$y)
if(!path$retval) # no path
return(FALSE)
i <- visible <- self$get_visible()
i <- which(visible)[as.numeric(path$path$toString()) + 1]
j <- self$get_column_index(path$column)
if(length(j) == 0) j <- 0
## Can have popup on cells, but right now don't know what to put there
if(j == 0) {
popup <- gmenu(menu_fun(self, i, j), popup=TRUE, toolkit=toolkit)
popup$widget$popup(button=e$button, activate.time=e$time)
}
}
FALSE
}, data=.self)
cell_popup_id <<- id
},
remove_cell_popup=function() {
"Remove cell popup"
gSignalHandlerDisconnect(widget, cell_popup_id)
},
##
## Main GWidget interface. Need gWidgets (svalue) and matrix interface
##
get_dim=function() {
"size of displayed data"
ncols <- length(widget$getColumns()) - 1L # no rownames
nrows <- length(model[not_deleted(),1])
c(rows=nrows, cols=ncols)
},
get_length=function() {
get_dim()[2]
},
get_value=function(drop=TRUE, ...) {
ind <- get_selected()
if(length(ind) == 0)
return(NULL) # ?? what is right?
DF <- get_frame()
if(drop)
DF[ind, 1]
else
DF[ind,]
},
set_value=function(value, ...) {
},
get_index=function(...) {
get_selected()
},
set_index=function(value, ...) {
set_selected(value)
},
get_items=function(i,j, ...,drop=TRUE) {
x <- get_frame()
x[i,j, ..., drop=drop]
},
set_items=function(value, i, j, ...) {
"Replace part of data: whole thing, by column, by cell. By row?"
### XXX Need checks on i,j bounds not exceeding. Need to call insert_column, insert_row otherwise
if(missing(i) && missing(j)) {
if(!is.data.frame(value))
value <- data.frame(value, stringsAsFactors=FALSE)
set_frame(value)
} else if(missing(i)) {
## replace column by column
if(is.vector(value))
cmds <- list(cmd_replace_column(value, j))
else
cmds <- lapply(seq_along(j), function(i) cmd_replace_column(value[i], j[i], add=FALSE))
cmd_stack$add(gWidgets2:::CommandList$new(lst=cmds))
} else if(missing(j)) {
## XXX need to add this row by row!
value <- as.data.frame(value)
sapply(seq_along(value), function(col) .self$set_items(value[,row], i, col))
} else {
if(length(i) == 1) {
value <- rep(value, length=length(j)) # recyle
cmd_list <- lapply(seq_along(j), function(jj) cmd_set_cell(i, j[jj], value[jj], add=FALSE))
} else if(length(j) == 1) {
value <- rep(value, length=length(i)) # recyle
cmd_list <- lapply(seq_along(i), function(ii) cmd_set_cell(i[ii], j, value[ii], add=FALSE)) } else {
## no recycling
if(length(i) != nrow(value) || length(j) != ncol(value))
stop(gettext("value is not of correct dimensions for indices"))
cmd_list <- lapply(seq_len(length(i) * length(j)), function(x) NULL)
ctr <- 1
for(ii in seq_along(i))
for(jj in seq_along(j)) {
cmd_list[[ctr]] <- cmd_set_cell(i[ii], j[jj], value[i[ii], j[jj]], add=FALSE)
ctr <- ctr + 1
}
}
cmd_stack$add(gWidgets2:::CommandList$new(lst=cmd_list))
}
},
get_names=function() {
sapply(widget$getColumns()[-1], function(vc) vc$getWidget()$getChild()$getLabel())
},
set_names=function(value) {
"Set the names of each column"
## modify when using widget, not default
#f <- function(vc, nm) vc$getWidget()$getChild()$setLabel(nm)
#mapply(f, widget$getColumns()[-1], value)
cmd_set_column_names(value)
},
get_rownames=function() {
model[not_deleted(), 3] # fixed
},
set_rownames=function(value) {
if(length(value) != length(not_deleted()))
return() # wrong length
old_names <- get_rownames()
model[not_deleted(),3] <<- value
invisible(old_names)
},
get_dimnames=function() {
list(rownames=get_rownames(), colnames=get_names())
},
set_dimnames=function(value) {
XXX()
},
get_visible=function() {
"Return which rows are visible"
model[not_deleted(),1L]
},
set_visible=function(value) {
## don't update
block_handlers()
if(length(value) == length(not_deleted()))
model[not_deleted(), 1L] <<- as.logical(value)
unblock_handlers()
},
get_editable=function(j) {
is_editable(j)
},
set_editable=function(value, j, ...) {
"Make a column editable or not."
if(value)
unblock_editable_column(j)
else
block_editable_column(j)
},
##
## Handler code
##
handler_widget=function() {
## for add_handler_changed
model
},
add_handler_clicked=function(handler, action=NULL, ...) {
## put this on tree view, we used handler_widget for the model
signal <- "button-press-event"
if(is_handler(handler)) {
o <- gWidgets2:::observer(.self, event_decorator(handler), action)
invisible(add_observer(o, signal))
gSignalConnect(widget, signal, function(...) {
.self$notify_observers(signal=signal, ...)
})
connected_signals[[signal]] <<- TRUE
}
},
add_handler_column_clicked=function(handler, action=NULL, ...) {
XXX()
},
add_handler_column_double_click=function(handler, action=NULL, ...) {
XXX()
},
add_handler_column_right_click=function(handler, action=NULL, ...) {
XXX()
},
##
## Command infrastructure
##
clear_stack=function() cmd_stack$clear(),
can_undo=function() cmd_stack$can_undo(),
can_redo=function() cmd_stack$can_do(),
undo=function() cmd_stack$undo(),
redo=function() cmd_stack$redo(),
##
## Commands with undo support
##
cmd_set_cell=function(i, j, value, add=TRUE) {
"Set cell i,j (in view indices) to value"
if(length(j)) {
cmd <- gWidgets2:::Command$new(receiver=.self, meth="set_cell",i=i, j=j, value=value)
} else {
## setting row name
cmd <- gWidgets2:::Command$new(receiver=.self, meth="set_row_name",i=i, value=value)
}
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
## Column commands.
cmd_insert_column=function(x, nm, j, add=TRUE) {
"Insert values from x into j"
if(missing(nm))
nm <- gettext("Replace me")
if(missing(j))
j <- get_dim()[2]
cmd <- InsertColumn$new(.self, meth="", x=x, nm=nm, j=j)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_replace_column=function(x, j, add=TRUE) {
"Replace values in column j with x"
cmd <- ReplaceColumn$new(.self, meth="", x=x, j=j)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_remove_column=function(j, add=TRUE) {
"remove column j"
cmd <- RemoveColumn$new(.self, meth="", j=j)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_hide_column=function(j, add=TRUE) {
"hide column j"
## do command
cmd <- gWidgets2:::Command$new(receiver=.self, meth="hide_column", j=j, value=TRUE)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_unhide_column=function(j, add=TRUE) {
"Show hidden column j"
## do command
cmd <- setRefClass("UnhideColumn",
contains="Command",
methods=list(
do=function() receiver$unhide_column(params$col),
undo=function() receiver$hide_column(params$col)
))$new(.self, meth="", col=j)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_coerce_column=function(j, coerce_with, add=TRUE) {
"Coerce column using coerce_with function, e.g. as.integer or as.character"
x <- get_column_value(j)
x <- coerce_with(x)
cmd <- ReplaceColumn$new(.self, meth="", j=j, x=x)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_set_column_name=function(j, nm, add=TRUE) {
cmd <- gWidgets2:::Command$new(receiver=.self, meth="set_name", j=j, value=nm)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_set_column_names=function(value, add=TRUE) {
if(length(value) != get_dim()[2])
stop(gettext("Wrong length names"))
cmds <- lapply(seq_along(value), function(j) cmd_set_column_name(j, value[j], add=FALSE))
cmdlist <- gWidgets2:::CommandList$new(lst=cmds)
if(add)
cmd_stack$add(cmdlist)
invisible(cmdlist)
},
## row commands
cmd_insert_row=function(i, nm, add=TRUE) {
if(missing(nm))
nm <- ""
cmd <- InsertRow$new(.self, meth="", i=i, nm=nm)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_remove_row=function(i, add=TRUE) {
cmd <- RemoveRow$new(.self, meth="", i=i)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_hide_row=function(i, add=TRUE) {
cmd <- gWidgets2:::Command$new(.self, meth="hide_row", i=i, value=TRUE)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_unhide_row=function(i, add=TRUE) {
cmd <- gWidgets2:::Command$new(.self, meth="hide_row", i=i, value=FALSE)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
}
))
##' For \code{RGtk2}, a GDf object has several methods defined for it
##' that are toolkit specific, but may be useful. For example, the
##' columns may be made editable or non editable
##' (\code{block_editable_column} and \code{unblock_editable_column})
##' (accessed through \code{editable<-}); the headers can be
##' hidden/shown through the method \code{hide_names(boolean)}; the
##' rownames can be hidden/shown through themethod
##' \code{hide_row_names(boolean)}; the popup menus for the headers
##' can be removed (\code{remove_popup_menu}) and customized
##' (\code{add_popup}); similarly the cell popup can be
##' (\code{remove_cell_popup} and \code{add_cell_popup}).
##'
##' Passing in a value \code{freeze_attributes = TRUE} will make it so
##' there are no menu items to resize frame, change variable types,
##' relabel factors, .... Values of \code{"row"} or \code{"column"}
##' will remove popup menus just for the row or columns.
##'
##' @rdname gWidgets2RGtk2-package
GDf <- setRefClass("GDf",
contains="GDfBase",
methods=list(
initialize=function(toolkit, items, name=deparse(substitute(df)),
handler=NULL, action=NULL,
container=NULL,
...) {
model <<- rGtkDataFrame()
store <<- model$filter()
store$setVisibleColumn(0L)
widget <<- gtkTreeView()
widget$setModel(store)
## make pretty XXX shade, ...
widget$setRulesHint(TRUE)
widget$setGridLines(GtkTreeViewGridLines['both'])
## block is scrolled window
block <<- gtkScrolledWindow()
block$setPolicy("GTK_POLICY_AUTOMATIC","GTK_POLICY_AUTOMATIC")
block$add(widget)
## command stack
cmd_stack <<- gWidgets2:::CommandStack$new()
## initialize fields
initFields(default_expand=TRUE,
default_fill=TRUE,
change_signal="row-changed",
freeze_attributes = as.character(getWithDefault(list(...)$freeze_attributes, FALSE))
)
if(!is.data.frame(items))
items <- data.frame(items, stringsAsFactors=FALSE)
set_frame(items)
## adjust if we should freeze attributes
if(freeze_attributes %in% c("TRUE", "row")) {
set_editable(FALSE, 0) # don't edit row names
}
if(!freeze_attributes %in% c("TRUE", "row")) {
## menus only good once realized
gSignalConnect(widget, "realize", f=function(...) .self$add_cell_popup())
}
add_to_parent(container, .self, ...)
##handler_id <<- add_handler_changed(handler, action)
callSuper(toolkit)
}
))
## Some commands defined as separate classes. Put here, not inline as
## Issue here with <<- within command
## These are not exported or documented.
ReplaceColumn <- setRefClass("ReplaceColumn",
contains="Command",
methods=list(
do=function() {
j <- params$j
params$old_n <<- receiver$map_j(j)
#
x <- params$x
params$nm <<- receiver$get_name(j)
receiver$add_column(x, params$nm)
params$new_n <<- receiver$get_dim()[2]
params$new_index <<- ncol(receiver$model) # new model index
receiver$remove_column(j)
receiver$move_column(params$new_n - 1L, j)
},
undo=function() {
DF <- as.data.frame(receiver$model)
n <- params$old_n
add_editable_cell_renderer(DF[[n]], self=receiver, model_idx=n, receiver$get_view_column(params$j))
receiver$set_name(params$j, params$nm)
},
redo=function() {
DF <- as.data.frame(receiver$model)
n <- params$new_index
add_editable_cell_renderer(DF[[n]], self=receiver, model_idx=n, receiver$get_view_column(params$j))
receiver$set_name(params$j, params$nm)
}
))
InsertColumn <- setRefClass("InsertColumn",
contains="Command",
methods=list(
do=function() {
n <- receiver$add_column(params$x, params$nm)
params$model_idx <<- n
receiver$move_column(receiver$get_dim()[2], params$j + 1) # to right
},
undo=function() {
receiver$remove_column(params$j + 1)
},
redo=function() {
## adds another column, not sure why
receiver$insert_column(params$j + 1, params$model_idx, params$nm)
}
))
RemoveColumn <- setRefClass("RemoveColumn",
contains="Command",
fields=list(
"model_idx"="numeric"
),
methods=list(
do=function() {
out <- receiver$remove_column(params$j) ## nm, model_idx
params$nm <<- out$nm; params$model_idx <<- out$model_idx
},
undo=function() {
receiver$insert_column(params$j, params$model_idx, params$nm)
},
redo=function() do()
))
InsertRow <- setRefClass("InsertRow",
contains="Command",
fields=list(
row_num="ANY"
),
methods=list(
do=function() {
row_num <<- receiver$insert_row(params$i)
receiver$set_row_name(row_num, params$nm)
},
undo=function() {
receiver$remove_row(row_num, TRUE, model_index=TRUE)
},
redo=function() {
receiver$unremove_row(row_num)
}
))
RemoveRow <- setRefClass("RemoveRow",
contains="Command",
fields=list(
model_index="ANY"
),
methods=list(
do=function() {
model_index <<- receiver$map_i(params$i)
receiver$remove_row(model_index, TRUE, model_index=TRUE)
},
undo=function() {
receiver$unremove_row(model_index)
},
redo=function() do()
))
## ### Factor editor
## CollapseFactor <- setRefClass("CollapseFactor",
## fields = list(
## old = "ANY",
## widget = "ANY"
## ),
## methods = list(
## initialize = function(fac, cont = gwindow(), ...) {
## old <<- as.character(fac)
## make_gui(cont)
## callSuper()
## },
## make_gui = function(cont) {
## group <- gpanedgroup(cont = cont)
## levs <- sort(unique(as.character(old)))
## DF <- data.frame(original = levs,
## new = levs, stringsAsFactors = FALSE)
## #
## widget <<- tbl <- gtable(DF, cont = group, multiple = TRUE)
## size(tbl) <- c(300, 200)
## #
## nested_group <- ggroup(cont = group, horizontal = FALSE)
## instructions <- gettext(paste(
## "Select a one or more levels.",
## "Enter a new label in the text box.",
## "If there is one level selected, it will be renamed.",
## "If more, they will be collapsed and renamed.",
## sep="\n"))
## #
## glabel(instructions, cont = nested_group)
## # factor_edit <- gcombobox(levs, selected = 0, editable = TRUE,
## # cont = nested_group)
## factor_edit <- gedit("", cont=nested_group)
## # factor_edit[] <- levs
## enabled(factor_edit) <- FALSE
## #
## addHandlerSelectionChanged(widget, function(h,...) {
## ind <- svalue(widget, index = TRUE)
## enabled(factor_edit) <- (length(ind) > 0)
## if (length(ind) > 0) {
## blockHandler(factor_edit)
## svalue(factor_edit) <- svalue(widget)
## unblockHandler(factor_edit)
## }
## })
## ##
## factor_edit_change_handler = function(h,...) {
## ind <- svalue(tbl, index = TRUE)
## if(length(ind) == 0 || ind == 0L) {
## return()
## }
## #
## tbl[ind,2] <- svalue(factor_edit)
## # svalue(tbl, index = TRUE) <- 0
## blockHandler(factor_edit)
## # factor_edit[] <- sort(unique(tbl[,2]))
## # svalue(factor_edit) <- ""
## unblockHandler(factor_edit)
## }
## addHandlerChanged(factor_edit, handler=function(h,...) {
## blockHandler(factor_edit)
## factor_edit_change_handler(h,...)
## svalue(tbl, index=TRUE) <- 0
## focus(tbl) <- TRUE
## unblockHandler(factor_edit)
## })
## addHandlerKeystroke(factor_edit, handler =factor_edit_change_handler)
## addHandlerBlur(factor_edit, handler=function(h,...) {
## svalue(tbl, index = TRUE) <- 0
## svalue(h$obj) <- ""
## })
## },
## get_value = function() {
## "Return factor with new levels"
## old_levels <- widget[,1]
## new_levels <- widget[,2]
## new <- old
## for(i in seq_along(old_levels)) # one pass
## new[new == old_levels[i]] <- new_levels[i]
## factor(new)
## }
## ))
CollapseFactor <- setRefClass("CollapseFactor",
fields = list(
old = "ANY",
cur_reference_level="ANY",
widget = "ANY",
cur_child = "ANY"
),
methods = list(
initialize = function(fac, cont = gwindow(), ...) {
old <<- fac
cur_reference_level <<- levels(fac)[1]
make_gui(cont)
callSuper()
},
make_gui = function(cont) {
directions <- "
Adjust levels of a factor.
One can add a level through the 'Add' button.
Toggle if ordered with checkbox.
Select level to rename, make reference level, or
reorder, as appropriate.
Select levels to collapse.
"
## adjust these properties during dialog
g <- gpanedgroup(container=cont, expand=TRUE)
lg <- gvbox(container=g, fill="y")
rg <- ggroup(container=g, expand=TRUE, fill="both")
## fill left group with table
cur_levels <- gtable(levels(old), container=lg,
multiple=TRUE,
expand=TRUE, fill="y")
size(cur_levels) <- c(width=200, height=400)
names(cur_levels) <- "Levels"
cur_levels$remove_popup_menu()
bg <- ggroup(cont=lg)
add_level <- gbutton("add", cont=bg, handler=function(h,...) {
add_level_dialog(g)
})
tooltip(add_level) <- gettext("Add a new level to factor")
is_ordered <- gcheckbox("Ordered", container=bg, checked=is.ordered(old))
tooltip(is_ordered) <- gettext("Toggle if factor is ordered")
## Fill right group
cur_child <<- gvbox(container=rg, expand=TRUE)
glabel(directions, cont=cur_child, anchor=c(-1,0))
## adjust size after
addHandler(g, "map", function(...) {
svalue(g) <- 0.2
})
## show different things based on selection...
none_selected <- function() {
delete(rg, cur_child)
cur_child <<- gvbox(container=rg, expand=TRUE)
glabel("Directions...", cont=cur_child, anchor=c(-1, 0))
}
one_selected <- function() {
## if one_is selected
delete(rg, cur_child)
cur_child <<- gvbox(container=rg, expand=TRUE)
## offer to relabel
glabel(gettext("Relabel:"), container=cur_child, anchor=c(-1,0))
rename_level <- gedit(svalue(cur_levels),
container=cur_child)
gseparator(container=cur_child)
## give choice of making ordered, or adjusting order
if(svalue(is_ordered)) {
bg <- ggroup(cont=cur_child)
move_up <- gbutton("up", cont=bg, handler=function(h,...) {
ind <- svalue(cur_levels, ind=TRUE)
cur <- cur_levels[]
cur[c(ind-1,ind)] <- cur[c(ind, ind-1)]
## adjust factor
old <<- factor(old, levels=cur)
## adjust GUI
cur_levels[] <- cur
svalue(cur_levels) <- ind - 1
selection_changed()
})
move_down <- gbutton("down", cont=bg, handler=function(h,...) {
ind <- svalue(cur_levels, ind=TRUE)
cur <- cur_levels[]
cur[c(ind,ind + 1)] <- cur[c(ind+1, ind)]
## adjust factor
old <<- factor(old, levels=cur)
## adjust GUI
cur_levels[] <- cur
svalue(cur_levels) <- ind + 1
selection_changed()
})
tooltip(move_up) <- gettext("Move selected level up in the order")
tooltip(move_down) <- gettext("Move selected level down in the order")
cur_ind <- svalue(cur_levels, ind=TRUE)
nlevs <- length(cur_levels[])
enabled(move_up) <- cur_ind > 1
enabled(move_down) <- cur_ind < nlevs
} else {
## can make ordered *or* make reference level
bg <- ggroup(container=cur_child)
ref_button <- gbutton("Set as reference", cont=bg, handler=function(h,...) {
ind <- svalue(cur_levels, index=TRUE)
if (ind == 1) return()
cur_reference_level <<- svalue(cur_levels)
## adjust old
relevel(old, cur_reference_level)
## adjust GUI
blockHandler(cur_levels)
tmp <- cur_levels[]
tmp[c(1, ind)] <- tmp[c(ind, 1)]
cur_levels[] <- tmp
svalue(cur_levels, index=TRUE) <- 1
unblockHandler(cur_levels)
})
tooltip(ref_button) <- "
For an unordered factor, the top most level is set
as the reference level.Clicking this button will
move the selected level to the top.
"
}
addSpring(cur_child)
addHandler(rename_level, "key-press-event", handler=function(h, w, e, ...) {
if(e$GetKeyval() != GDK_Return) {
return(FALSE)
}
ind <- svalue(cur_levels, index=TRUE)
new_name <- svalue(h$obj)
## adjust old
tmp <- old
levels(tmp)[ind] <- new_name
old <<- tmp
## adjust GUI
blockHandler(rename_level)
tmp <- cur_levels[]
tmp[ind] <- new_name
cur_levels[] <- tmp
svalue(cur_levels, index=TRUE) <- ind
svalue(rename_level) <- ""
unblockHandler(rename_level)
focus(cur_levels) <- TRUE
return(TRUE)
})
}
more_than_one_selected <- function() {
delete(rg, cur_child)
cur_child <<- gvbox(container=rg, expand=TRUE)
glabel("Collapse selected levels to:", container=cur_child, anchor=c(-1,0))
collapse_levels <- gedit("", intial.msg="Collapse levels to...",
container=cur_child)
addSpring(cur_child)
addHandlerChanged(collapse_levels, handler=function(h,...) {
ind <- svalue(cur_levels, index=TRUE)
new_val <- svalue(collapse_levels)
if (length(ind) < 2)
return()
## adjust old
tmp <- old
levels(tmp)[ind] <- new_val
old <<- tmp
## adjust GUI
blockHandler(cur_levels);
tmp <- cur_levels[]
tmp[ind] <- new_val
tmp <- tmp[-sort(ind)[-1]]
cur_levels[] <- tmp
unblockHandler(cur_levels)
svalue(cur_levels, index=TRUE) <- sort(ind)[1]
})
}
##
selection_changed <- function(...) {
ind <- svalue(cur_levels, index=TRUE)
if(length(ind) == 0)
none_selected()
else if(length(ind) == 1)
one_selected()
else
more_than_one_selected()
}
addHandlerSelectionChanged(cur_levels, handler=function(h,...) {
blockHandler(cur_levels)
on.exit(unblockHandler(cur_levels))
selection_changed()
})
addHandlerChanged(is_ordered, handler=function(h, ...) {
## adjust factor
old <<- factor(old, ordered=svalue(h$obj))
## adjust GUI
ind <- svalue(cur_levels, index=TRUE)
if (length(ind)==0 || ind < 1)
ind <- 1
svalue(cur_levels, index=TRUE) <- ind
})
##
add_level_dialog <- function(parent) {
## add a level to current levels
dlg <- gbasicdialog(parent=parent, handler=function(...) {
new_val <- svalue(e)
tmp <- cur_levels[]
if(nchar(new_val) > 0 && !(new_val %in% tmp)) {
tmp <- c(tmp, new_val)
## adjust factor
xx <- old
levels(xx) <- tmp
old <<- xx
## add to GUI
blockHandler(cur_levels)
cur_levels[] <- tmp
unblockHandler(cur_levels)
svalue(cur_levels, index=TRUE) <- length(tmp)
}
})
g <- gvbox(cont=dlg)
glabel("Add a new level to factor ...", cont=g, anchor=c(-1,0))
e <- gedit("", container=g)
visible(dlg, TRUE)
}
},
get_value = function() {
"Return factor with new levels"
old
}
))
jverzani/gWidgets2RGtk2 documentation built on May 27, 2022, 11:25 p.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 make_editable_cell_renderer.Date make_editable_cell_renderer.logical make_editable_cell_renderer.factor make_editable_cell_renderer.default make_editable_cell_renderer add_editable_cell_renderer my_date my_logical ensure_type.logical ensure_type.integer ensure_type.numeric ensure_type.factor ensure_type.character ensure_type.default ensure_type .gdf.guiWidgetsToolkitRGtk2
Documented in add_editable_cell_renderer ensure_type .gdf.guiWidgetsToolkitRGtk2
##' @include GWidget.R
##' @include gmenu.R
##' @include dialogs.R
##' @include gtable.R
NULL
## TODO
## * handlers
## * column drag and drop
## * size override for passing in column sizes through a list.
##' Toolkit constructor
##'
##' @export
##' @rdname gWidgets2RGtk2-undocumented
##' @method .gdf guiWidgetsToolkitRGtk2
## @export .gdf guiWidgetsToolkitRGtk2
.gdf.guiWidgetsToolkitRGtk2 <- function(toolkit,
items = NULL,
handler = NULL,action = NULL, container = NULL, ... ) {
GDf$new(toolkit,
items=items,
handler = handler, action = action, container = container, ...)
}
##' S3 generic to ensure we don't change data type when assigning into column
##'
##' @param x column values
##' @param value new value
##' @return coerced new value
ensure_type <- function(x, value) UseMethod("ensure_type")
ensure_type.default <- function(x, value) value
ensure_type.character <- function(x, value) as.character(value)
ensure_type.factor <- function(x, value) {x[length(x) + 1] <- value; utils::tail(x, n=1)}
ensure_type.numeric <- function(x, value) as.numeric(value)
ensure_type.integer <- function(x, value) as.integer(value)
ensure_type.logical <- function(x, value) as.logical(value)
my_logical <- function(x) {
y <- as.character(x)
y[is.na(y)] <- "NA"
y <- factor(y)
class(y) <- c("mylogical", "factor")
y
}
my_date <- function(x) {
y <- format(x)
y[is.na(y)] <- "NA"
class(y) <- c("mydate", "character")
y
}
##' make a view column for the given type of variable
##'
##' @param x variable
##' @param self reference to ModelView object
##' @param model_idx 1-based index in model of data to represent
##' @param view_col optional view column to reuse
##' @return a gtkTreeViewColumn with data "n", and "id" to block editable id
add_editable_cell_renderer <- function(x, self, model_idx, view_col) {
## Make column, set editable
if(missing(view_col))
view_col <- gtkTreeViewColumnNew()
else
view_col$clear()
make_editable_cell_renderer(x, self, model_idx, view_col)
event_box <- gtkEventBox()
event_box$SetVisibleWindow(FALSE)
label <- gtkLabel()
event_box$add(label)
event_box$setAboveChild(TRUE) # gets events to box
view_col$setWidget(event_box)
view_col
}
## Make cell renderer for above. Dispatches on x
make_editable_cell_renderer <- function(x, self, model_idx, view_col) UseMethod("make_editable_cell_renderer")
make_editable_cell_renderer.default <- function(x, self, model_idx, view_col) {
cr <- gtkCellRendererText()
cr['editable'] <- TRUE
cr$setData("editable", "editable")
cr$setData("view_col", view_col) # no lookup otherwise
view_col$setResizable(TRUE)
view_col$packStart(cr, TRUE)
view_col$addAttribute(cr, "text", model_idx - 1L)
## make editable
id <- gSignalConnect(cr,
signal="edited",
f=function(cr, path, newtext) {
visible <- self$get_visible()
i <- which(visible)[as.numeric(path) + 1]
view_col <- cr$getData("view_col")
j <- self$get_column_index(view_col)
self$cmd_set_cell(i, j, newtext)
})
view_col$setData("n", model_idx) # map to model
view_col$setData("edit.id", id) # use this to disable editing
}
make_editable_cell_renderer.factor <- function(x, self, model_idx, view_col) {
cr <- gtkCellRendererCombo()
model <- rGtkDataFrame(levels(x))
cr['model'] <- model
cr['text-column'] <- 0
cr['editable'] <- TRUE
cr$setData("editable", "editable")
cr$setData("view_col", view_col) # no lookup otherwise
view_col$setResizable(TRUE)
view_col$packStart(cr, TRUE)
view_col$addAttribute(cr, "text", model_idx - 1L)
## make editable
id <- gSignalConnect(cr,
signal="edited",
f=function(combo, path, newdata) {
visible <- self$get_visible()
i <- which(visible)[as.numeric(path) + 1]
view_col <- cr$getData("view_col")
j <- self$get_column_index(view_col)
self$cmd_set_cell(i, j, newdata) # toggle
})
view_col$setData("n", model_idx) # map to model
view_col$setData("edit.id", id) # use this to disable editing
}
make_editable_cell_renderer.logical <- function(x, self, model_idx, view_col) {
cr <- gtkCellRendererToggle()
cr['activatable'] <- TRUE
cr$setData("editable", "activatable")
cr$setData("view_col", view_col) # no lookup otherwise
view_col$setResizable(TRUE)
view_col$packStart(cr, TRUE)
view_col$addAttribute(cr, "active", model_idx - 1L)
## make editable
id <- gSignalConnect(cr,
signal="toggled",
f=function(cr, path, data) {
visible <- self$get_visible()
i <- which(visible)[as.numeric(path) + 1]
view_col <- cr$getData("view_col")
j <- self$get_column_index(view_col)
self$cmd_set_cell(i, j, !self$get_cell(i, j)) # toggle
})
view_col$setData("n", model_idx) # map to model
view_col$setData("edit.id", id) # use this to disable editing
}
make_editable_cell_renderer.Date <- function(x, self, model_idx, view_col) {
cr <- gtkCellRendererText()
cr['editable'] <- TRUE
cr$setData("editable", "editable")
cr$setData("view_col", view_col) # no lookup otherwise
view_col$setResizable(TRUE)
view_col$packStart(cr, TRUE)
view_col$addAttribute(cr, "text", model_idx - 1L)
view_col$setCellDataFunc(cr, function(vc, cr, model, iter, ...) {
## set cell value by formatting
col <- self$get_column_index(cr$getData("view_col"))
row <- as.numeric(model$getPath(iter)$toString()) + 1L
val <- self$get_cell(row, col)
cr["text"] <- format(val)
})
## make editable
id <- gSignalConnect(cr,
signal="edited",
f=function(cr, path, newtext) {
visible <- self$get_visible()
i <- which(visible)[as.numeric(path) + 1]
view_col <- cr$getData("view_col")
j <- self$get_column_index(view_col)
## calls ensure_type to format
self$cmd_set_cell(i, j, newtext)
})
view_col$setData("n", model_idx) # map to model
view_col$setData("edit.id", id) # use this to disable editing
}
make_editable_cell_renderer.POSIXt <- make_editable_cell_renderer.Date
## This is a bit convoluted due to the command framework. To do
## something, say set a cell value we have 3 methods! One is a
## gWidgets methods (\code{set_items(i,j,value)}), this in turn calls
## a command with undo/redo support (\code{cmd_set_cell}), the
## command relies on the third method to actual set the cell value
## (\code{set_cell(i,j,value)}). To make matters worse, there is an
## issue defining one-off reference classes within a reference class
## when the \code{<<-} operator is involved. As such, we have a
## fourth place things may be defined -- in reference class
## definitions appearing after the one for \code{GDf}. Be warned,
## this is a maintenance issue.
GDfBase <- setRefClass("GDfBase",
contains="GWidget",
fields=list(
model="ANY",
store="ANY",
freeze_attributes="character", # one of FALSE, TRUE, "row", or "column"
cmd_stack="ANY",
cell_popup_id="ANY"
),
methods=list(
set_frame=function(items) {
"Change data frame, update view, clear out stack"
clear_stack()
clear_view_columns()
## if any row is all NA, then we set the class to numeric
for (nm in names(items)) {
if(all(is.na(items[nm]))) {
items[nm] <- rep(NA_real_, nrow(items))
}
}
## turn logical into factor -- must turn back
inds <- which(sapply(items, function(x) is(x, "logical")))
for (i in inds)
items[[i]] <- my_logical(items[[i]])
## turn date into character -- must turn back
inds <- which(sapply(items, function(x) is(x, "Date")))
for (i in inds)
items[[i]] <- my_date(items[[i]])
mod_items <- cbind(`_visible`=rep(TRUE, nrow(items)),
`_deleted`=rep(FALSE, nrow(items)),
`_rownames`=I(rownames(items)),
items)
model$setFrame(mod_items)
add_view_columns()
},
save_data=function(nm, where) {
assign(nm, get_frame(), where)
cmd_stack$clear()
},
##
## View column methods
##
get_view_column=function(j) {
"Return view column in column j (1-based). Use j=0 for rownames column"
widget$getColumns()[[j + 1L]] # skip rownams
},
clear_view_columns=function() {
"Clear out all view columns from view"
sapply(rev(widget$getColumns()), widget$removeColumn)
},
add_view_columns=function() {
"Add view columns to treeview widget"
DF <- as.data.frame(model)
## add row names column
view_col<- add_editable_cell_renderer(as.character(DF[[3]]), self=.self, model_idx=3)
cr <- view_col$getCellRenderers()[[1]]; cr['font'] <- "Bold"
widget$insertColumn(view_col, -1L)
## add remaining columns
sapply(seq_along(DF[,-(1:3), drop=FALSE]), function(i) {
view_col <- add_editable_cell_renderer(DF[[i + 3L]], self=.self, model_idx=i + 3L)
widget$insertColumn(view_col, -1L)
if(!freeze_attributes %in% c("TRUE", "column"))
add_popup_to_view_col(view_col)
})
## set names
set_names(names(DF)[-(1:3)]) # remove first 3!
},
##
## Get the data
##
get_frame=function() {
"Get data frame from columns. Skips deleted rows, but returns non-visible ones"
columns <- widget$getColumns()[-1] # drop rownames
cols <- sapply(columns, function(vc) vc$getData("n"))
out <- as.data.frame(model)
## must convert character to Date before subsetting.
inds <- which(sapply(out, function(x) is(x, "mylogical")))
for (i in inds)
out[[i]] <- as.logical(out[[i]])
## convert mydate to date
inds <- which(sapply(out, function(x) is(x, "mydate")))
for (i in inds)
out[[i]] <- as.Date(out[[i]])
out <- out[not_deleted(),cols, drop=FALSE]
names(out) <- get_names()
rownames(out) <- make.unique(get_rownames())
out
},
## DND
## XXX This needs fleshing out
add_dnd_columns=function() {
## Hack to add in drag and drop to columns
remove_popup_menu()
add_dnd_to_vc <- function(vc) {
vc$setClickable(TRUE)
btn <- vc$getWidget()$getParent()$getParent()$getParent()
label <- vc$getWidget()$getChild()
gtkDragSourceSet(btn,
start.button.mask=c("button1-mask", "button3-mask"),
targets=widgetTargetTypes[["text"]],
actions="copy")
gSignalConnect(btn, "drag-data-get", function(data, widget, contet, sel, ty, tm, ...) {
sel$setText(data$getLabel(), -1)
}, label, user.data.first=TRUE)
}
QT <- Map(add_dnd_to_vc, widget$getColumns())
},
##
## Column methods
##
add_column=function(x, nm) {
"Add column to end of model, create new view column, set name to nm"
n <- get_dim()[2]
if(missing(nm))
nm <- sprintf("X%s", n)
frame <- as.data.frame(model)
frame[not_deleted(),ncol(frame) + 1] <- x
model$setFrame(frame)
model_n <- dim(model)[2]
view_col <- add_editable_cell_renderer(x, .self, model_n)
widget$insertColumn(view_col, -1)
add_popup_to_view_col(view_col)
j <- get_column_index(view_col)
set_name(j, nm)
model_n # return
},
insert_column=function(j, model_idx, nm) {
"Insert column j with model number model_idx and name name"
DF <- as.data.frame(model)
view_col <- add_editable_cell_renderer(DF[[model_idx]], .self, model_idx)
view_col$getWidget()$getChild()$setLabel(nm)
widget$insertColumn(view_col, j)
add_popup_to_view_col(view_col)
},
remove_column=function(j) {
"Remove column from view. Keeps data in model. Returns name and index in model to undo"
column <- get_view_column(j)
old_nm <- get_name(j)
model_idx <- column$getData("n") # model_idx is 1-based
widget$removeColumn(column)
invoke_change_handler()
## return info to reconstruct
invisible(list(nm=old_nm, model_idx=model_idx ))
},
move_column=function(from ,to) {
"Move a view column from j to i, shift others over. Does not effect model."
columns <- widget$getColumns()[] # includes rownames as 1, so no shift over
from_col <- columns[[from + 1L]]
to_col <- columns[[to]]
widget$moveColumnAfter(from_col, to_col)
},
hide_column=function(j, value) {
"Hide column j (view coordinates). Hiding column j does not remove it and j still refers to this column. That is view coordinates are different from what is in GUI"
column <- get_view_column(j)
column$setVisible(!as.logical(value))
invisible(!value)
},
unhide_column=function(j) {
column <- get_view_column(j)
column$setVisible(TRUE)
},
is_editable=function(j) {
column <- get_view_column(j)
cr <- column$getCellRenderers()[[1]]
cr[cr$getData("editable")]
},
block_editable_column=function(j) {
"Block that column j can be edited"
column <- get_view_column(j)
cr <- column$getCellRenderers()[[1]]
cr[cr$getData("editable")] <- FALSE
},
unblock_editable_column=function(j) {
"unblock that column j can be edited"
column <- get_view_column(j)
cr <- column$getCellRenderers()[[1]]
cr[cr$getData("editable")] <- TRUE
},
##
## Row methods
##
hide_row=function(i,value=TRUE) {
"Hide row i, i refers to non-deleted rows. value if TRUE to hide, FALSE to unhide"
i <- map_i(i)
model[i,1] <<- !as.logical(value)
invisible(!value) # return opposite for command framework
},
remove_row=function(i, value, model_index=FALSE) {
"Delete row"
## we don't actually delete, we just make not visible and deleted.
if(!model_index)
i <- map_i(i)
model[i,1] <<- !as.logical(value)
model[i,2] <<- as.logical(value)
invisible(i)
},
unremove_row=function(model_i) {
"Un delete row model_i."
model[model_i,1] <<- TRUE # show it
model[model_i,2] <<- FALSE
},
insert_row=function(i, value) {
"Insert new row after position i, i=0:nrow"
## we insert row into model. How depends on what i is.
DF <- as.data.frame(model)
if(i == 0) {
## first
new_DF <- DF[c(1, seq_len(nrow(DF))), ]
new_i <- 1
} else if(i >= get_dim()[1]) {
i <- get_dim()[1] # in case bigger
## end
new_DF <- DF[c(seq_len(nrow(DF)), 1), ]
new_i <- nrow(new_DF)
} else {
## middle
ii <- map_i(i)
new_DF <- DF[c(1:ii, 1, (ii+1):nrow(DF)), ]
new_i <- ii + 1
}
## clear
n <- ncol(new_DF)
new_DF[new_i,] <- lapply(1:n, function(i) NA)
new_DF[new_i, 1:3] <- list(TRUE, FALSE, "")
if(!missing(value)) {
ind <- sapply(widget$getColumns()[-1], function(vc) vc$getData("n"))
new_DF[new_i, ind] <- value
}
model$setFrame(new_DF)
return(new_i) # new column in model coordinates
},
## names
set_view_column_name=function(column, value) {
j <- get_column_index(column)
old_nm <- get_name(j)
column$getWidget()$getChild()$setLabel(value)
return(old_nm)
},
set_name = function(j, value) {
"Set view column's name"
old_nm <- get_name(j)
column <- get_view_column(j)
column$getWidget()$getChild()$setLabel(value)
invoke_change_handler()
return(old_nm)
},
get_name=function(j) {
column <- get_view_column(j)
column$getWidget()$getChild()$getLabel()
},
hide_names=function(value) {
"Toggle display of names by logical values"
widget$setHeadersVisible(as.logical(value))
},
set_row_name=function(i, value) {
i <- map_i(i)
old_value <- model[i, 3L]
model[i, 3L] <<- value
invisible(old_value)
},
hide_row_names=function(value) {
"Toggle display of row names by logical value"
hide_column(0, value)
},
##
## mappings between view columns and model
##
get_column_index=function(view_col) {
"Get view column index from view column"
columns <- widget$getColumns()[-1] # no reownames
Filter(function(i) identical(columns[[i]], view_col), seq_along(columns))
},
map_j=function(j) {
"get column in model from j"
column <- get_view_column(j) # skip rownames
n <- column$getData("n") # 0-based
n
},
not_deleted=function() {
"Return indices of non deleted model rows"
which(!model[,2L])
},
map_i=function(i) {
"Return model index from i (possibl sorted, removed, ...)"
## i is in order, but we skip over deleted -- but not filtered
not_deleted()[i]
},
##
## Values by cell, column
##
get_cell=function(i,j) {
"Get value in cell i,j using view coordinates"
model[map_i(i), map_j(j)]
},
set_cell=function(i, j, value) {
"set cell, i, j in view coordinates (including hidden). Return old_value"
n <- map_j(j)
old_value <- model[map_i(i), n]
model[map_i(i), n] <<- ensure_type(model[,n], value)
old_value
},
get_column_value=function(j) {
"Get data in model for jth column in view coordinates"
model[not_deleted(), map_j(j)]
},
##
## Selection methods. From gtable
##
get_selected=function() {
"Get selected indices or numeric(0)"
sel_model <- widget$getSelection()
x <- sapply(sel_model$getSelectedRows()$retval, gtkTreePathToString)
if(is.null(x))
x <- integer(0)
else
x <- as.numeric(x) + 1L
seq_len(nrow(model))[model[,1]][x] # not deleted
},
set_selected=function(ind) {
"Set selected rows by index"
old_ind <- get_selected()
ind <- seq_len(nrow(model))[!model[,2]][ind]
sel_model = widget$getSelection()
block_handlers()
sel_model$unselectAll()
lapply(ind, function(i) {
sel_model$selectPath(gtkTreePathNewFromString(i-1))
})
unblock_handlers()
},
set_selectmode=function(mode=c("none", "single", "browse", "multiple")) {
sel = widget$getSelection()
sel$setMode(match.arg(mode))
},
##
## Popup menu methods. From gtable (should be a subclass)
##
default_popup_menu=function(view_col) {
"Provide default popup menu (passed to gmenu(..., popup=TRUE))"
j <- get_column_index(view_col)
x <- get_column_value(j)
nm <- get_name(j)
## intercept row names
types <- c("other", "character", "factor", "numeric", "logical")
tmp <- function(x) UseMethod("tmp")
tmp.default <- function(x) ""
tmp.numeric <- function(x) "numeric"
tmp.factor <- function(x) "factor"
tmp.character <- function(x) "character"
tmp.logical <- function(x) "logical"
actions <- list(
gaction("Rename column", handler=function(h,...) {
out <- ginput(gettext("New column names:"), nm, title=gettext("Rename column"), parent=.self)
if(nchar(out))
cmd_set_column_name(j, out)
}),
gseparator(),
gaction("Insert column...", handler=function(h,...) {
## need x, nm
x <- character(get_dim()[1])
nm <- "Replace me"
cmd_insert_column(x, nm, j)
}),
gaction("Delete column", handler=function(h,...) {
cmd_remove_column(j)
}),
## gaction("Hide column", handler=function(h,...) {
## cmd_hide_column(j)
## }),
gseparator(),
## Coerce class of object
gradio(types, selected=getWithDefault(match(tmp(x), types), 1L), handler=function(h,...) {
ind <- svalue(h$obj, index=TRUE)
if(ind > 1)
cmd_coerce_column(j, get(sprintf("as.%s", types[ind])))
}),
gseparator(),
gaction("Edit factor levels...", handler=function(h, ...) {
collapseFactor <- function(f, parent = NULL) {
out <- character()
w <- gbasicdialog("Edit factor levels", parent = parent,
handler = function(h,...) {
new_f <- relf$get_value()
if(!is.factor(new_f))
new_f <- factor(new_f)
assign("out", new_f, inherits=TRUE)
})
size(w) <- c(600, 400)
g <- ggroup(cont = w)
relf <- CollapseFactor$new(f, cont = g)
visible(w, set = TRUE)
out
}
out <- collapseFactor(x)
if(length(out)) {
cmd_replace_column(out, j)
}
}),
gseparator(),
gcheckbox("Editable", checked=is_editable(j), handler=function(h,...) {
if(svalue(h$obj))
unblock_editable_column(j)
else
block_editable_column(j)
}),
gseparator(),
gaction("Apply function ...", handler=function(h,...) {
w <- gbasicdialog(gettext("Apply a function to values in the column"), parent=.self, handler=function(h,...) {
val <- svalue(txt)
new_x <- eval(parse(text=val), envir=list(x=x))
if(is.vector(new_x))
cmd_insert_column(new_x)
else
galert(gettext("Expression did not return a vector"), parent=.self)
})
txt <- gtext("sapply(x, function(i) {\n\n})", cont=w)
visible(w, TRUE)
})
)
enabled(actions[[8]]) <- is.factor(x)
actions
},
add_popup_menu=function(menulist) {
f <- function(...) menulist
add_popup(f)
},
add_popup=function(menu_fun=NULL) {
"Add a popup menu to the columns. Function should generate list of actions, ..."
sapply(widget$getColumns()[-1], function(view.col) {
add_popup_to_view_col(view.col, menu_fun)
})
},
add_popup_to_view_col=function(view.col, menu_fun) {
if(freeze_attributes %in% c("TRUE", "column")) {
return() # no popup menu if frozen
}
if(missing(menu_fun))
menu_fun <- .self$default_popup_menu
view.col$setClickable(TRUE)
event_box <- view.col$getWidget()
btn <- event_box$getParent()$getParent()$getParent()
id <- gSignalConnect(btn, "button-press-event", f=function(w, e, data, ...) {
if(isRightMouseClick(e)) {
popup <- gmenu(menu_fun(data), popup=TRUE, toolkit=toolkit)
## This is a *real* hack, as the following doesn't
## work when I use event_box. NOt sure why
## not, seems like the right combination of
## arguments is given
popup$widget$popup(button=e$button, activate.time=e$time)
}
FALSE
}, data=view.col)
btn$setData("popup_id", id)
},
remove_popup_menu=function() {
"remove popup menu from column headers"
sapply(widget$getColumns(), function(view.col) {
view.col$setClickable(FALSE)
btn <- view.col$getWidget()$getParent()$getParent()$getParent()
if(!is.null(id <- btn$getData("popup_id")))
gSignalHandlerDisconnect(btn, id)
})
},
default_cell_popup_menu=function() {
## returns a function of i,j which produces actions for a popup menu
## j=0 when rownames column
f <- function(self, i, j) {
if(j == 0) {
## rownames popup
actions <- list(
gaction("Insert row", handler=function(...) {
self$cmd_insert_row(i)
}),
gaction("Delete row", handler=function(...) {
self$cmd_remove_row(i)
})#,
## gaction("Hide row", handler=function(...) {
## self$cmd_hide_row(i)
## })
)
} else {
## No idea what to put here...
actions <- list(
gaction("cell popup")
)
}
}
return(f)
},
add_cell_popup=function(menu_fun) {
"Add cell popup, pass in function to produce menu or uses default"
if(missing(menu_fun))
menu_fun <- default_cell_popup_menu()
id <- gSignalConnect(widget, "button-press-event", f=function(w, e, self) {
if(isRightMouseClick(e)) {
path <- w$getPathAtPos(e$x, e$y)
if(!path$retval) # no path
return(FALSE)
i <- visible <- self$get_visible()
i <- which(visible)[as.numeric(path$path$toString()) + 1]
j <- self$get_column_index(path$column)
if(length(j) == 0) j <- 0
## Can have popup on cells, but right now don't know what to put there
if(j == 0) {
popup <- gmenu(menu_fun(self, i, j), popup=TRUE, toolkit=toolkit)
popup$widget$popup(button=e$button, activate.time=e$time)
}
}
FALSE
}, data=.self)
cell_popup_id <<- id
},
remove_cell_popup=function() {
"Remove cell popup"
gSignalHandlerDisconnect(widget, cell_popup_id)
},
##
## Main GWidget interface. Need gWidgets (svalue) and matrix interface
##
get_dim=function() {
"size of displayed data"
ncols <- length(widget$getColumns()) - 1L # no rownames
nrows <- length(model[not_deleted(),1])
c(rows=nrows, cols=ncols)
},
get_length=function() {
get_dim()[2]
},
get_value=function(drop=TRUE, ...) {
ind <- get_selected()
if(length(ind) == 0)
return(NULL) # ?? what is right?
DF <- get_frame()
if(drop)
DF[ind, 1]
else
DF[ind,]
},
set_value=function(value, ...) {
},
get_index=function(...) {
get_selected()
},
set_index=function(value, ...) {
set_selected(value)
},
get_items=function(i,j, ...,drop=TRUE) {
x <- get_frame()
x[i,j, ..., drop=drop]
},
set_items=function(value, i, j, ...) {
"Replace part of data: whole thing, by column, by cell. By row?"
### XXX Need checks on i,j bounds not exceeding. Need to call insert_column, insert_row otherwise
if(missing(i) && missing(j)) {
if(!is.data.frame(value))
value <- data.frame(value, stringsAsFactors=FALSE)
set_frame(value)
} else if(missing(i)) {
## replace column by column
if(is.vector(value))
cmds <- list(cmd_replace_column(value, j))
else
cmds <- lapply(seq_along(j), function(i) cmd_replace_column(value[i], j[i], add=FALSE))
cmd_stack$add(gWidgets2:::CommandList$new(lst=cmds))
} else if(missing(j)) {
## XXX need to add this row by row!
value <- as.data.frame(value)
sapply(seq_along(value), function(col) .self$set_items(value[,row], i, col))
} else {
if(length(i) == 1) {
value <- rep(value, length=length(j)) # recyle
cmd_list <- lapply(seq_along(j), function(jj) cmd_set_cell(i, j[jj], value[jj], add=FALSE))
} else if(length(j) == 1) {
value <- rep(value, length=length(i)) # recyle
cmd_list <- lapply(seq_along(i), function(ii) cmd_set_cell(i[ii], j, value[ii], add=FALSE)) } else {
## no recycling
if(length(i) != nrow(value) || length(j) != ncol(value))
stop(gettext("value is not of correct dimensions for indices"))
cmd_list <- lapply(seq_len(length(i) * length(j)), function(x) NULL)
ctr <- 1
for(ii in seq_along(i))
for(jj in seq_along(j)) {
cmd_list[[ctr]] <- cmd_set_cell(i[ii], j[jj], value[i[ii], j[jj]], add=FALSE)
ctr <- ctr + 1
}
}
cmd_stack$add(gWidgets2:::CommandList$new(lst=cmd_list))
}
},
get_names=function() {
sapply(widget$getColumns()[-1], function(vc) vc$getWidget()$getChild()$getLabel())
},
set_names=function(value) {
"Set the names of each column"
## modify when using widget, not default
#f <- function(vc, nm) vc$getWidget()$getChild()$setLabel(nm)
#mapply(f, widget$getColumns()[-1], value)
cmd_set_column_names(value)
},
get_rownames=function() {
model[not_deleted(), 3] # fixed
},
set_rownames=function(value) {
if(length(value) != length(not_deleted()))
return() # wrong length
old_names <- get_rownames()
model[not_deleted(),3] <<- value
invisible(old_names)
},
get_dimnames=function() {
list(rownames=get_rownames(), colnames=get_names())
},
set_dimnames=function(value) {
XXX()
},
get_visible=function() {
"Return which rows are visible"
model[not_deleted(),1L]
},
set_visible=function(value) {
## don't update
block_handlers()
if(length(value) == length(not_deleted()))
model[not_deleted(), 1L] <<- as.logical(value)
unblock_handlers()
},
get_editable=function(j) {
is_editable(j)
},
set_editable=function(value, j, ...) {
"Make a column editable or not."
if(value)
unblock_editable_column(j)
else
block_editable_column(j)
},
##
## Handler code
##
handler_widget=function() {
## for add_handler_changed
model
},
add_handler_clicked=function(handler, action=NULL, ...) {
## put this on tree view, we used handler_widget for the model
signal <- "button-press-event"
if(is_handler(handler)) {
o <- gWidgets2:::observer(.self, event_decorator(handler), action)
invisible(add_observer(o, signal))
gSignalConnect(widget, signal, function(...) {
.self$notify_observers(signal=signal, ...)
})
connected_signals[[signal]] <<- TRUE
}
},
add_handler_column_clicked=function(handler, action=NULL, ...) {
XXX()
},
add_handler_column_double_click=function(handler, action=NULL, ...) {
XXX()
},
add_handler_column_right_click=function(handler, action=NULL, ...) {
XXX()
},
##
## Command infrastructure
##
clear_stack=function() cmd_stack$clear(),
can_undo=function() cmd_stack$can_undo(),
can_redo=function() cmd_stack$can_do(),
undo=function() cmd_stack$undo(),
redo=function() cmd_stack$redo(),
##
## Commands with undo support
##
cmd_set_cell=function(i, j, value, add=TRUE) {
"Set cell i,j (in view indices) to value"
if(length(j)) {
cmd <- gWidgets2:::Command$new(receiver=.self, meth="set_cell",i=i, j=j, value=value)
} else {
## setting row name
cmd <- gWidgets2:::Command$new(receiver=.self, meth="set_row_name",i=i, value=value)
}
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
## Column commands.
cmd_insert_column=function(x, nm, j, add=TRUE) {
"Insert values from x into j"
if(missing(nm))
nm <- gettext("Replace me")
if(missing(j))
j <- get_dim()[2]
cmd <- InsertColumn$new(.self, meth="", x=x, nm=nm, j=j)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_replace_column=function(x, j, add=TRUE) {
"Replace values in column j with x"
cmd <- ReplaceColumn$new(.self, meth="", x=x, j=j)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_remove_column=function(j, add=TRUE) {
"remove column j"
cmd <- RemoveColumn$new(.self, meth="", j=j)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_hide_column=function(j, add=TRUE) {
"hide column j"
## do command
cmd <- gWidgets2:::Command$new(receiver=.self, meth="hide_column", j=j, value=TRUE)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_unhide_column=function(j, add=TRUE) {
"Show hidden column j"
## do command
cmd <- setRefClass("UnhideColumn",
contains="Command",
methods=list(
do=function() receiver$unhide_column(params$col),
undo=function() receiver$hide_column(params$col)
))$new(.self, meth="", col=j)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_coerce_column=function(j, coerce_with, add=TRUE) {
"Coerce column using coerce_with function, e.g. as.integer or as.character"
x <- get_column_value(j)
x <- coerce_with(x)
cmd <- ReplaceColumn$new(.self, meth="", j=j, x=x)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_set_column_name=function(j, nm, add=TRUE) {
cmd <- gWidgets2:::Command$new(receiver=.self, meth="set_name", j=j, value=nm)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_set_column_names=function(value, add=TRUE) {
if(length(value) != get_dim()[2])
stop(gettext("Wrong length names"))
cmds <- lapply(seq_along(value), function(j) cmd_set_column_name(j, value[j], add=FALSE))
cmdlist <- gWidgets2:::CommandList$new(lst=cmds)
if(add)
cmd_stack$add(cmdlist)
invisible(cmdlist)
},
## row commands
cmd_insert_row=function(i, nm, add=TRUE) {
if(missing(nm))
nm <- ""
cmd <- InsertRow$new(.self, meth="", i=i, nm=nm)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_remove_row=function(i, add=TRUE) {
cmd <- RemoveRow$new(.self, meth="", i=i)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_hide_row=function(i, add=TRUE) {
cmd <- gWidgets2:::Command$new(.self, meth="hide_row", i=i, value=TRUE)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
},
cmd_unhide_row=function(i, add=TRUE) {
cmd <- gWidgets2:::Command$new(.self, meth="hide_row", i=i, value=FALSE)
if(add)
cmd_stack$add(cmd)
invisible(cmd)
}
))
##' For \code{RGtk2}, a GDf object has several methods defined for it
##' that are toolkit specific, but may be useful. For example, the
##' columns may be made editable or non editable
##' (\code{block_editable_column} and \code{unblock_editable_column})
##' (accessed through \code{editable<-}); the headers can be
##' hidden/shown through the method \code{hide_names(boolean)}; the
##' rownames can be hidden/shown through themethod
##' \code{hide_row_names(boolean)}; the popup menus for the headers
##' can be removed (\code{remove_popup_menu}) and customized
##' (\code{add_popup}); similarly the cell popup can be
##' (\code{remove_cell_popup} and \code{add_cell_popup}).
##'
##' Passing in a value \code{freeze_attributes = TRUE} will make it so
##' there are no menu items to resize frame, change variable types,
##' relabel factors, .... Values of \code{"row"} or \code{"column"}
##' will remove popup menus just for the row or columns.
##'
##' @rdname gWidgets2RGtk2-package
GDf <- setRefClass("GDf",
contains="GDfBase",
methods=list(
initialize=function(toolkit, items, name=deparse(substitute(df)),
handler=NULL, action=NULL,
container=NULL,
...) {
model <<- rGtkDataFrame()
store <<- model$filter()
store$setVisibleColumn(0L)
widget <<- gtkTreeView()
widget$setModel(store)
## make pretty XXX shade, ...
widget$setRulesHint(TRUE)
widget$setGridLines(GtkTreeViewGridLines['both'])
## block is scrolled window
block <<- gtkScrolledWindow()
block$setPolicy("GTK_POLICY_AUTOMATIC","GTK_POLICY_AUTOMATIC")
block$add(widget)
## command stack
cmd_stack <<- gWidgets2:::CommandStack$new()
## initialize fields
initFields(default_expand=TRUE,
default_fill=TRUE,
change_signal="row-changed",
freeze_attributes = as.character(getWithDefault(list(...)$freeze_attributes, FALSE))
)
if(!is.data.frame(items))
items <- data.frame(items, stringsAsFactors=FALSE)
set_frame(items)
## adjust if we should freeze attributes
if(freeze_attributes %in% c("TRUE", "row")) {
set_editable(FALSE, 0) # don't edit row names
}
if(!freeze_attributes %in% c("TRUE", "row")) {
## menus only good once realized
gSignalConnect(widget, "realize", f=function(...) .self$add_cell_popup())
}
add_to_parent(container, .self, ...)
##handler_id <<- add_handler_changed(handler, action)
callSuper(toolkit)
}
))
## Some commands defined as separate classes. Put here, not inline as
## Issue here with <<- within command
## These are not exported or documented.
ReplaceColumn <- setRefClass("ReplaceColumn",
contains="Command",
methods=list(
do=function() {
j <- params$j
params$old_n <<- receiver$map_j(j)
#
x <- params$x
params$nm <<- receiver$get_name(j)
receiver$add_column(x, params$nm)
params$new_n <<- receiver$get_dim()[2]
params$new_index <<- ncol(receiver$model) # new model index
receiver$remove_column(j)
receiver$move_column(params$new_n - 1L, j)
},
undo=function() {
DF <- as.data.frame(receiver$model)
n <- params$old_n
add_editable_cell_renderer(DF[[n]], self=receiver, model_idx=n, receiver$get_view_column(params$j))
receiver$set_name(params$j, params$nm)
},
redo=function() {
DF <- as.data.frame(receiver$model)
n <- params$new_index
add_editable_cell_renderer(DF[[n]], self=receiver, model_idx=n, receiver$get_view_column(params$j))
receiver$set_name(params$j, params$nm)
}
))
InsertColumn <- setRefClass("InsertColumn",
contains="Command",
methods=list(
do=function() {
n <- receiver$add_column(params$x, params$nm)
params$model_idx <<- n
receiver$move_column(receiver$get_dim()[2], params$j + 1) # to right
},
undo=function() {
receiver$remove_column(params$j + 1)
},
redo=function() {
## adds another column, not sure why
receiver$insert_column(params$j + 1, params$model_idx, params$nm)
}
))
RemoveColumn <- setRefClass("RemoveColumn",
contains="Command",
fields=list(
"model_idx"="numeric"
),
methods=list(
do=function() {
out <- receiver$remove_column(params$j) ## nm, model_idx
params$nm <<- out$nm; params$model_idx <<- out$model_idx
},
undo=function() {
receiver$insert_column(params$j, params$model_idx, params$nm)
},
redo=function() do()
))
InsertRow <- setRefClass("InsertRow",
contains="Command",
fields=list(
row_num="ANY"
),
methods=list(
do=function() {
row_num <<- receiver$insert_row(params$i)
receiver$set_row_name(row_num, params$nm)
},
undo=function() {
receiver$remove_row(row_num, TRUE, model_index=TRUE)
},
redo=function() {
receiver$unremove_row(row_num)
}
))
RemoveRow <- setRefClass("RemoveRow",
contains="Command",
fields=list(
model_index="ANY"
),
methods=list(
do=function() {
model_index <<- receiver$map_i(params$i)
receiver$remove_row(model_index, TRUE, model_index=TRUE)
},
undo=function() {
receiver$unremove_row(model_index)
},
redo=function() do()
))
## ### Factor editor
## CollapseFactor <- setRefClass("CollapseFactor",
## fields = list(
## old = "ANY",
## widget = "ANY"
## ),
## methods = list(
## initialize = function(fac, cont = gwindow(), ...) {
## old <<- as.character(fac)
## make_gui(cont)
## callSuper()
## },
## make_gui = function(cont) {
## group <- gpanedgroup(cont = cont)
## levs <- sort(unique(as.character(old)))
## DF <- data.frame(original = levs,
## new = levs, stringsAsFactors = FALSE)
## #
## widget <<- tbl <- gtable(DF, cont = group, multiple = TRUE)
## size(tbl) <- c(300, 200)
## #
## nested_group <- ggroup(cont = group, horizontal = FALSE)
## instructions <- gettext(paste(
## "Select a one or more levels.",
## "Enter a new label in the text box.",
## "If there is one level selected, it will be renamed.",
## "If more, they will be collapsed and renamed.",
## sep="\n"))
## #
## glabel(instructions, cont = nested_group)
## # factor_edit <- gcombobox(levs, selected = 0, editable = TRUE,
## # cont = nested_group)
## factor_edit <- gedit("", cont=nested_group)
## # factor_edit[] <- levs
## enabled(factor_edit) <- FALSE
## #
## addHandlerSelectionChanged(widget, function(h,...) {
## ind <- svalue(widget, index = TRUE)
## enabled(factor_edit) <- (length(ind) > 0)
## if (length(ind) > 0) {
## blockHandler(factor_edit)
## svalue(factor_edit) <- svalue(widget)
## unblockHandler(factor_edit)
## }
## })
## ##
## factor_edit_change_handler = function(h,...) {
## ind <- svalue(tbl, index = TRUE)
## if(length(ind) == 0 || ind == 0L) {
## return()
## }
## #
## tbl[ind,2] <- svalue(factor_edit)
## # svalue(tbl, index = TRUE) <- 0
## blockHandler(factor_edit)
## # factor_edit[] <- sort(unique(tbl[,2]))
## # svalue(factor_edit) <- ""
## unblockHandler(factor_edit)
## }
## addHandlerChanged(factor_edit, handler=function(h,...) {
## blockHandler(factor_edit)
## factor_edit_change_handler(h,...)
## svalue(tbl, index=TRUE) <- 0
## focus(tbl) <- TRUE
## unblockHandler(factor_edit)
## })
## addHandlerKeystroke(factor_edit, handler =factor_edit_change_handler)
## addHandlerBlur(factor_edit, handler=function(h,...) {
## svalue(tbl, index = TRUE) <- 0
## svalue(h$obj) <- ""
## })
## },
## get_value = function() {
## "Return factor with new levels"
## old_levels <- widget[,1]
## new_levels <- widget[,2]
## new <- old
## for(i in seq_along(old_levels)) # one pass
## new[new == old_levels[i]] <- new_levels[i]
## factor(new)
## }
## ))
CollapseFactor <- setRefClass("CollapseFactor",
fields = list(
old = "ANY",
cur_reference_level="ANY",
widget = "ANY",
cur_child = "ANY"
),
methods = list(
initialize = function(fac, cont = gwindow(), ...) {
old <<- fac
cur_reference_level <<- levels(fac)[1]
make_gui(cont)
callSuper()
},
make_gui = function(cont) {
directions <- "
Adjust levels of a factor.
One can add a level through the 'Add' button.
Toggle if ordered with checkbox.
Select level to rename, make reference level, or
reorder, as appropriate.
Select levels to collapse.
"
## adjust these properties during dialog
g <- gpanedgroup(container=cont, expand=TRUE)
lg <- gvbox(container=g, fill="y")
rg <- ggroup(container=g, expand=TRUE, fill="both")
## fill left group with table
cur_levels <- gtable(levels(old), container=lg,
multiple=TRUE,
expand=TRUE, fill="y")
size(cur_levels) <- c(width=200, height=400)
names(cur_levels) <- "Levels"
cur_levels$remove_popup_menu()
bg <- ggroup(cont=lg)
add_level <- gbutton("add", cont=bg, handler=function(h,...) {
add_level_dialog(g)
})
tooltip(add_level) <- gettext("Add a new level to factor")
is_ordered <- gcheckbox("Ordered", container=bg, checked=is.ordered(old))
tooltip(is_ordered) <- gettext("Toggle if factor is ordered")
## Fill right group
cur_child <<- gvbox(container=rg, expand=TRUE)
glabel(directions, cont=cur_child, anchor=c(-1,0))
## adjust size after
addHandler(g, "map", function(...) {
svalue(g) <- 0.2
})
## show different things based on selection...
none_selected <- function() {
delete(rg, cur_child)
cur_child <<- gvbox(container=rg, expand=TRUE)
glabel("Directions...", cont=cur_child, anchor=c(-1, 0))
}
one_selected <- function() {
## if one_is selected
delete(rg, cur_child)
cur_child <<- gvbox(container=rg, expand=TRUE)
## offer to relabel
glabel(gettext("Relabel:"), container=cur_child, anchor=c(-1,0))
rename_level <- gedit(svalue(cur_levels),
container=cur_child)
gseparator(container=cur_child)
## give choice of making ordered, or adjusting order
if(svalue(is_ordered)) {
bg <- ggroup(cont=cur_child)
move_up <- gbutton("up", cont=bg, handler=function(h,...) {
ind <- svalue(cur_levels, ind=TRUE)
cur <- cur_levels[]
cur[c(ind-1,ind)] <- cur[c(ind, ind-1)]
## adjust factor
old <<- factor(old, levels=cur)
## adjust GUI
cur_levels[] <- cur
svalue(cur_levels) <- ind - 1
selection_changed()
})
move_down <- gbutton("down", cont=bg, handler=function(h,...) {
ind <- svalue(cur_levels, ind=TRUE)
cur <- cur_levels[]
cur[c(ind,ind + 1)] <- cur[c(ind+1, ind)]
## adjust factor
old <<- factor(old, levels=cur)
## adjust GUI
cur_levels[] <- cur
svalue(cur_levels) <- ind + 1
selection_changed()
})
tooltip(move_up) <- gettext("Move selected level up in the order")
tooltip(move_down) <- gettext("Move selected level down in the order")
cur_ind <- svalue(cur_levels, ind=TRUE)
nlevs <- length(cur_levels[])
enabled(move_up) <- cur_ind > 1
enabled(move_down) <- cur_ind < nlevs
} else {
## can make ordered *or* make reference level
bg <- ggroup(container=cur_child)
ref_button <- gbutton("Set as reference", cont=bg, handler=function(h,...) {
ind <- svalue(cur_levels, index=TRUE)
if (ind == 1) return()
cur_reference_level <<- svalue(cur_levels)
## adjust old
relevel(old, cur_reference_level)
## adjust GUI
blockHandler(cur_levels)
tmp <- cur_levels[]
tmp[c(1, ind)] <- tmp[c(ind, 1)]
cur_levels[] <- tmp
svalue(cur_levels, index=TRUE) <- 1
unblockHandler(cur_levels)
})
tooltip(ref_button) <- "
For an unordered factor, the top most level is set
as the reference level.Clicking this button will
move the selected level to the top.
"
}
addSpring(cur_child)
addHandler(rename_level, "key-press-event", handler=function(h, w, e, ...) {
if(e$GetKeyval() != GDK_Return) {
return(FALSE)
}
ind <- svalue(cur_levels, index=TRUE)
new_name <- svalue(h$obj)
## adjust old
tmp <- old
levels(tmp)[ind] <- new_name
old <<- tmp
## adjust GUI
blockHandler(rename_level)
tmp <- cur_levels[]
tmp[ind] <- new_name
cur_levels[] <- tmp
svalue(cur_levels, index=TRUE) <- ind
svalue(rename_level) <- ""
unblockHandler(rename_level)
focus(cur_levels) <- TRUE
return(TRUE)
})
}
more_than_one_selected <- function() {
delete(rg, cur_child)
cur_child <<- gvbox(container=rg, expand=TRUE)
glabel("Collapse selected levels to:", container=cur_child, anchor=c(-1,0))
collapse_levels <- gedit("", intial.msg="Collapse levels to...",
container=cur_child)
addSpring(cur_child)
addHandlerChanged(collapse_levels, handler=function(h,...) {
ind <- svalue(cur_levels, index=TRUE)
new_val <- svalue(collapse_levels)
if (length(ind) < 2)
return()
## adjust old
tmp <- old
levels(tmp)[ind] <- new_val
old <<- tmp
## adjust GUI
blockHandler(cur_levels);
tmp <- cur_levels[]
tmp[ind] <- new_val
tmp <- tmp[-sort(ind)[-1]]
cur_levels[] <- tmp
unblockHandler(cur_levels)
svalue(cur_levels, index=TRUE) <- sort(ind)[1]
})
}
##
selection_changed <- function(...) {
ind <- svalue(cur_levels, index=TRUE)
if(length(ind) == 0)
none_selected()
else if(length(ind) == 1)
one_selected()
else
more_than_one_selected()
}
addHandlerSelectionChanged(cur_levels, handler=function(h,...) {
blockHandler(cur_levels)
on.exit(unblockHandler(cur_levels))
selection_changed()
})
addHandlerChanged(is_ordered, handler=function(h, ...) {
## adjust factor
old <<- factor(old, ordered=svalue(h$obj))
## adjust GUI
ind <- svalue(cur_levels, index=TRUE)
if (length(ind)==0 || ind < 1)
ind <- 1
svalue(cur_levels, index=TRUE) <- ind
})
##
add_level_dialog <- function(parent) {
## add a level to current levels
dlg <- gbasicdialog(parent=parent, handler=function(...) {
new_val <- svalue(e)
tmp <- cur_levels[]
if(nchar(new_val) > 0 && !(new_val %in% tmp)) {
tmp <- c(tmp, new_val)
## adjust factor
xx <- old
levels(xx) <- tmp
old <<- xx
## add to GUI
blockHandler(cur_levels)
cur_levels[] <- tmp
unblockHandler(cur_levels)
svalue(cur_levels, index=TRUE) <- length(tmp)
}
})
g <- gvbox(cont=dlg)
glabel("Add a new level to factor ...", cont=g, anchor=c(-1,0))
e <- gedit("", container=g)
visible(dlg, TRUE)
}
},
get_value = function() {
"Return factor with new levels"
old
}
))
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.