viewHtml <-
#
# Uses the gtkhtml widget to display an HTML document in a scrolled window.
#
# Currently this handles internal links, i.e. hyper-links between HTML anchors
# within this document.
# Also handles certain types of embedded objects.
#
# Example:
# viewHtml(system.file("html", "00Index.html", package="base"))
#
function(fileName = "examples/form.html", createWindow = TRUE)
{
# Create an HTML widget. Make certain it can handle
# embedded objects (<OBJECT> tags).
html <- gtkHTMLNew()
# class(html) <- gtkObjectGetClasses(html, FALSE)
html$AddCallback("object-requested", embeddedObjectHandler)
# a list of the previous files visited.
history <- character(0)
status <- NULL
# setBase() is getting the wrong arguments going to the
tmpBase <- getwd()
Load <-
# Loads the contents of a file into the HTML widget.
# Function so that we can call it from menu callbacks.
function(infile, reload = FALSE) {
if(!reload)
addToHistory(fileName)
if(file.exists(infile)) {
html$SetBase(infile)
tmpBase <<- dirname(infile)
lns <- paste(readLines(infile), collapse="\n")
html$LoadFromString(lns, -1)
fileName <<- infile
} else if(!is.null(status)) {
status$Push(statusContext, paste(infile,"doesn't exist"))
}
TRUE
}
addToHistory <-
# Add the file name to the history list
# and add it to the menu
function(name) {
if(!any(name == history)) {
HistoryMenu$Append(item <- gtkMenuItem(name))
item$AddCallback("activate", function(w, cmd) {Load(cmd, FALSE)}, data = name, object = FALSE)
}
history <<- c(history, name)
TRUE
}
sw <- gtkScrolledWindow(show = FALSE)
# Do not use with viewport. Seg-faults in layout allocation size!
sw$Add(html)
if(!createWindow) {
# Now actually load the file
Load(fileName, TRUE)
return(list(html = html, scrolledWindow = sw))
}
# create the window and set its size.
win <- gtkWindow(show = FALSE)
win$SetUsize(400, 500)
# Now create a vertical box and put the menu and the HTML widget (actually
# the scrolled window in wich it resides) into it.
box <- gtkVBox(FALSE, 4)
mbar <- gtkMenuBar()
fileMenu <- gtkMenuItem("File")
# Create a pull-down menu with a function in command.S
# Each of the entries has the same callback function given in the
# second argument.
m <- createSimpleMenu(c("Load", "Reload", "", "Edit", "", "Close"),
function(w, cmd) {
if(cmd == "Load") {
dlg <- gtkFileSelection("Load html file")
dlg[["OkButton"]]$AddCallback("clicked",
function(w) {
f <- dlg$GetFilename()
if(f != "") {
Load(f)
dlg$Destroy()
}
})
dlg[["CancelButton"]]$AddCallback("clicked", function(w) dlg$Destroy())
dlg$Show()
} else if(cmd == "Reload") {
Load(fileName, TRUE)
} else if(cmd == "Close") {
win$Hide()
}
})
fileMenu$SetSubmenu(m$menu)
mbar$Append(fileMenu)
# Create an empty history menu to which we will add the entries
# as we load new files and store the previous value
historyMenu <- gtkMenuItem("History")
HistoryMenu <- gtkMenu()
historyMenu$SetSubmenu(HistoryMenu)
mbar$Append(historyMenu)
# Put the menu bar into the top-level box.
box$PackStart(mbar, expand = FALSE)
# Now create a row in the box that has a URL label, an entry to type a URL
# and a button to process that entry if one doesn't want to use the Enter key.
urlBox <- gtkHBox(FALSE, 10)
urlBox$PackStart(gtkLabel("URL"), expand = FALSE, fill= FALSE)
urlEntry <- gtkEntry()
urlBox$PackStart(urlEntry, expand = TRUE)
# When the user hits return, load the URL!
urlEntry$AddCallback("activate", function(w) {
txt <- w$GetText()
if(txt != "") {
Load(txt)
}
})
btn <- gtkButton("Go")
urlBox$PackStart(btn, expand = FALSE, fill= FALSE)
btn$AddCallback("clicked", function(w) {
txt <- urlEntry$GetText()
if(txt != "")
Load(txt)
})
box$PackStart(urlBox, expand = FALSE)
# Put the scrolled window for the HTML widget next.
box$PackStart(sw)
# Now create status bar at the bottom of the window
# and use this to display URLs that we mouse-over.
status <- gtkStatusbar()
statusContext <- status$GetContextId("description")
box$PackEnd(status, expand= FALSE)
# Now actually load the file
Load(fileName, TRUE)
win$Add(box)
win$ShowAll()
# Now setup some handlers for the HTML actions.
# Callback for user clicking on a link.
link <- html$AddCallback("link-clicked",
function(w, link) {
print(link)
if(length(grep("^#", link))) {
html$JumpToAnchor(gsub("^#","", link))
} else if(length(grep("^R:", link))) {
eval(parse(text = substring(link, 3)))
} else {
if(file.exists(link)) {
Load(link)
} else if(file.exists(paste(tmpBase, link, sep=.Platform$file.sep)))
Load(paste(tmpBase, link, sep=.Platform$file.sep))
# cat("External Link:",link,"\n")
}
})
# These are for mouse-over links and we display the locations
# in the status bar.
link <- html$AddCallback("on-url",
function(w, link) {
if(link != "") {
status$Push(statusContext, link)
}
NULL
})
# Handler for when the user clicks on the form submit
submit <- html$AddCallback("submit",
function(w, str1, str2, str3) {
cmd <- parseFormURL(str3)
print(eval(parse(text = cmd["command"])))
})
invisible(list(win = win, html = html, callbackIds = list(link, submit)))
}
parseFormURL <-
#
# Take the string reported by an HTML form in the format
# name1=value1&name2=value2&name3=value3....&name-n=value-n
# and return a vector of the form
# c(name1=value, name2=value2,...)
# i.e. a named character vector with the values and indexed
# by the corresponding name.
#
function(url)
{
# Do the first level split at the &'s in the string.
cmd <- strsplit(url,"&")[[1]]
# Now split by the =
cmd <- strsplit(cmd,"=")
# Get the names and then the values in two separate steps.
#
name <- sapply(cmd, function(x) x[[1]])
cmd <- sapply(cmd, function(x) if(length(x) > 1) x[[2]] else "")
names(cmd) <- name
cmd
}
htmlOutputFilter <-
#
# An ``object'' that provides methods for generating
# HTML for an S session, giving a representation of
# a task (expression and result).
#
function()
{
# Counter for the number of commands that have been displayed.
ctr <- 0
markup <-
#
# Create a textual representation of the given
# command (`cmd') and result (`value').
#
function(cmd, value) {
ctr <<- ctr + 1
# Using a text connection is convenient, but
# having the result be stored in a global variable
# is one of the worst "design" decisions I have seen!
# In the future, this will be fixed.
con <- textConnection(".out", open="w")
sink(con)
on.exit({sink(); close(con)})
print(value) # print the value to the text connection so we
# we can get the resulting text next.
out <- get(".out")
val <- c("<dt>", ctr,
"<font color='red'>",
paste("<a href='",cmd,"' name='", ctr, "'>", sep=""),
cmd, "</a></font></dt>\n",
"<dd>\n<pre>\n",
out,
"\n</pre></dd>\n")
val
}
header <-
# Called when starting the session
function() {
"<body bg='#FFF'><h1>Output</h1>\n<dl>"
}
footer <-
# Called each time we append an entry and should provide
# the closing element to finish off the document.
# This should provide the corresponding end elements for those
# in the header.
function() {
"</dl></body>"
}
# Return the filter methods as a list
# and give it a particular class for identification purposes.
m <- list(header = header,
markup = markup,
footer = footer,
getCurrentAnchor = function() as.character(ctr))
class(m) <- "HTMLCommandOutputFilter"
m
}
localOutput <-
#
# Simple interface with 2 HTML widgets stacked on top of each other
# The file displayed in the first is expected to present the interface
# via form so that when it is submitted there is an "command" variable
# in the data. This is parsed and evaluated and the result
# is displayed in the lower HTML widget. We markup the output
# using the `filter' which can do what it wants. In the default
# case, this makes the expression a link which if clicked re-runs
# that command. Also, it puts the result in a <PRE> tag
# and generates the content as if it were printed by R.
#
function(fileName = "examples/form.html", filter = htmlOutputFilter())
{
# Create a basic HTML widget without the window
w <- viewHtml(fileName, createWindow = FALSE)
#
html <- w$html
w$scrolledWindow$SetUsize(500,400)
# Now create the window
win <- gtkWindow(show = FALSE)
win$SetUsize(500,600)
# Create a split pane that the user can adjust directly
# The top contains the HTML document with the form, and
# the bottom one shows the output from the commands.
pane <- gtkVPaned()
pane$Add(w$scrolledWindow)
# The output HTML widget for the commands.
output <- gtkHTMLNew()
# Will be done when the bindings are done.
# class(output) <- gtkObjectGetClasses(output, FALSE)
sw <- gtkScrolledWindow()
sw$Add(output)
pane$Add(sw)
# Get the header for the output page.
txt <- filter$header()
# When the user clicks on the submit button in form in the top HTML widget,
# process the settings and evaluate the `command' value.
submit <- html$AddCallback("submit",
function(w, str1, str2, str3) {
cmd <- parseFormURL(str3)
evalCommand(cmd["command"], show = as.logical(cmd["show"]))
})
# Arrange to re-evaluate the command when the user clicks on it
# in the output area.
output$AddCallback("link-clicked",
function(w, link) {
evalCommand(link, show = TRUE)
})
evalCommand <-
# Evaluate a command, put the command and result
# in the output window by transforming the {expression, value}
# pair through the filter.
function(cmd, show = TRUE) {
val <- eval(parse(text = cmd))
if(!show)
return(val)
# Now display the result, marking it up as we want.
txt <<- c(txt, filter$markup(cmd, val))
contents <- paste(txt, filter$footer(), collapse="\n", sep="")
output$LoadFromString(contents, nchar(contents))
# And scroll to this new entry.
output$JumpToAnchor(filter$getCurrentAnchor())
val
}
win$Add(pane)
win$ShowAll()
return(list(win = win, output = output, html = html))
}
embeddedObjectHandler <-
#
# called when an HTML widget needs to act on an
# <OBJECT> tag for an embedded object.
# This returns TRUE or FALSE depending on whether it understood
# and processed the request or not.
# We can have built-in types or just evaluate the script
# in the init parameter
# <PARAM name="init" value="script but must contain ; between expressions">
#
#
function(html, obj)
{
type <- obj[["Type"]]
if(type == "app/x-color") {
# Create a color selection dialog.
obj$Add(gtkColorSelection())
} else if(type == "app/x-button") {
# Create a button and a simple callback.
label <- obj$GetParameter("label")
if(label == "")
label <- "Embedded Widget"
btn <- gtkButton(label)
obj$Add(btn)
btn$AddCallback("clicked", function(w) {print("Callback from embedded widget")})
} else if(type == "app/x-slider") {
# Create a slider, using values from the parameters for the min, max and value
# if provided.
mn <- obj$GetParameter("min")
mn <- ifelse(mn != "", as.numeric(mn), 0)
mx <- obj$GetParameter("max")
mx <- ifelse(mn != "", as.numeric(mx), 0)
val <- obj$GetParameter("value")
val <- ifelse(val != "", as.numeric(val), mn)
adj <- gtkAdjustment(val, mn, mx, .1, 1, 1)
scale <- gtkHScale(adj)
obj$Add(scale)
} else if(type == "app/x-R-device") {
dev <- gtk(no.window = TRUE);
class(dev) <- gtkObjectGetClasses(dev, check=FALSE)
dev$Show()
box <- gtkHBox(TRUE,10)
box$PackStart(dev)
obj$Add(box)
} else {
# Check if there is an init paramter and if so,
# attempt to evaluate it as an S command/expression.
init <- obj$GetParameter("init")
if(init != "") {
val <- eval(parse(text = init))
# If the result is a GtkWidget, then add it to the
# embedded widget container.
add <- as.logical(obj$GetParameter("addWidget"))
if(inherits(val, "GtkWidget") && (is.na(add) || add == TRUE)) {
obj$Add(val)
val$Reparent(obj)
} else if(is.function(val)) {
val(html, obj)
}
} else {
# say that we did't handle this.
return(FALSE)
}
}
TRUE
}