Nothing
## Copyright (C) 2011 John Verzani
##
## This program is free software: you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation, either version 3 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program. If not, see <http://www.gnu.org/licenses/>.
##' @include array.R
##' @include ext-misc.R
##' @include BasicInterface.R
##' @include gwidgets-toplevel.R
NULL
## Main class for object, include Ext stuff
##' Base class for all Ext objects
##'
##' The \code{GComponent} class provides the base class for all widgets.
##'
##' The basic setup of gWidgetsWWW2 involves a set of constructors and
##' S3 methods for manipulating the constructed objects. The
##' constructors return a reference class object. The S3 methods then
##' simply pass arguments along to the appropriate reference class
##' method. Of course, these may be called directly, but for
##' portability of gWidgets code to other toolkits this is not
##' recommended. However, for methods that are only implemented in a
##' given toolkit, such reference method calls becomes necessary and
##' desirable. In documenting the reference class objects just those
##' exposed methods which must be called as reference methods are
##' mentioned.
##'
##' The GComponent class is used to define methods common to all the
##' widgets. This class also includes methods for processing
##' callbacks. This is different in gWidgetsWWW2. The basic idea is
##' that JavaScript is used to make a callback into the session
##' containing (using the session id to find the correct evaluation
##' environment). Passed along are an object id (to find the signaling
##' object), a signal (to look up the handlers assigned to that object
##' for the given signal) and possibly some extra parameters. The
##' latter are there to bypass the transport calls that are used to
##' synchronize the widget state from the browser with the R session
##' data. These transport calls are asynchronous so may not have been
##' processed when the handler call is processed.
##'
##' The lookup used above requires each widget to be registered in a
##' toplevel object which is unique to a page. This toplevel object is
##' found from the session id, which then looks up the object from the
##' passed in object id. This toplevel object is passed into a widget
##' via either the \code{container} argument or the \code{parent}
##' argument. In addition to routing requests to handlers, the
##' toplevel object also is used to send back JavaScript commands to
##' the browser. The method \code{add_js_queue} is all that is needed
##' for this. A convenience method \code{call_Ext} provides an
##' alternative. For this method one specifies a method name and named
##' arguments that are converted to a JavaScript object to
##' parameterize the method call. Somewhat reverse to this is calling
##' an R object from JavaScript. The method \code{call_rpc} is used
##' for this, where in the JavaScript code one uses \code{jRpc} to
##' initiate the call and \code{add_public_method} to register that an
##' object's method is available to be called in this manner.
##'
##' Methods related to the handler code are \code{add_handler},
##' \code{invoke_handler}, \code{handler_widget},
##' \code{connect_to_toolkit}, \code{transport_fun},
##' \code{process_transport}, \code{param_defn},
##' \code{before_handler}
##'
##'
##' The basic reference class interface is meant to be implemented by
##' all gWidgets implementations. The forthcoming gWidgets2 will
##' expect that. So gWidgets2WWW -- if that ever happens -- will use
##' the basic interface, but for now gWidgetsWWW2 does only for the
##' most part.
##'
##' @rdname gWidgetsWWW2-package
GComponent <- setRefClass("GComponent",
contains="BasicToolkitInterface",
fields=list(
"toplevel"="ANY", # toplevel instance
"constructor" = "character", # for write_constructor
"args"="ANY", # for write_constructor
"prefix"="character", # really just "o"
"id" = "character", # the actual id, e.g gWidget_ID2
"transport_signal"="character", # if given, the signal to initiate transport
"value"="ANY", # default property of the object
"public_methods"="character", # exposed to rpc call
##
".e"="environment", # for stashing things (tag, tag<-)
change_signal="character", # what signal is default change signal
connected_signals="list",
..visible="logical",
..enabled="logical",
..editable="logical",
..index="ANY"
),
methods=list(
initialize=function(container=NULL, parent=NULL, ...) {
"Initialize widget. @param toplevel required or found"
if(!is.null(toplevel) && is(toplevel, "GWidgetsTopLevel")) {
toplevel <<- toplevel
} else {
if(is.null(container) & is.null(parent))
toplevel <<- NULL
if(is.null(container) & !is.null(parent))
toplevel <<- parent$get_toplevel()
if(!is.null(container))
toplevel <<- container$get_toplevel()
}
## This invovles a hack for finding the
## toplevel when none is specified, which
## should only happen with the initial
## gwindow() call.
## insert a toplevel thingy
if(is.null(toplevel)) {
## this variable is created when a new session is and lives in the
## evaluation environment. See gwidgets-session
if(exists(".gWidgets_toplevel", inherits=TRUE))
toplevel <<- get(".gWidgets_toplevel", inherits=TRUE)
else
toplevel <<- gWidgetsWWW2:::GWidgetsTopLevel$new()
}
## work on id
## id is used for html DOM id, o+id is used for
## javascript variable and key within toplevel hash
## to refer to this object
initFields(
args=gWidgetsWWW2:::ExtArgs$new(), # append with add_args method
.e=new.env(),
prefix="o",
id=sprintf("gWidget_ID%s", toplevel$get_object_id()),
##
..visible=TRUE,
..enabled=TRUE,
..editable=TRUE,
..index=NULL,
transport_signal="",
change_signal="",
public_methods=character(0)
)
args$extend(list(id=id))
toplevel$add_object(.self, get_id())
## return. We've eaten all the arguments
## we know of by now
callSuper()
},
init=function(...) {
"Initialization of the widget. The initialize method takes care of the toplevel"
},
## helpers
has_slot=function(key) {
exists(key, .self, inherits=FALSE)
},
##
add_args = function(..., overwrite=TRUE) {
"add new arguments. Will overwrite. Pass in lists of arguments through ..."
sapply(list(...), args$extend, overwrite=overwrite)
},
## id of base object (ogWidgetID1) There
## are two ids: the object id returned here
## refers to the actual javascript object
## created. The other id (the id property)
## is the DOM id of the object. The object
## id is usually what we want.
get_id = function() {
"ID of object. There is DOM id store in id property and Ext object id returned by this"
sprintf("%s%s", prefix, id)
},
get_toplevel=function() {
if(!is.null(toplevel))
return(toplevel)
else if(is(.self, "GWidgetsTopLevel"))
return(.self)
else
return(NULL)
},
## interface with js queue in toplevel
add_js_queue = function(cmd) {
"Add command to JavaScript queue"
toplevel$js_queue_push(cmd)
},
flush_js_queue = function() {
"Flush commands in JavaScript queue"
toplevel$js_queue_flush()
},
## method to write out constructor
write_constructor = function() {
"Write out constructor."
cmd <- sprintf("var %s = new %s(%s);",
get_id(),
constructor,
args$to_js_object()
)
add_js_queue(cmd)
},
write_ext_object = function(cls, args) {
"Write out an Ext object converting args"
cmd <- sprintf("new %s(%s)", cls, toJSObject(args))
String(cmd)
},
process_dot_args = function(...) {
"Helper function"
l <- list(...)
out <- sapply(l, coerceToJSString)
paste(out, collapse=", ")
},
## call a method of ext object
## This converts its arguments to JavaScript strings through coerceToJSString
call_Ext = function(meth, ...) {
"Write JavaScript of ext method call for this object. The ... values will be coerced to JavaScript stings through coerceToJSString, allowing the call to be as 'R'-like as possible, e.g.: call_Ext('setValue', 'some value'). Here the string will be quoted through ourQuote. To avoid that wrap within the String function, as in call_Ext('setValue', String('some value'))."
cmd <- sprintf("%s.%s(%s);",
get_id(),
meth,
process_dot_args(...))
cmd
add_js_queue(cmd)
},
## Ext apply basically merges lists (objects). Where the default comes from is up to you to
## read about....
ext_apply = function(value) {
"Call ext apply with value a list containing config options. This is called after write-constructor, prior to that call use add_args or arg$append."
if(is.null(value))
return()
cmd <- sprintf("Ext.apply(%s, %s);",
get_id(),
toJSObject(value))
add_js_queue(cmd)
},
## Transport. Many widgets transport a value from WWW -> R after
## minor changes through an AJAX call. This requires three things.
## 1. a signal that is listened to for an initiation of the transport
## 2. a function to define an object {value: ..., values: ..., others: ...} that
## is converted to JSON and transported back to R through the param argument
## 3. a process_transport method that is passed the widget id and this param value. It
## adjusts the state of the R widget and optionally other call, returning the javascript
## queue when done
##
## In the case where the transport_signal is the same as the default change_signal -- where we pass in the
## the change information -- we bypass this call.
transport_fun = function() {
"javascript function for transport web -> R. Creates an object param.
This is a string to be passed to the javascript queue withing the transport function call
E.g. var param = {value: this.getText()}"
"var param = null;" # no default
},
write_transport = function() {
"Writes out JavaScript for transport function"
## param ? Ext.JSON.encode(param) : null
f <- function(t_signal) {
if(t_signal == "") return()
cmd <- sprintf("%s.on('%s', function(%s) {%s; transportFun('%s', param)}, null, {delay:10, buffer:100, single:false});",
get_id(),
t_signal,
getWithDefault(.ext_callback_arguments[[t_signal]], ""),
transport_fun(),
get_id()
)
add_js_queue(cmd)
}
sapply(transport_signal, f)
},
write_change_transport = function() {
"Write change handler, instead of transport"
if(change_signal != "")
add_handler(change_signal, NULL, NULL)
},
process_transport = function(value, ...) {
"R Function to process the transport. Typically just sets 'value', but may do more. In the above example, where var param = {value: this.getText()} was from transport_fun we would get the text for value"
if(!is.null(value))
value <<- value
},
## Call back code
##
is_handler=function(handler) {
!missing(handler) && is.function(handler)
},
## add a handler
## creates an observer arranges to connect to toolkit
add_handler=function(signal, handler, action=NULL, decorator, ...) {
"Uses Observable framework for events. Adds observer, then call connect signal method. Override last if done elsewhere"
ID <- NULL
if(is_handler(handler)) {
if(!missing(decorator))
handler <- decorator(handler)
o <- observer(.self, handler, action) # in gWidgets2 but not now
ID <- add_observer(o, signal)
}
connect_to_toolkit_signal(signal, ...)
invisible(ID)
},
invoke_handler=function(signal, ...) {
"Invoke observers listening to signal"
notify_observers(..., signal=signal)
},
handler_widget=function() {
"Widget to assign handler to"
.self
},
connect_to_toolkit_signal=function(
signal, # which signal
...
) {
"Connect signal of toolkit to notify observer"
## only connect once
if(is.null(connected_signals[[signal, exact=TRUE]]))
add_R_callback(signal, ...)
connected_signals[[signal]] <<- TRUE
},
cb_args=function(signal) {
"Callback arguments, may be overridden in a subclass"
getWithDefault(.ext_callback_arguments[[signal, exact=TRUE]], "")
},
get_callback_object = function() {
"Return object for callback. Defaults to get_id(), but can be subclassed"
get_id()
},
add_R_callback = function(signal, ...) {
"Add a callback into for the Ext signal. Return callback idas a list."
## XXX This needs a fixing. The callbacks are now stored in the objects and we
## notify through toplevel$call_handler(id, signal, params)
## The id is for lookup from toplevel, the signal to call the right observers
## the params passed back to pass information prior to the call.
## What to do with handlers?
## create JS handler code
cmd <- sprintf("%s.on('%s', function(%s) {%s; callRhandler('%s', '%s', param)}, null, {delay:10, buffer:100, single:false});",
get_id(),
signal,
cb_args(signal),
param_defn(signal),
get_callback_object(),
signal
)
add_js_queue(cmd)
## what to return?
},
## We have an issue: when a user initiates
## an action, the state of the widget is
## being transported via the transport
## mechanism, Some times the request (which
## is asynchronous) beats the transport and
## the wrong value is used. This allows us
## to bypass by signal. These defaults just
## use the transport mechanism and are
## meant to be overridden.
param_defn=function(signal) {
"Define different parameter definitions based on the signal"
if(signal == change_signal) {
transport_fun()
} else {
"var param = null"
}
},
before_handler=function(signal, params) {
"Hook that can be called prior to observer call. Might be useful to set value without relying on transport call to arrive first. Return value -- a named list -- is passed to observers as components of h "
if(signal == change_signal) {
process_transport(params)
}
},
## delayed call
add_async_javascript_callback = function(url, callback, data=list(), data_type=c("json","xml", "html", "script", "text")) {
"
##' add ajax call complete with handler to call
##'
##' @param url url to call. Quote it if it is a string
##' @param callback string containing javascript callback. Might be
##' callRhandler to work with gWidgets. Arguments are data, textStatus
##' and jqXHR.
##' @param data named list of values to pass back to ajax call
##' @param data_type type of data coming back
"
tpl <- "
$.ajax({{url}}, {
dataType: '{{data_type}}',
data: {{data}},
type:'GET',
cache:false,
success: {{callback}}
});
"
out <- whisker.render(tpl, list(url=url,
data_type=match.arg(data_type),
data=toJSObject(merge.list(
list(session_id=String("session_id")),
data)),
callback=callback))
add_js_queue(out)
},
## block and unblock
block_handlers=function() {
"Block all handlers."
## default is to block the observers.
block_observers()
},
block_handler=function(ID) {
"Block a handler by ID"
block_observer(ID)
},
unblock_handlers=function() {
"unblock blocked observer. May need to be called more than once to clear block"
unblock_observers()
},
unblock_handler=function(ID) {
"unblock a handler by ID"
unblock_observer(ID)
},
remove_handlers=function() {
"Remove all observers"
remove_observers()
},
remove_handler=function(ID) {
"remove a handler by ID"
remove_observer(ID)
},
## Used to add a javascript callback -- that is not a call into R.
add_js_callback = function(signal, callback, ...) {
"Add a javascript callback. The value of 'this' refers to the object this is called from"
cmd <- sprintf("%s.on('%s', %s);",
get_id(),
signal,
callback)
add_js_queue(cmd)
},
##
## basic callbacks? (ext-component.R) XXX
##
add_handler_changed=function(handler, action=NULL, ...) {
add_handler(change_signal, handler, action, ...)
},
invoke_change_handler=function(...) {
"Generic change handler invoker."
if(!is(change_signal, "uninitializedField") && length(change_signal))
invoke_handler(signal=change_signal, ...)
},
add_handler_change=function(handler, action=NULL, ...) {
add_handler("change", handler, action, ...)
},
add_handler_clicked=function(handler, action=NULL, ...) {
add_handler("clicked", handler, action, ...)
},
add_handler_focus=function(handler, action=NULL, ...) {
add_handler("focus", handler, action, ...)
},
add_handler_blur=function(handler, action=NULL, ...) {
add_handler("blur", handler, action, ...)
},
add_handler_double_click=function(handler, action=NULL, ...) {
add_handler("dblclick", handler, action, ...)
},
##
## rpc
##
call_rpc = function(meth, val) {
"The jRpc call back from JavaScript into R passes a method name and arguments to the object. This calls the method"
if(!is.list(val))
val <- list(val)
## awkward way to call method by name avoiding cache
if(exists(meth, .self, inherits=FALSE))
f <- get(meth, .self)
else
f <- methods:::envRefInferField(.self, meth, getClass(class(.self)), .self)
f(val)
},
add_public_method=function(x) {
"Add a method name to the public methods, so that jRpc can call back intoR."
public_methods <<- c(public_methods, x)
},
##
## Drag and Drop
##
## XXX implement me
##
## setup
##
setup = function(container, handler, action=NULL, ext.args=NULL, ...) {
"Set up widget"
if(!is.null(ext.args))
args$extend(ext.args)
if(missing(container) || is.null(container)) {
message(gettext("No empty containers are allowed"))
stop()
}
container$add_dots(.self, ...)
write_constructor()
container$add(.self, ...)
## if transport & change are identical, we cut down
## by one with this.
if(length(transport_signal) == 1 &&
transport_signal == change_signal)
write_change_transport()
else
write_transport()
if(!missing(handler) & !is.null(handler))
add_handler_changed(handler, action)
},
##
## Cookies
##
## Example:
## w <- gwindow("Cookies")
## g <- ggroup(cont=w)
## w$set_cookie("one", "two")
## b <- gbutton("click me", cont=g, handler=function(h,...) {
## print(b$get_cookies()) ## cookies at time of page initiation, so won't include "one" first time
## })
set_cookie = function(key, value) {
"Set a cookie"
toplevel$cookies[[key]] <<- value
},
get_cookies = function() {
"Return list of cookies"
toplevel$the_request$cookies()
},
##
## The standard gWidgets API for reference methods expects certain reference methods to be defined.
## see BasicInterface for these. That just presents the names, not their implementations. These are
## done here.
##
## Basic methods for gWidgets
get_length=function() 1,
len=function() 1,
## get/set value
coerce_to = function(val, ...) {
"if coerce_with property present, call function on value"
if(is(coerce_with, "uninitializedField") || is.null(coerce_with))
return(val)
coerce_with(val)
},
get_value = function(...) {
"Get main property, Can't query widget, so we store here"
coerce_to(value)
},
set_value=function(value, ...) {
"Set main property, invoke change handler on change"
old_value <- value
value <<- value
if(!identical(old_value, value))
invoke_change_handler()
},
get_index=function(drop=TRUE, ...) {
..index
},
set_index=function(value, ...) {
old_index <- ..index
..index <<- value
if(!identical(old_index, ..index))
invoke_change_handler()
},
get_visible = function() ..visible,
set_visible = function(value) {
..visible <<- as.logical(value)
call_Ext("setVisible", as.logical(value))
},
get_enabled=function() {
..enabled
},
set_enabled = function(value) {
"Disable/enable component"
..enabled <<- value
if(value)
call_Ext("enable")
else
call_Ext("disable")
},
set_tooltip = function(tip) {
"Set tooltip for widget"
call_Ext("setTooltip", tip)
},
set_focus = function(value) {
"focus component"
if(value)
call_Ext("focus")
},
## tag, tag<-
get_attr = function(key) {
"Persistent attribute. If key missing return names, else return value for key"
if(missing(key))
ls(.e)
else
attr(.e, key)
},
set_attr = function(key, value) {
"Set persistent attribute"
attr(.e, key) <<- value
},
set_height = function(px) {
"Set height in pixels"
call_Ext("setHeight", px)
},
set_width = function(px) {
"Set width in pixels"
call_Ext("setWidth", px)
},
set_size = function(val) {
"Set size, specified as width or c(width, height) or list(width,height)"
## may use:
## A Number specifying the new width in the Element's Ext.Element.defaultUnits (by default, pixels).
## A String used to set the CSS width style.
if(!is.list(val)) {
nms <- c("width", "height")[seq_along(val)]
val <- setNames(as.list(val), nms)
}
width <- val$width; height <- val$height
if(is.null(width) && is.null(height))
return()
else if(is.null(height))
set_width(width)
else if(is.null(width))
set_height(height)
else
## depends on class
if(is.numeric(width)) {
call_Ext("setSize", width, height)
} else {
## This allows set_size("100%", "100%")
cmd <- sprintf("%s.setSize({width:'%s',height:'%s'});",
get_id(), width, height)
add_js_queue(cmd)
}
},
get_font = function(...) {
message("Fonts not implemented")
},
set_font = function(value, ...) {
message("Fonts are not implemented. Perhaps using HTML will work.")
},
destroy = function() {
"destroy component"
call_Ext("destroy")
},
update_widget=function(...) {
"Update GUI, in this case recompute layout"
call_Ext("doLayout")
}
))
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.