Nothing
# Written by Tom Taverner <Thomas.Taverner@pnl.gov>
# for the U.S. Department of Energy (PNNL, Richland, WA, USA)
# Website: http://omics.pnl.gov/software
#
# Notice: This computer software was prepared by Battelle Memorial Institute,
# hereinafter the Contractor, under Contract No. DE-AC05-76RL0 1830 with the
# Department of Energy (DOE). All rights in the computer software are reserved
# by DOE on behalf of the United States Government and the Contractor as
# provided in the Contract.
#
# NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, EXPRESS OR
# IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE.
#
# This notice including this sentence must appear on any copies of this computer
# software.
#__Generic dialog maker__
#
#This set of functions is intended to assist rapid development of simple dialogs to
#serve as front ends to existing R functions. It is a riff off (or rip off) of John
#Verzani's traitr toolkit where flexibility is sacrificed for ease of use.
#
#To make a dialog, all that is required is to list the dialog items for each
#argument of the function. Then, the dialog is set for the function.
#
#Calling run.dialog() on the function will then open the dialog. When "OK" is
# pressed, the dialog will call the function with the specified arguments.
# Changed eval(parse to "safe.eval" to avoid malicious insertions of code
library(RGtk2)
library(gWidgetsRGtk2)
my.getwd <- function() gsub("(.*)/$", "\\1", getwd()) # for "C:/" we want to remove the end "/"
.ITEMS = c("choiceItem", "rangeItem", "fileItem", "integerItem", "radiobuttonItem", "objectItem",
"numericItem", "stringItem", "trueFalseItem", "variableSelectorItem", "listItem", "dataframeItem", "variableStringItem", "buttonItem")
.DATA_OBJECTS <- c("data.frame", "matrix")
# Utility function for choosing file with filters in platform independent way
my_choose_files <- function(fn ="*.*", multi=FALSE, filters=NULL, type = "open", caption=NULL){
captions <- list(open = "Select File", save= "Save File", selectdir = "Select Directory")
stopifnot(type%in%names(captions))
if(is.null(caption)) caption <- captions[[type]]
if(identical(.Platform$OS.type, "windows")){
if(identical(type, "selectdir")) {
f <- choose.dir(fn)
} else {
f <- choose.files(fn, multi = multi, filters=filters, caption=caption)
}
} else {
f <- gfile(fn, multi = multi, type = type)
}
return(f)
}
# This function binds its arguments together into a ragged column-wise array
ragged.cbind <- function(...){
items <- list(...)
if(length(items) == 1) items <- items[[1]]
for(item in items)
stopifnot(all(sapply(item, is.atomic)))
dd <- function(x){
if(!is.null(dim(x))) return(dim(x))
return(c(length(x), 1))
}
num.rows <- max(sapply(items, function(x) dd(x)[1]))
rv <- NULL
for(ii in 1:length(items)){
item <- items[[ii]]
tmp <- array(NA, c(num.rows, dd(item)[2]))
if(!is.null(dim(item))){
for(jj in 1:dd(item)[2]) tmp[1:dd(item)[1],jj] <- item[,jj]
colnames(tmp) <- colnames(item)
} else {
if(dd(item)[1] > 0)
tmp[1:dd(item)[1],] <- unlist(item)
colnames(tmp) <- names(items)[[ii]]
}
rv <- cbind(rv, tmp)
}
return(rv)
}
# exists("a$b$c")
object.exists <- function(text, envir=parent.env(environment())){
if(!nchar(text) || !is.character(text) || length(text) != 1) return(FALSE)
xx <- strsplit(text, "$", fixed=T)[[1]]
if(!nchar(xx) || !length(xx) || !exists(xx[1])) return(FALSE)
x1 <- get(xx[1], envir)
if(length(xx) > 1) for (item in xx[-1]) {
if(!item%in%names(x1)) return(FALSE)
x1 <- x1[[item]]
}
return(TRUE)
}
# Safely evaluates "a$b$c"
safe.eval <- function(text, envir=parent.env(environment())){
xx <- strsplit(text, "$", fixed=T)[[1]]
tryCatch({
x1 <- get(xx[1], envir)
if(length(xx) > 1) for (item in xx[-1]) x1 <- x1[[item]]
}, error= function(e) stop(paste("error in safe.eval:", as.character(e))))
return(x1)
}
get.value <- function(dlg.item, ...) {
#if(is.function(dlg.item$getData("get.value")))
dlg.item$getData("get.value")(dlg.item, ...)
}
get.name <- function(dlg.item) dlg.item$getData("name")
set.value <- function(dlg.item, ...){
if(is.function(dlg.item$getData("set.value")))
dlg.item$getData("set.value")(dlg.item, ...)
}
signal.connect <- function(obj, f, data=NULL, signal="default"){
signals <- obj$getData("signals")
if(is.null(signals)) signals <- list()
if(is.null(signals[[signal]])) signals[[signal]] <- list()
signals[[signal]][[length(signals[[signal]])+1]] <- list(f=f, data=data)
obj$setData("signals", signals)
}
get.signal <- function(dlg.item, signal="default")
dlg.item$getData("signals")[[signal]]
signal <- function(obj, signal="default"){
sapply(get.signal(obj, signal), function(x) {
do.call(x$f, as.list(c(obj, x$data)))
})
}
# Puts a frame around the item, if the item has attribute "suppress frame" it doesn't
myFrame <- function(item, label){
name <- item$getData("name")
suppress.frame <- !is.null(item$getData("suppress.frame"))
if(suppress.frame){
fram <- gtkHBoxNew()
fram$packStart(item, TRUE, TRUE, 5)
} else {
fram <- gtkFrameNew(label=label)
fram$setBorderWidth(2)
vbox <- gtkVBoxNew()
hbox <- gtkHBoxNew()
hbox$packStart(item, TRUE, TRUE, 5)
vbox$packStart(hbox, TRUE, TRUE, 5)
fram$add(vbox)
}
#fram$setData("item", item)
#fram$setData("name", name)
return(fram)
}
stringItem <- function(value, name="", multi=F, ...){
if(!multi){
item <- gtkEntryNew()
item$setText(value)
item$setData("name", name)
item$setData("get.value", gtkEntryGetText)
item$setData("set.value", function(item, value, ...) item$setText(value))
gSignalConnect(item, "activate", function(...) {
signal(item)
})
} else {
item <- gtkVBoxNew()
sw <- gtkScrolledWindowNew()
txt <- gtkTextViewNew()
sw$add(txt)
sw$setPolicy("automatic", "automatic")
buf <- txt$getBuffer()
item$add(sw)
item$setData("name", name)
item$setData("get.value", function(item)
buf$getText(buf$getStartIter()$iter, buf$getEndIter()$iter))
item$setData("set.value", function(item, value, ...) buf$setText(value))
item$setData("expand", TRUE) # expand in column
gSignalConnect(txt, "key-press-event", function(obj, evt) {
if(evt[["keyval"]] == GDK_Return && (as.flag(evt[["state"]] & GdkModifierType['control-mask'])))
signal(item)
return(FALSE)
})
}
return(item)
}
# This creates a widget that allows selection of multiple ranges of values.
# By Iago Conde
variableStringItem <- function(value, name="", show.arrows, ...){
hbox0 <- gtkHBoxNew(FALSE, 0)
button.add <- gtkButtonNewWithLabel(">>")
gSignalConnect(button.add, "clicked", function(...) signal(hbox0, "add"))
hbox0$packStart(button.add, FALSE, FALSE, 0)
ent <- gtkEntryNew()
ent$setText(value)
hbox0$packEnd(ent,TRUE,TRUE,0)
hbox0$setData("ent", ent)
hbox0$setData("get.value", function(hbox0,selected=FALSE){
texto <- hbox0$getData("ent")$getText()
return(texto)
})
hbox0$setData("name",name)
hbox0$setData("set.value", function(item, value, ...){
ent <- item$getData("ent")$getText()
new_string <- paste(value, collapse = "; ")
if(nchar(ent)) new_string <- paste(ent, new_string)
item$getData("ent")$setText(new_string)
})
return(hbox0)
}
choiceItem <- function(value=NULL, values=NULL, item.labels=NULL, name="", ...){
if(is.null(values)) values <- value
if("value"%in%names(value))
default.value <- value[["value"]]
else
default.value <- value[1]
value <- default.value
stopifnot(value%in%values)
if(is.null(item.labels)) item.labels <- values
stopifnot(length(item.labels) == length(values))
item <- gtkComboBoxNewText()
MAX_WIDTH = 150
sr <- item$getSizeRequest()
item$setSizeRequest(MAX_WIDTH, -1)
for (ll in item.labels) item$appendText(ll)
item$setData("values", values)
item$setData("labels", item.labels)
if(length(values)) item$setActive(which(values %in% value)-1)
changed.id <- gSignalConnect(item, "changed", function(...) {
signal(item)
})
# Emit the signal if the box is popped up, to refresh
#gSignalConnect(item, "popup", function(...) {
# signal(item)
#})
item$setData("changed.id", changed.id)
item$setData("name", name)
item$setData("get.value", function(x, selected=TRUE, ...){
item.labels <- item$getData("labels")
values <- item$getData("values")
if(selected){
stopifnot(length(item.labels) == length(values))
idx <- which(item.labels%in%x$getActiveText())
return(values[idx])
} else {
return(values)
}
})
item$setData("set.value", function(item, values, selected=NULL, ...){
old.values <- item$getData("values")
gSignalHandlerBlock(item, item$getData("changed.id"))
if(length(old.values) > 0)
for (ii in 1:length(old.values))
item$removeText(0)
item$setData("values", values)
item$setData("labels", values) # remove any labels
for (v in values) {
item$appendText(v)
sr <- item$getSizeRequest()
if(sr$width > MAX_WIDTH) item$setSizeRequest(MAX_WIDTH, -1)
}
if(is.null(selected) && length(values)) {
item$setActive(0)
} else if (!is.null(selected) && length(selected)==1 && selected%in%values){
item$setActive(which(values%in%selected)-1)
}
gSignalHandlerUnblock(item, item$getData("changed.id"))
})
return(item)
}
buttonItem <- function(value, name = "", ...){
item <- gtkHBoxNew()
button <- gtkButtonNewWithLabel(value)
item$packEnd(button, FALSE, FALSE, 0)
item$setData("name", name)
item$setData("value", NULL)
gSignalConnect(button, "clicked", function(...){
signal(item, "clicked")
})
item$setData("get.value", function(x) {
item$getData("value")
})
item$setData("set.value", function(item, value, ...){
item$setData("value", value)
})
item$setData("suppress.frame", TRUE)
return(item)
}
# Runs a dialog from a buttonItem given the list
dialog_button <- function(item, user.data){
rv <- run.dialog(list, dlg.list=user.data)$retval
if(!is.null(rv)) set.value(item, rv)
}
radiobuttonItem <- function(value=NULL, values=NULL,
item.labels=NULL, name="", by.index=NULL, ...){
if("value"%in%names(value))
default.value <- value[["value"]]
else
default.value <- value[1]
item <- gtkVBoxNew()
if(is.null(values)) values <- value
if(is.null(by.index)) by.index <- FALSE
value <- default.value
stopifnot(value%in%values)
if(is.null(item.labels))
item.labels <- values
stopifnot(length(item.labels) == length(values))
item$setData("values", values)
stopifnot(length(values) > 1)
the.choice <- which(values%in%value)
grb <- gtkRadioButtonNewWithLabel(NULL, label=item.labels[1])
if(the.choice == 1) grb$setActive(TRUE)
item$add(grb)
for(jj in 2:length(values)){
grb <- gtkRadioButtonNewWithLabel(group=grb$getGroup(),label=item.labels[jj])
if(jj == the.choice) grb$setActive(TRUE)
item$add(grb)
}
sapply(grb$getGroup(), function(x) gSignalConnect(x, "toggled", after=T, function(...) {
if(x$getActive()) signal(item)
}))
item$setData("name", name)
item$setData("grb", grb)
item$setData("get.value", function(x){
idx <- which(rev(sapply(x$getData("grb")$getGroup(), gtkToggleButtonGetActive)))
return(values[idx])
})
item$setData("set.value", function(x, value, ...){
values <- x$getData("values")
stopifnot(value%in%values || length(value) == 1)
grb <- rev(x$getData("grb")$getGroup())
idx <- which(values==value)
grb[[idx]]$setActive(TRUE)
})
return(item)
}
trueFalseItem <- function(value, name="", label = NULL, ...){
stopifnot(is.logical(value))
if(is.null(label)) label <- name
item <- gtkCheckButtonNewWithLabel(label=label)
item$setActive(value)
gSignalConnect(item, "toggled", after=T, function(item) {
signal(item, "default")
})
item$setData("name", name)
item$setData("suppress.frame", TRUE)
item$setData("get.value", gtkToggleButtonGetActive)
item$setData("set.value", function(item,value, ...){
item$setActive(value)
#signal(item, "default")
})
return(item)
}
numericItem <- function(value, name="", ...){
stopifnot(!is.na(as.numeric(value)))
item <- gtkEntryNew()
item$setText(value)
item$setData("name", name)
item$setData("get.value", function(x) {
as.numeric(x$getText())
})
item$setData("set.value", function(item, value, propagate=TRUE, ...) {
item$setText(value)
if(propagate) signal(item, "default")
})
return(item)
}
integerItem <- function(value, name="", from=-.Machine$integer.max, to=.Machine$integer.max, ...){
stopifnot(!is.na(as.integer(value)))
if("from"%in%names(value)) from <- value["from"]
if("to"%in%names(value)) to <- value["to"]
if("value"%in%names(value)) value <- value["value"]
item_adj <- gtkAdjustment(value=value, lower=from, upper=to, step.incr=1, page.incr=10)
item <- gtkSpinButton(item_adj, 1.0, 0)
item$setValue(value)
item$setData("name", name)
item$setData("get.value", function(x) {
x$getValue()
})
item$setData("set.value", function(item, value, propagate=TRUE, ...) {
item$setValue(value)
if(propagate) signal(item, "default")
})
return(item)
}
rangeItem <- function(value, name="", from=0, to=100, by=1, ...){
stopifnot(!is.na(as.numeric(value)))
if("from"%in%names(value)) from <- value["from"]
if("to"%in%names(value)) to <- value["to"]
if("by"%in%names(value)) by <- value["by"]
if("value"%in%names(value)) value <- value["value"]
item <- gtkHScaleNewWithRange(min=from, max=to, step=by)
if(length(value) > 1) value <- value[1]
item$setValue(value)
gSignalConnect(item, "value-changed", function(obj){
signal(item, "default")
return(value)
})
item$setData("name", name)
item$setData("get.value", function(x) {
x$getValue()
})
item$setData("set.value", function(item, value, propagate=TRUE, ...){
item$setValue(value)
if(propagate) signal(item, "default")
})
return(item)
}
fileItem <- function(value, name="", multi = FALSE, filters=NULL, extension = "*", type = "open", ...){
if(identical(.Platform$OS.type, "windows") && is.null(filters)) filters <- get("Filters", envir=.GlobalEnv)
stopifnot(type%in%c("open", "save", "selectdir"))
item <- gtkHBoxNew()
#label <- gtkLabelNew(value)
#label$setEllipsize(PangoEllipsizeMode['start'])
label <- gtkEntryNew()
label$setText(value)
label$setAlignment(0)
button <- gtkButtonNewWithLabel(paste(c("Select", ifelse(identical(type,"selectdir"), " Folder", " File"), ifelse(multi, "(s)", "")), collapse=""))
item$add(label)
item$packEnd(button, FALSE, FALSE, 0)
item$setData("label", label)
gSignalConnect(button, "clicked", data=label, function(obj, label){
#tryCatch({
#fn <- file.path(my.getwd(), paste("*", extension, sep=""))
fn <- extension
if(identical(.Platform$OS.type, "windows")){
if(identical(type, "selectdir"))
f <- choose.dir(fn)
else
f <- choose.files(fn, multi = multi, filters=filters)
} else {
f <- gfile(fn, multi = multi, type = type)
}
if(!is.na(f) && length(f) > 0 && nchar(f) > 0){
set.value(item, f)
#tryCatch({
setwd(dirname(f))
#}, error = function(e) setwd(dirname(f)))
}
#}, error = function(e){print(e)})
})
item$setData("name", name)
item$setData("get.value", function(x){
val <- x$getData("label")$getText()
# Check we're evaluating either a string or a call to c(...)
rv <- tryCatch({
pt <- parse(text=val)
if( length(pt) > 0 && (identical(call("c"), pt[[1]][1]) || identical(class(pt[[1]]), "character"))){
eval(pt)
} else {
val
}
}, error = function(e) val)
return(rv)
})
item$setData("set.value", function(x, value, propagate=TRUE, ...) {
x$getData("label")$setText(deparse(value))
if(propagate) signal(item, "default")
})
return(item)
}
objectItem <- function(value=NULL, name="", tooltip="", data.types=NULL, parent.window=NULL, ...){
item <- gtkHBoxNew()
label <- gtkEntryNew()
if(!length(value)){
label$setText("")
} else {
label$setText(value)
}
#label$setText(deparse(substitute(value)))
label$setAlignment(0)
#label$setSizeRequest(150, -1)
button <- gtkButtonNewWithLabel("Select Data...")
item$add(label)
bb1 <- gtkHBoxNew()
item$packEnd(button, FALSE, FALSE, 0)
item$setData("label", label)
gSignalConnect(button, "clicked", data=label, function(obj, data){
ow = options("warn")[[1]]
options(warn = -1) # suppress warnings from vb
label=data
# Changed to "select" from "gtk-close"
dialog <- gtkDialog("Select...", parent.window, "modal", "Select", 1,show = T)
dialog$setSizeRequest(400, 300)
dialog$setPosition(GtkWindowPosition["center-on-parent"])
dialog$setTransientFor(parent.window)
dialog$showAll()
library(gWidgetsRGtk2)
tryCatch({ # this warns about missing .tags on windows
vb <- gvarbrowser(action = list(item=item, label=label),
handler= function(obj, tv, path, column, ...){
action <- obj$action
label <- action$label
item <- action$item
if(identical(data.types, "function"))
getToolkitWidget((vb@widget)@filter)$setActive(4)
if(getToolkitWidget(vb)$getSelection()$countSelectedRows() > 0){
choice <- svalue(vb)
get.choice <- safe.eval(choice, envir=.GlobalEnv)
if(is.null(data.types) || class(get.choice)%in%data.types){
set.value(item, choice)
dialog$destroy()
}
}
options(warn = ow)
})
}, error= function(e) {}, warning= function(w) print(w))
dialog[["vbox"]]$add(getToolkitWidget(vb)$getParent()$getParent()$getParent())
if( dialog$run() == 1){
if(getToolkitWidget(vb)$getSelection()$countSelectedRows() > 0){
choice <- svalue(vb)
get.choice <- safe.eval(choice, envir=.GlobalEnv)
if(is.null(data.types) || class(get.choice)%in%data.types) set.value(item, choice)
}
options(warn = ow)
dialog$destroy()
}
})
item$setData("button", button)
item$setData("name", name)
item$setData("get.value", function(x){
#txt = x$getData("label")$getText()
#return(as.call(parse(text=txt))[[1]])
return(x$getData("label")$getText())
})
item$setData("set.value", function(x, value, propagate=TRUE, ...) {
#x$getData("label")$setText(deparse(substitute(value)))
label <- x$getData("label")
if(!length(value)){
label$setText("")
} else {
label$setText(value)
}
if(propagate) signal(item, "default")
})
gSignalConnect(label, "activate", function(...) {
signal(item)
})
#set.value(item, value)
return(item)
}
# An item to allow any data frame to be selected
dataframeItem <- function(data.types = .DATA_OBJECTS, ...)
objectItem(data.types=data.types, ...)
quick_message <- function(message="", win=NULL, caption="Warning") {
dialog <- gtkDialog(caption, NULL, "destroy-with-parent", "gtk-ok", 1, show = FALSE)
dialog$setPosition(GtkWindowPosition["center"])
label <- gtkLabel(message)
label$setLineWrap(TRUE)
gSignalConnect(dialog, "response", gtkWidgetDestroy)
hbox <- gtkHBoxNew()
hbox$packStart(label, TRUE, TRUE, 20)
dialog[["vbox"]]$packStart(hbox, TRUE, TRUE, 10)
dialog$setResizable(FALSE)
dialog$showAll()
dialog$setKeepAbove(TRUE)
dialog$run()
}
# source("/home/larman/research/RGtk/inst/demo/treeStore.R")
# From Rgtk demo
# Choice item
create.model <- function(row.items, col.items, initial=TRUE){
theFrame <- data.frame("rows" = row.items, array(initial, c(length(row.items), length(col.items))))
colnames(theFrame)[-1] <- col.items
model <- rGtkDataFrame(theFrame)
return(model)
}
item.toggled <- function(cell, path.str, data){
treeview <- data$treeview
vbox <- data$vbox
checkPtrType(treeview, "GtkTreeView")
model <- gtkTreeViewGetModel(treeview)
# theFrame <- as.data.frame(model)
path <- gtkTreePathNewFromString(path.str)
column <- cell$getData("column")
# theFrame[as.numeric(path$toString())+1, column+1] <- !theFrame[as.numeric(path$toString())+1, column+1]
# treeview$setModel(rGtkDataFrame(theFrame))
i <- as.numeric(path$toString())+1
j <- column + 1
model[i, j] <- !model[i, j]
return()
}
add.item <- function(treeview, item) {
model <- treeview$getModel()
iter <- model$append()$iter
model$set(iter, 0, item)
}
list.selected.items <- function(treeview)
{
checkPtrType(treeview, "GtkTreeView")
model <- treeview$getModel()
selection <- treeview$getSelection()
selected <- selection$getSelectedRows()$retval
rv <- vector("character", length(selected))
if (length(selected)) for(ii in 1:length(selected)){
path <- selected[[ii]]
iter <- model$getIterFromString(path$toString())$iter
rv[ii] <- model$get(iter, 0)[[1]]
}
return(rv)
}
column.clicked <- function(column, data){
col.idx <- column$getData("column.index")
#return(FALSE)
treeview <- data
columns <- treeview$getColumns()
ncols <- length(columns)
model <- treeview$getModel()
new.state <- column$getData("next.state")
column$setData("next.state", !new.state)
# path <- gtkTreePathNewFromString("0")
# iter <- model$getIter(path)$iter
# model$foreach(user.data=col.idx, function(model, path, iter, col.idx){
# model$set(iter, col.idx, new.state)
# return(FALSE)
# })
#
theFrame <- as.data.frame(model)
if(dim(theFrame)[1] > 0)
theFrame[, col.idx+1] <- !new.state
treeview$setModel(rGtkDataFrame(theFrame))
return(FALSE)
}
add.columns <- function(treeview, col.items, initial=integer(0), vbox) {
# column for holiday names
renderer <- gtkCellRendererTextNew()
renderer['ellipsize'] <- PangoEllipsizeMode['end']
renderer['ellipsize-set'] <- TRUE
renderer$set(xalign = 0.0)
col.offset <- treeview$insertColumnWithAttributes(-1, "Item", renderer,
text = 0)
column <- treeview$getColumn(col.offset - 1)
column$setClickable(TRUE)
gtkTreeViewColumnSetFixedWidth(column, 150)
gtkTreeViewColumnSetSizing(column, GtkTreeViewColumnSizing['fixed'])
if(length(col.items)) column$setResizable(TRUE)
if(length(col.items)) for(jj in 1:length(col.items)){
renderer <- gtkCellRendererToggleNew()
renderer$set(xalign = 0.0)
renderer$setData("column", jj)
gSignalConnect(renderer, "toggled", item.toggled, data=list(treeview=treeview, vbox=vbox))
col.offset <- treeview$insertColumnWithAttributes(-1, col.items[jj], renderer,
active = jj)
column <- treeview$getColumn(col.offset - 1)
column$setData("column.index", jj)
column$setSizing("fixed")
column$setFixedWidth(50)
column$setClickable(TRUE)
if(jj != length(col.items)) column$setResizable(TRUE)
column$setData("next.state", !jj%in%initial)
gSignalConnect(column, "clicked", column.clicked, data=treeview)
}
}
choice.grid <- function(row.items, col.items=character(0), initial=integer(0), xor=TRUE,
headers.visible=T, select.mode="multiple", handler.selected=NULL, user.data=NULL){
GetItems <- function(treeview){
model <- treeview$getModel()
ncols <- length(treeview$getColumns())-1
dim <- treeview$getData("dim")
retval <- array(F, dim)
the.dimnames <- treeview$getData("dimnames")
if(ncols > -1){
# .env <- new.env()
# .env$retval <- retval
#
theFrame <- as.data.frame(model)
#
## model$foreach( user.data=.env, function(model, path, iter, .env){
# iter <- model$getIter(path)$iter
# ii <- path$getIndices()+1
# if(ncols > 0) for(jj in 1:ncols) .env$retval[ii, jj] <- model$get(iter, jj)[[1]]
# return(FALSE)
# })
# retval <- .env$retval
if(length(dim(theFrame)) > 1 && dim(theFrame)[2] > 0){
rn <- theFrame[,1]
cn <- colnames(theFrame)
retval <- array(as.logical(as.matrix(theFrame[,-1,drop=F])), dim(theFrame[,-1,drop=F]))
rownames(retval) <- rn
colnames(retval) <- cn[-1]
} else {
#print("Frame NOT seen")
}
} else { # just return selected values for 0 columns
retval <- integer(0)
tryCatch({
retval <- gtkTreeSelectionGetSelectedRows(gtkTreeViewGetSelection(treeview))$retval
if(length(retval)){
retval <- sapply(retval, gtkTreePathGetIndices)+1
}
},
error=function(e) {
warning(e)
})
if(!length(retval)) retval <- integer(0)
retval <- the.dimnames$rows[retval]
}
retval
}
# create tree view
make.treeview <- function(vbox, row.items, col.items, initial=integer(0)){
sw <- gtkScrolledWindowNew(NULL, NULL)
sw$setShadowType("etched-in")
sw$setPolicy("automatic", "automatic")
vbox$packStart(sw, TRUE, TRUE, 0)
vbox$setData("sw", sw)
## this returns an RGtkDataF
model <- create.model(row.items, col.items, initial)
treeview <- gtkTreeViewNewWithModel(model)
treeview$setRulesHint(TRUE)
treeview$setHeadersVisible(headers.visible)
treeview$getSelection()$setMode(GtkSelectionMode[select.mode])
vbox$setData("model", model)
sw$setData("treeview", treeview)
# selectedColor <- as.GdkColor(c(49, 106, 197)*256) # Linux
# treeview$modifyBase(GtkStateType['selected'], selectedColor)
# treeview$modifyBase(GtkStateType['active'], selectedColor)
# treeview$modifyText(GtkStateType['selected'], as.GdkColor("white"))
# treeview$modifyText(GtkStateType['active'], as.GdkColor("white"))
treeview$setData("xor", xor)
treeview$setData("dim", c(length(row.items), length(col.items)))
treeview$setData("dimnames", list(rows=row.items, columns=col.items))
treeview$setData("GetItems", GetItems)
add.columns(treeview, col.items, initial, vbox)
sw$add(treeview)
gSignalConnect(treeview$getSelection(), "changed",
data=list(vbox=vbox, treeview=treeview),
function(treeselection, data){
handler.selected <- vbox$getData("handler.selected")
user.data=vbox$getData("user.data")
if(is.function(handler.selected)){
treeview <- data$treeview
retval <- GetItems(treeview)
handler.selected(retval, user.data)
}
return(FALSE)
})
# watch out for mapping more than once
#gSignalConnect(sw, "map", map.treeview, data=list(treeview=treeview, col.items=col.items))
return(treeview)
}
replace.treeview <- function(vbox, row.items, col.items=character(0), initial=TRUE){
treeview <- vbox$getData("treeview")
theFrame <- data.frame("rows" = row.items, array(initial, c(length(row.items), length(col.items))))
colnames(theFrame)[-1] <- col.items
treeview$setModel(rGtkDataFrame(theFrame))
vbox$setData("treeview", treeview)
}
vbox <- gtkVBoxNew(FALSE, 8)
vbox$setBorderWidth(8)
vbox$setData("handler.selected", handler.selected)
vbox$setData("user.data", user.data)
vbox$setData("replace.treeview", replace.treeview)
treeview <- make.treeview(vbox, row.items, col.items, initial)
vbox$setData("treeview", treeview)
return(vbox)
}
# This creates a widget that allows selection of multiple ranges of values.
variableSelectorItem <- function(value, values=integer(0), name="", tooltip="", ...){
if(!length(values)) values <- "Select All" # our default column name
vbox <- choice.grid(character(0), col.items="Select All", initial =TRUE,
headers.visible=T, select.mode="none")
vbox$setBorderWidth(0)
vbox$setSizeRequest(200, 150)
vbox$setData("name", name)
vbox$setData("values", values)
vbox$setData("get.value", function(vbox){
treeview <- vbox$getData("treeview")
GetItems <- treeview$getData("GetItems")
stopifnot(is.function(GetItems))
values <- vbox$getData("values")
retval <- GetItems(treeview)
return(row.names(retval)[retval])
})
vbox$setData("set.value", function(vsi, values, initial=TRUE, propagate=TRUE, ...){
replace.treeview <- vsi$getData("replace.treeview")
#if(length(dim(values)) < 2){
replace.treeview(vsi, values, col.items="Select All", initial)
#} else if (length(dim(values)) == 2){
#}
vsi$setData("value", values)
if(propagate) signal(vsi, "default")
})
tvc <- vbox$getData("treeview")$getColumns()
if( length(tvc) > 1){
gSignalConnect(tvc[[2]], "clicked", function(...) signal(vbox, "default"))
renderer <- tvc[[2]]$getCellRenderers()[[1]]
gSignalConnect(renderer, "toggled", function(...) signal(vbox, "default"), vbox$getData("treeview"))
}
vbox$setData("expand", TRUE) # expand in column
set.value(vbox, value)
return(vbox)
}
# This just makes a new name in .global guaranteed to be unique.
unique.global.name <- function(nam){
ll <- ls(envir=.GlobalEnv)
new.name <- make.unique(c(ll, nam))[length(ll)+1]
return(new.name)
}
# This creates a widget that allows selection of multiple ranges of values.
listItem <- function(value,
return.selection = TRUE,
name="",
show.arrows= TRUE,
max.items = NULL,
remove.items = TRUE,
select.mode = "multiple",
...){
hbox0 <- gtkHBoxNew(FALSE, 0)
stopifnot(select.mode%in%c("none", "single", "multiple"))
vbox <- choice.grid(character(0), col.items=character(0), initial =character(0),
headers.visible=F, select.mode = select.mode)
hbox0$packEnd(vbox, TRUE, TRUE, 0)
box3 <- gtkVBoxNew(FALSE, 0)
box2 <- gtkVBoxNew(FALSE, 0)
hbox0$packStart(box3, FALSE, FALSE, 0)
if(show.arrows) box3$packStart(box2, FALSE, FALSE, 10)
#button1 <- gtkButtonNewWithLabel("/\\")
#box2$packStart(button1, FALSE, FALSE, 0)
#button2 <- gtkButtonNewWithLabel("\\/")
#box2$packStart(button2, FALSE, FALSE, 0)
button.add <- gtkButtonNewWithLabel(">>")
box2$packStart(button.add, FALSE, FALSE, 0)
button.remove <- gtkButtonNewWithLabel("<<")
box2$packStart(button.remove, FALSE, FALSE, 0)
gSignalConnect(button.add, "clicked", function(...) signal(hbox0, "add"))
gSignalConnect(button.remove, "clicked", function(...) signal(hbox0, "subtract"))
hbox0$setBorderWidth(0)
hbox0$setSizeRequest(200, 150)
if(show.arrows) hbox0$setSizeRequest(220, 150)
hbox0$setData("name", name)
hbox0$setData("remove.items", remove.items)
hbox0$setData("max.items", max.items)
hbox0$setData("get.value", function(hbox0, selected=FALSE){
treeview <- hbox0$getData("vbox")$getData("treeview")
rv <- NULL
if(selected) {
rv <- list.selected.items(treeview)
} else {
rv <- rownames(treeview$getData("GetItems")(treeview))
}
return(rv)
})
hbox0$setData("vbox", vbox)
hbox0$setData("expand", TRUE)
hbox0$setData("set.value", function(item, values=NULL, ...){
if(is.numeric(max.items) && max.items >= 1 && length(values) > max.items)
values <- values[1:max.items]
checkPtrType(item, "GtkBox")
vbox <- item$getData("vbox")
replace.treeview <- vbox$getData("replace.treeview")
replace.treeview(item$getData("vbox"), values, col.items=character(0), initial=1)
item$setData("value", values)
})
selection <- vbox$getData("treeview")$getSelection()
gSignalConnect(selection, "changed", function(...) {
signal(hbox0, "default")
})
#gSignalConnect(selection, "changed", function(...) {
# signal(hbox0, "default")
# print(get.value(hbox0))
#})
set.value(hbox0, value)
return(hbox0)
}
# this function turns a list of markup items into a list that has
# one element per markup item
process.markup <- function(dlg.list, func=NULL){
if(any(!nchar(names(dlg.list))))
stop(paste("Dialog markup contains unnamed elements at", paste(which(!nchar(names(dlg.list))), collapse=", ")))
items.regex <- paste("[.]", .ITEMS, "$", collapse="|", sep="")
pos.of.items <- regexpr(items.regex, names(dlg.list)) # where are the Items?
items.idx <- which(pos.of.items > -1)
possible.items.idx <- which(regexpr(paste("[iI]tem$", collapse="|", sep=""), names(dlg.list)) > -1)
if(!all(possible.items.idx%in%items.idx)) {
cat(paste('Found', paste(names(dlg.list)[possible.items.idx[!possible.items.idx%in%items.idx]], collapse=", "), "in dialog list but could not identify as markup item(s).\n"))
flush.console()
}
dlg.item.names <- substr(names(dlg.list), pos.of.items+1, pos.of.items+attr(pos.of.items, "match.length"))[items.idx]
retval <- list()
markup <- list()
if(length(items.idx) > 0 && items.idx[1] > 1)
markup <- (dlg.list[1:(items.idx[1]-1)])
retval[[1]] <- markup
names(retval)[1] <- "main"
arg.names <- substr(names(dlg.list), 1, pos.of.items-1)[items.idx]
if(any(duplicated(arg.names))) stop("Duplicate arguments in function dialog")
# # Warn for potential mismatches between function and dialog arguments
# if(!is.null(func) && is.function(func)){
# nff <- names(formals(func))
# if(length(nff) && !"..."%in%arg.names && any(!arg.names%in%nff))
# cat(paste("Found argument(s) called:", paste(arg.names[!arg.names%in%nff], collapse = ", "), "in function, but not in dialog.\n"))
# if(length(arg.names) && !"..."%in%nff && any(!nff%in%arg.names))
# cat(paste("Found argument(s) called:", paste(nff[!nff%in%arg.names], collapse = ", "), "in dialog, but not in function.\n"))
# }
#
if(length(items.idx)) for(jj in 1:length(items.idx)){
markup <- list()
pos <- items.idx[jj] # position in values
value <- dlg.list[[pos]] # the actual value that the dialog item has
markup['value'] <- list(value) # to deal with NULL
markup$signals <- list()
kk <- pos+1 # index we're at in the dialog list
while(!kk %in% items.idx && kk <= length(dlg.list)){
if(names(dlg.list)[kk] == "signal"){
markup$signals[[length(markup$signals)+1]] <- as.list(dlg.list[[kk]])
} else {
markup[[length(markup)+1]] <- dlg.list[[kk]]
if(is.null(dlg.list[[kk]])) # for nulls
markup[[length(markup)+1]] <- list(dlg.list[[kk]])
names(markup)[[length(markup)]] <- names(dlg.list)[kk]
}
kk <- kk +1
}
markup$name <- arg.names[jj]
markup$dlg.item.name <- dlg.item.names[jj]
retval[[length(retval)+1]] <- markup
names(retval)[length(retval)] <- names(dlg.list)[items.idx[jj]]
}
retval
}
# this function interprets the "signals" markup and performs signal.connect
# appropriately
wire.up.items <- function(a, dlg.items, envir){
locate.arg <- function(a, arg) {
idx <- which(unlist(sapply(a, function(x) x$name==arg), recursive=F))
if(length(idx) != 1)
stop(paste("locate.arg: argument named",
arg, "either not found or duplicated"))
return(idx)
}
# Connect signals
for(jj in 1:length(a)){
for(sig in a[[jj]]$signals){
if(length(sig) < 2) stop("Signal argument needs to contain at least 2 items")
signl <- sig[[1]]
if(!is.character(signl)) stop("Signal argument 1 needs to be a string containing the signal")
user.data <- sig$user.data
ww <- which(names(sig)%in%c("user.data"))
if(length(ww) > 0) sig <- sig[-ww]
sf <- sig[[2]]
if(is.character(sf)) {
# Look for signal function first in calling envir, then in local, then die
if (exists(sf, envir=envir, mode="function")) {
func <- get(sf, envir=envir)
} else if (exists(sf, mode="function")) {
func <- get(sf)
} else {
stop(paste("Can't find signaling function", sf))
}
} else if(is.function(sf)) {
func <- sf
} else {
stop("Signal argument #2 needs to be a function name or function")
}
obj <- dlg.items[[names(a)[jj]]]
data.args <- NULL
if(length(sig) >= 3)
data.args <- sapply(sig[(3:length(sig))],
function(x) dlg.items[[locate.arg(a, x)]])
if(!is.null(user.data))
data.args <- append(data.args, list(user.data=user.data))
connect.args = list(signal = signl, obj=obj, f=func, data=data.args)
do.call(signal.connect, connect.args)
}
}
# Send the default signal from all items marked sensitive
# This way if an item's marked insensitive, all its subordinates won't be
# toggled to sensitive
for(item in dlg.items){
if(item$isSensitive() && !identical(item$getData("signal.on.starting"), FALSE))
tryCatch(signal(item), error = function(e){
#cat(paste("Couldn't initialize dialog element", item$getData("name"), "to", deparse(get.value(item)), "\n")); flush.console()
})
}
}
create.dialog.items <- function(a){
dlg.items <- list()
for(jj in 1:length(a)){
obj.name <- names(a)[jj]
if(obj.name == "main")
next;
markup <- a[[jj]]
if(is.call(markup$value))
markup['value'] <- list(tryCatch({
eval(markup$value)
}, error = function(e) {
#deparse(markup$value)
#cat(paste("Couldn't set dialog element", markup$name, "to", deparse(markup$value), "\n"))
#flush.console()
return(NULL)
}))
dlg.item <- do.call(get(markup$dlg.item.name), markup)
dlg.items[[obj.name]] <- dlg.item
if(is.logical(markup$sensitive))
dlg.items[[obj.name]]$setSensitive(markup$sensitive)
if(is.logical(markup$signal.on.starting)) # option to signal from initialize dialog item on starting
dlg.items[[obj.name]]$setData("signal.on.starting", markup$signal.on.starting)
}
return(dlg.items)
}
create.panel <- function(a, dlg.items){
# this function creates a box with appropriate elements from the
# processed markup list
vbox.main <- gtkVBoxNew()
if(!is.null(a$main$label))
vbox.main$packStart(gtkLabelNew(a$main$label), FALSE, FALSE, 5)
hbox0 <- gtkHBoxNew() # hbox0 is where we pack our vboxes
curr.vbox <- gtkVBoxNew()
#tooltips <- gtkTooltipsNew()
# Assign items
for(jj in 1:length(a)){
obj.name <- names(a)[jj]
if(obj.name == "main")
next;
markup <- a[[jj]]
if(identical(markup$visible, FALSE))
next;
dlg.item <- dlg.items[[obj.name]]
nam <- markup$name
lab.str <- nam
if(!is.null(markup$label)) lab.str <- markup$label
if(!is.null(markup$tooltip) && nchar(markup$tooltip))
dlg.item$setTooltipText(markup$tooltip)
expand <- !is.null(dlg.item$getData("expand"))
bin <- myFrame(dlg.item, lab.str)
# add indentation if requested
if(!is.null(markup$indent)) {
hbox <- gtkHBoxNew()
vbox <- gtkVBoxNew()
hbox$packStart(vbox, FALSE, FALSE, markup$indent)
hbox$packEnd(bin, TRUE, TRUE, 0)
curr.vbox$packStart(hbox, expand, TRUE, 0)
} else {
curr.vbox$packStart(bin, expand, TRUE, 0)
}
# go to the next column if you see a BREAK
if("BREAK"%in%names(markup)) {
hbox0$packStart(curr.vbox, TRUE, TRUE, 0)
curr.vbox <- gtkVBoxNew()
}
}
# To pack the last vbox
if(!"BREAK"%in%names(markup)) hbox0$packStart(curr.vbox, TRUE, TRUE, 0)
vbox.main$packStart(hbox0, TRUE, TRUE, 0)
return(vbox.main)
}
run.dialog <- function(func,
pos = -1,
envir = as.environment(pos),
dlg.list = tryCatch(get(paste(func.name, "dialog", sep="."), envir=envir), error = function(e) NULL),
var.browser=NULL,
parent.window=NULL,
auto.assign=TRUE,
do.long.running=FALSE,
OK_handler = default.handler,
output.name.rule = "append",
output.name = NULL,
do.logging = TRUE,
log.handler = NULL,
user.args = NULL, # the user can specify which args to use
...)
{
func.name <- NULL
if(is.character(func)) {
func.name <- func
func <- get(func, envir=envir)
}
stopifnot(is.function(func))
if(is.null(func.name)) func.name <- deparse(substitute(func))
if(is.null(dlg.list)) dlg.list=tryCatch(get(paste("", func.name, "dialog", sep="."), envir=envir),
error = function(e) get(paste(func.name , "dialog", sep="."), envir=envir))
stopifnot(is.list(dlg.list))
#return()
# turn the flattened markup list into a list with $main and one item per dialog item
dlist <- process.markup(dlg.list, func)
if(!missing(user.args)){
# uas <- substitute(user.args)
# turn any symbols into their deparsed characters, for objectItems
# for(ii in 2:length(uas)) if(is.symbol(uas[[ii]])) uas[[ii]] <- deparse(uas[[ii]])
# symbol2names.user.args <- uas
# Make sure that you pass a string to this for objectItems, not a symbol
for(ii in seq(length=length(dlist))){
item <- dlist[[ii]]
if(isTRUE(item$name%in%names(user.args))){
user.value <- user.args[[item$name]]
if(item$dlg.item.name%in%c("radiobuttonItem", "choiceItem")){ # named value arg
value.names <- names(item$value)
if(any("value"%in%value.names)) names(value.names)["value"%in%value.names] <- ""
if(any(item$value%in%user.value)) names(dlist[[ii]]$value)[which(item$value%in%user.value)] <- "value"
} else if (item$dlg.item.name%in%"integerItem"){
dlist[[ii]]$value["value"] <- user.value
} else if (item$dlg.item.name%in%c("dataframeItem", "objectItem")){
dlist[[ii]]$value <- user.value
} else {
dlist[[ii]]$value <- user.value
}
}
}
}
#print(dlist)
input.name <- NULL
# set hints if varbrowser is set
if(!is.null(var.browser)){
item.hint <- names(which(sapply(dlist, function(x)
!is.null(x$dlg.item.name) && x$dlg.item.name%in%c("dataframeItem", "objectItem"))))
nsr <- getToolkitWidget(var.browser)$getSelection()$countSelectedRows()
if(nsr > 0 && length(item.hint) > 0) {
vb.choice <- svalue(var.browser)
if(!identical(dlist[[item.hint[1]]]$take.hint, FALSE)) # take.hint markup cancels this
dlist[[item.hint[1]]]$value <- vb.choice
}}
# create the list of dialog items
dlg.items <- create.dialog.items(dlist)
# create a box containing the dialog elements
box <- create.panel(dlist, dlg.items)
# set the signaling properties between dialog elements
wire.up.items(dlist, dlg.items, envir)
title <- func.name
if(!is.null(dlist$main$title)) title <- dlist$main$title
close.str <- "gtk-cancel"
if(identical(dlist$main$keep.open, TRUE)) close.str <- "gtk-close"
if(identical(dlist$main$ok.button, FALSE))
dialog <- gtkDialog(title, parent.window, "modal", "gtk-close", 0, show = F)
else
dialog <- gtkDialog(title, parent.window, "modal", "gtk-ok", 1, close.str, 0, show = F)
dialog$setPosition(GtkWindowPosition["center-on-parent"])
dialog[["vbox"]]$packStart(box, TRUE, TRUE, 0)
dialog$showAll()
dialog_button_box <- dialog$getChildren()[[1]]$getChildren()[[2]]
dgc <- dialog$getChildren()[[1]]$getChildren()
dialog_button_box <- dgc[[length(dgc)]]
runMe <- function(){
dialog_button_box$setSensitive(FALSE)
the.args <- lapply(dlg.items, get.value)
names(the.args) <- sapply(dlg.items, get.name)
dataset.name <- NULL
if(length(the.args)) for(jj in 1:length(the.args)){
# this is to get the name or call as required
if(dlist[[names(dlg.items)[jj]]]$dlg.item.name%in%c("dataframeItem", "objectItem")
&& !identical(dlist[[names(dlg.items)[jj]]]$as.character, TRUE)){
the.args[jj] <- list(tryCatch(as.call(parse(text=the.args[[jj]]))[[1]], error = function(e) NULL))
if(is.null(dataset.name) && !is.null(the.args[[jj]])){
dataset.name <- deparse(the.args[[jj]])
}
}
}
# if the "suppress" markup is used, then suppress this value from being passed to the function
suppress.idx <- which(unlist(sapply(dlist, function(x) !is.null(x$suppress) && identical(x$suppress, TRUE))))
for(nam in names(suppress.idx)) the.args[[dlist[[nam]]$name]] <- NULL
if("..."%in%names(the.args)){
ss <- paste("list(",the.args$...,")", sep="")
s2 <- eval(parse(text=ss))
for(nn in names(s2)) the.args[[nn]] <- s2[[nn]]
the.args$... <- NULL
}
if(is.null(output.name)){
if(output.name.rule == "append"){
if(is.null(dataset.name)){
output.name <- paste(func.name, "output", sep="_")
} else {
output.name <- paste(func.name, dataset.name, sep="_")
}
} else if (output.name.rule == "replace") {
output.name <- dataset.name
} else {
stop("Unknown output.name.rule")
}
output.name <- gsub(".", "_", make.names(output.name), fixed=T)
}
#the.args <<- the.args
# Execute the function
retval <- NULL
if(.Platform$OS.type == "windows" && do.long.running || identical(dlist$main$long.running, TRUE)) {
do.long.running.task(func=func, values=the.args, func.name=func.name, input.name=input.name, output.name=output.name)
} else {
dcan <- NULL
if(identical(dlist$main$show.progress, TRUE)){
dcan = gtkDialog("Progress", parent.window, "modal", "gtk-cancel", 1, show=F)
pb <- gtkProgressBar()
dcan[["vbox"]]$packStart(pb, TRUE, FALSE, 10)
dcan$setPosition(GtkWindowPosition["center-on-parent"])
dcanbb <- rev(dcan$getChildren()[[1]]$getChildren())[[1]]
b = dcanbb$getChildren()[[1]]
gSignalConnect(b, "clicked", function(button, data=list(dcan=dcan, dlg=dialog)){
data$dcan$destroy()
dialog_button_box$setSensitive(TRUE)
#dlg$destroy()
.C("rgtk2extras_interrupt")
})
# Pass the p.b. to the function if it's looking for one
pw_contains_bar <- FALSE
pw_contains_label <- FALSE
if("progressbar" %in% names(formals(func)) && !"progressbar" %in% names(the.args)) {
pw_contains_bar <- TRUE
the.args <- append(the.args, list(progressbar = pb))
}
if("progresslabel" %in% names(formals(func)) && !"progresslabel" %in% names(the.args)) {
pw_contains_label <- TRUE
pl <- gtkLabelNew()
dcan[["vbox"]]$packStart(pl, TRUE, FALSE, 10)
the.args <- append(the.args, list(progresslabel = pl))
}
if(!pw_contains_bar && !pw_contains_label){
pb$setText("Function is running...")
}
dcan$show()
while(gtkEventsPending()) gtkMainIteration()
}
retval <- OK_handler(func=func, values=the.args, func.name=func.name, input.name=input.name, output.name=output.name, cancel.dialog=dcan)
# while(TRUE) Sys.sleep(0.1)
if(!is.null(dcan) && !inherits(dcan, "<invalid>")) dcan$destroy()
}
# Assign the output. Can do it within hierarchical list or else create a new name.
if(!is.null(retval) && auto.assign){
assign(output.name, retval, envir=.GlobalEnv)
}
# Log the action to a file
if(!do.long.running && do.logging && !is.null(log.handler) && is.function(log.handler)){
the.args$progresslabel <- NULL
the.args$progressbar <- NULL
sub.values <- as.character(substitute(the.args))
cidx <- sapply(the.args, function(x) is.character(x) && length(x) == 1)
sub.values[cidx] <- sapply(as.character(the.args[cidx]), deparse)
cmd.string <- paste(func.name, "(",
paste(paste(names(the.args), sub.values, sep="="), collapse=", "),
")\n", sep="")
cmd.string <- paste(output.name, "<-", cmd.string)
log.handler(cmd.string)
}
dialog_button_box$setSensitive(TRUE)
return(list(retval=retval, args = the.args))
} # end runMe
retval <- NULL
if(identical(dlist$main$keep.open, TRUE)) {
while(dialog$run() == 1){
# tryCatch({
retval <- runMe()
# }, interrupt = function() {
# cat("Function interrupted.\n")
# })
}
dialog$destroy()
} else {
if(dialog$run() == 1){
retval <- runMe()
dialog$destroy()
} else {
dialog$destroy()
}
}
return(invisible(retval))
}
# This is our handler for computations and returning things
# Try to call the output "Dataset.Function" or "Function.Output"
# input name is the first dataset name we've got, if any
default.handler = function(func, values, func.name=NULL, input.name=NULL, output.name=NULL, data=NULL,
confirm.overwrite=F, cancel.dialog=NULL) {
retval <- NULL
stopifnot(is.function(func))
tryCatch({
retval <- do.call(func, values)
},
interrupt = function(ex)
{
cat("Function was interrupted.\n");
#print(ex);
},
error = function(ex)
{
#gmessage(paste("An error occurred in", func.name, "\n\n", as.character(ex)))
if(!is.null(cancel.dialog) && !inherits(cancel.dialog, "<invalid>")) cancel.dialog$destroy()
quick_message(paste("An error occurred in", func.name, "\n\n", as.character(ex)))
},
#warning = function(w)
#{
# gmessage(paste("A warning occurred in", func.name, "\n\n", as.character(w)))
#},
finally =
{
if(!is.null(cancel.dialog) && !inherits(cancel.dialog, "<invalid>")) cancel.dialog$destroy()
}) # tryCatch()
return(retval)
}
##
##
# These are some functions for common dialog signaling needs
# This function should trigger the same result as if the rightmost button were clicked
run.it <- function(item){
while(!inherits(item$getParent(), "GtkWindow")) item <- item$getParent()
rev(rev(item$getChildren())[[1]]$getChildren())[[1]]$clicked()
}
# Get names from the item and set them to list
get.names <- function(item, b, user.data=NULL) {
#obj <- get(get.value(item))
obj <- safe.eval(get.value(item))
set.value(b, names(obj))
}
# user.data (list(extra.names = "row.names")) puts row.names at the start
get.colnames <- function(item, ..., user.data=NULL) {
#obj <- get(get.value(item))
if(object.exists(get.value(item))){
obj <- safe.eval(get.value(item))
cn <- colnames(obj)
if(is.null(cn)) cn <- 1:dim(obj)[2]
if(!is.null(user.data$extra.names)) cn <- c(user.data$extra.names, cn)
sapply(list(...), function(x) set.value(x, cn))
}
}
get.rownames <- function(item, ..., user.data=NULL) {
#obj <- get(get.value(item))
obj <- safe.eval(get.value(item))
rn <- colnames(obj)
if(is.null(rn)) rn <- 1:dim(obj)[1]
if(!is.null(user.data$extra.names)) rn <- c(user.data$extra.names, rn)
sapply(list(...), function(x) set.value(x, rn))
}
# Get the data object name from b and the column from item and report
# the column objects
get.column <- function(item, b, c, user.data=NULL) {
colname <- get.value(item)[1]
#obj <- get(get.value(b))
obj <- safe.eval(get.value(b))
set.value(c, obj[,colname])
}
# Set all arguments to user.data
set.to <- function(item, ..., user.data=NULL){
sapply(list(...), function(x) set.value(x, user.data))
}
toggle.sensitive = function(item, ...){
#x$setSensitive(get.value(item))
sapply(list(...), gtkWidgetSetSensitive, get.value(item))
# Send on the signal from the item only if it's sensitive
# This way you can have hierarchies of toggles for example
sapply(list(...), function(x) if(x$isSensitive()) signal(x))
}
# Transfer selected list rows from the second argument to the item
push.selection = function(item, b) {
xx <- union(get.value(item), get.value(b, selected=T))
# print("push.selection1")
# print(xx)
set.value(item, xx)
xx <- intersect(get.value(item), get.value(b, selected=T))
xx <- setdiff(get.value(b), xx)
# print("push.selection2")
# print(xx)
set.value(b, xx)
}
# Transfer selected list rows from the item to the second argument
pop.selection = function(item, b) {
push.selection(b, item)
}
# Copy selected list rows from the second argument to the item
# Assumes all items are unique.
copy.selection = function(item, b) {
xx <- union(get.value(item), get.value(b, selected=T))
set.value(item, xx)
}
# Remove selected list rows
remove.selection = function(item) {
xx <- setdiff(get.value(item), get.value(item, selected=T))
set.value(item, xx)
}
get.choice.names <- function(choice){
get.choice <- safe.eval(choice, envir=.GlobalEnv)
# if(exists(choice, envir=.GlobalEnv)){ # Selected a data frame
# get.choice <- get(choice, envir=.GlobalEnv)
# } else { # we've specified a data frame inside a list
# parse.choice <- parse(text=choice)
# get.choice <- eval(parse.choice, envir=.GlobalEnv)
# }
stopifnot(!is.null(names(get.choice)))
values <- names(get.choice)
return(values)
}
# Utility function to return all tables in global
get_all_tables <- function(){
.e <- new.env()
.e$ll <- c()
list_all_tables <- function(item, nam){
if(is.data.frame(item)||is.matrix(item)){
if(nam%in%.e$ll) warning(paste("Name shadowed", nam))
.e$ll <- c(.e$ll, nam)
}
if(is.list(item) && length(item)>0)
for(ii in 1:length(item)){
if(!is.null(names(item))) {
list_all_tables(item[[ii]], paste(nam, names(item)[ii], sep="$"))
}# else {
# list_all_tables(item[[ii]], paste(nam, "[[", ii, "]]", sep=""))
#}
}
}
for(item in ls(envir=.GlobalEnv)){
list_all_tables(get(item), item)
}
return(.e$ll)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.