Nothing
##' @include misc.R
NULL
##' Show info on Gtk widgets
##'
##' @return NULL
##' @export
showGtkWidgetInfo <- function() {
if(!faux_require("RGtk2"))
stop("This function require RGtk2")
## Main widgets
## entry widget
co <- gtkEntry() # object
nb <- gtkNotebook() # notebook
buffers <- list( # text buffers
properties = gtkTextBuffer(),
signals = gtkTextBuffer(),
methods = gtkTextBuffer(),
methodLookup = gtkTextBuffer()
)
bnames <- gettext(c("Widget Properties","Widget Signals","Widget methods", "Lookup method"))
names(bnames) <- names(buffers)
## Main GUI
w <- gtkWindow(show=FALSE)
w$setTitle("Browse Gtk Object")
w$setDefaultSize(500,450) # set size
g <- gtkVBoxNew(spacing=5, homogeneous=FALSE); w$add(g)
statusbar <- gtkStatusbar()
g$PackEnd(statusbar, expand=FALSE, fill=FALSE)
sg <- gtkHBoxNew(); g$packStart(sg, expand=FALSE, fill=FALSE)
sg$packStart(gtkHBox(), TRUE, TRUE,0) # push to right
sg$packStart(gtkLabel("gtk object:"),FALSE,FALSE)
sg$packStart(co, FALSE,FALSE,5)
## populate notebook
g$packStart(nb, TRUE,TRUE)
sapply(c("properties","signals","methods"),
function(i) {
tv <- gtkTextView(buffers[[i]])
sw <- gtkScrolledWindow()
sw$setPolicy("GTK_POLICY_AUTOMATIC","GTK_POLICY_AUTOMATIC")
sw$add(tv)
nb$appendPage(sw, gtkLabel(bnames[i]))
})
nb$setCurrentPage(0) # start on first page
## method lookup is different
mlg <- gtkVBox()
nb$AppendPage(mlg, gtkLabel("method lookup"))
vg <- gtkHBox()
mlg$PackStart(vg, expand=FALSE, fill=FALSE)
l <- gtkLabel("Method name:"); l['xalign'] <- 1
vg$PackStart(l)
methodEntry <- gtkEntry()
meCompletion <- gtkEntryCompletionNew()
meCompletion$setModel(gtkListStore("gchararray"))
meCompletion$setTextColumn(0)
methodEntry$setCompletion(meCompletion)
vg$PackStart(methodEntry)
tv <- gtkTextView(buffers[["methodLookup"]])
sw <- gtkScrolledWindow()
sw$setPolicy("GTK_POLICY_AUTOMATIC","GTK_POLICY_AUTOMATIC")
sw$add(tv)
mlg$PackStart(sw, expand=TRUE, fill=TRUE)
## functions to get information
toLowerFirst <- function(x) {
tmp <- unlist(strsplit(x,""))
paste(tolower(tmp[1]),paste(tmp[-1],collapse=""),sep="")
}
lookupObject <- function(objectName, where=.GlobalEnv) {
object <- get(objectName, envir=where)
if(inherits(object, "try-error")) {
statusbar$Push(1, paste("Can't find Gtk object:", objectName, sep=" "))
} else {
statusbar$Push(1,"")
}
return(object)
}
getPropertyText <- function(obj,
constructor=toLowerFirst(class(obj)[1])
) {
classes <- class(obj) # vector
properties <- obj$getPropInfo() #list
out <- c(constructor,"","","Class inheritance:")
for(i in 1:length(classes))
out[length(out)+1] <-
paste(paste(rep("\t",i-1),collapse=""), classes[i],sep="")
out[length(out)+1] <- "Properties:"
## now turn properties into text
for(i in names(properties)) {
out[length(out)+1] <- i
for(j in names(properties[[i]])) {
out[length(out)+1] <- paste("\t",j,": ",
as.character(properties[[i]][[j]]),
sep="")
}
}
return(out)
}
getSignalText <- function(obj,
constructor=toLowerFirst(class(obj)[1])
) {
signals <- gtkTypeGetSignals(constructor)
out <- c()
for(i in names(signals))
out[length(out)+1] <- paste(i,":\t signal-id ",as.character(signals[[i]]),sep="")
return(out)
}
getMethodsText <- function(obj,
constructor=toLowerFirst(class(obj)[1])
) {
out <- c(paste("Methods for", constructor))
meths <- apropos(paste("^",toLowerFirst(constructor),sep=""),ignore.case=FALSE)
out <- c(out,paste("\t",meths,sep=""))
return(out)
}
possibleMethods <- function(obj) {
## return vector of possible method names
l <- c()
for(i in class(obj)) {
meths <- apropos(paste("^",toLowerFirst(i), sep=""), ignore.case=FALSE)
meths <- gsub(toLowerFirst(i), "", meths)
meths <- meths[meths != ""]
meths <- meths[!grepl("New",meths)]
l <- c(l, meths)
}
return(l)
}
getMethodForObject <- function(obj, name, where=parent.frame()) {
## this is from RGtk2:.getAutoMethodByName
classes <- c(attr(obj, "interfaces"), class(obj))
sym <- paste(tolower(substring(classes, 1, 1)), # camelCase
substring(classes, 2),
toupper(substring(name, 1, 1)),
substring(name, 2),
sep = "")
which <- sapply(sym, exists, where)
if (!any(which)) {
msg <- paste("No such method", name, "for classes",
paste(class(obj), collapse = ",\n\t"))
} else {
methodName <- sym[which][1]
msg <- paste(paste("Opening help page for", methodName, "\n"))
##
print(help(methodName, help_type="html"))
}
return(msg)
}
showGtkInfo <- function(obj,
constructor=toLowerFirst(class(obj)[1])) {
if(missing(obj)) {
constructor <- gsub("New$","",constructor)
FUN <- match.fun(constructor)
obj <- do.call(constructor, list(show=FALSE))
if(inherits(obj,"try-error")) {
statusbar$Push(paste("Can't get object for", constructor, sep=" "),0)
return(FALSE)
} else {
statusbar$Push(1, "")
}
}
## update text buffers. SetText overwrites current text
propText <- paste(getPropertyText(obj, constructor),collapse="\n")
buffers[['properties']]$setText(propText)
signalText <- paste(getSignalText(obj, constructor),collapse="\n")
buffers[['signals']]$setText(signalText)
methsText <- paste(getMethodsText(obj, constructor),collapse="\n")
buffers[['methods']]$setText(methsText)
## update completion list for methods
l <- possibleMethods(obj)
store <- meCompletion$GetModel()
store$Clear()
for(i in l) {
iter <- store$append()
store$setValue(iter$iter, 0, i)
}
}
newObject = function(widget, ...) {
objectName <- widget$getText()
object <- lookupObject(objectName)
if(inherits(object, "try-error")) {
showGtkInfo(constructor=objectName)
} else {
showGtkInfo(obj=object)
}
return(FALSE)
}
ID <- gSignalConnect(co,"activate", f=newObject)
ID <- gSignalConnect(co, "focus-out-event", f=newObject)
ID <- gSignalConnect(methodEntry, "activate", f=function(widget, user.data) {
methodName <- widget$GetText()
object <- lookupObject(user.data$GetText())
if(inherits(object, "try-error"))
return()
txt <- getMethodForObject(object, methodName)
txt <- paste(txt, collapse="\n")
buffers[['methodLookup']]$setText(txt)
}, data=co)
## show GUI
w$showAll()
}
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.