Nothing
##### GObject wrapping #####
# GType support
# currently just converts type name to GType object, if x isn't one already
as.GType <- function(x)
{
mapping <- c("integer" = "gint", "character" = "gchararray", "logical" = "gboolean",
"numeric" = "gdouble", "raw" = "guchar", "externalptr" = "gpointer")
type <- x
if (is.character(type)) {
if (type %in% names(mapping))
type <- mapping[[type]]
type <- try(gTypeFromName(type), TRUE)
if (inherits(type, "try-error")) {
func <- paste(tolower(substring(x, 1, 1)), substring(x, 2), "GetType", sep="")
if (exists(func))
type <- do.call(func, list())
}
}
if (!inherits(type, "GType"))
stop("Cannot convert ", x, " to GType")
type
}
interface <-
function(obj)
{
attr(obj, "interfaces")
}
gTypeGetAncestors <-
function(type)
{
type <- as.GType(type)
.Call("R_getGTypeAncestors", type, PACKAGE = "RGtk2")
}
gTypeGetInterfaces <-
function(type)
{
type <- as.GType(type)
.Call("R_getInterfaces", type, PACKAGE = "RGtk2")
}
gTypeGetClass <-
function(type)
{
type <- as.GType(type)
ancestors <- gTypeGetAncestors(type)
class_ptr <- .Call("R_getGTypeClass", type, PACKAGE = "RGtk2")
class(class_ptr) <- c(paste(ancestors, "Class", sep=""), class(class_ptr))
class_ptr
}
gTypeFromName <-
function(name)
{
.Call("R_gTypeFromName", as.character(name), PACKAGE = "RGtk2")
}
print.GType <- function(x, ...) {
cat("GType identifier for '", attr(x, "name"), "'\n", sep = "")
}
# GSignal support
GSignalFlags <- c(
"run-first" = 1,
"run-last" = 2,
"run-cleanup" = 4,
"no-recurse" = 8,
"detailed" = 16,
"action" = 32,
"no-hooks" = 64
)
GConnectFlags <- c(
"after" = 1,
"swapped" = 2
)
connectSignal <- gSignalConnect <-
function(obj, signal, f, data = NULL, after = FALSE, user.data.first = FALSE)
{
useData <- missing(data) == FALSE
checkPtrType(obj, "GObject")
if(is.null(f))
stop("You've specified NULL as the action in setting a callback. Did you mean to use quote()")
if(is.expression(f)) {
f <- f[[1]]
}
if(!( is.expression(f) || is.function(f) || is.call(f))) {
stop(paste("Callback action must be an expression, a call or a function, but instead is of type", typeof(f), ". Did you forget to use quote()"))
}
invisible(.Call("R_connectGSignalHandler", obj, f, as.character(signal), data,
useData, as.logical(after), as.logical(user.data.first),
PACKAGE = "RGtk2"))
}
print.CallbackID <- function(x, ...)
cat("Connection to '", names(x), "': ", x, "\n", sep = "")
gSignalHandlerDisconnect <-
function(obj, id)
{
checkPtrType(obj, "GObject")
.Call("R_disconnectGSignalHandler", obj, as.integer(id), PACKAGE = "RGtk2")
}
gSignalHandlerBlock <-
function(obj, id)
{
checkPtrType(obj, "GObject")
.Call("R_blockGSignalHandler", obj, as.integer(id), TRUE, PACKAGE = "RGtk2")
}
gSignalHandlerUnblock <-
function(obj, id)
{
checkPtrType(obj, "GObject")
.Call("R_blockGSignalHandler", obj, as.integer(id), FALSE, PACKAGE = "RGtk2")
}
gSignalStopEmission <-
function(obj, signal, detail = NULL)
{
if (!is.null(detail))
signal <- paste(signal, detail, sep="::")
.Call("R_gSignalStopEmission", obj, signal, PACKAGE = "RGtk2")
}
gObjectGetSignals <-
function(obj)
{
checkPtrType(obj, "GObject")
type <- class(obj)[1]
els <- gTypeGetSignals(type)
els
}
gTypeGetSignals <-
function(type)
{
if(is.character(type))
type <- as.GType(type)
checkPtrType(type, "GType")
els <- .Call("R_getGSignalIdsByType", type, PACKAGE = "RGtk2")
names(els) <- sapply(els, function(x) names(x))
els
}
gSignalGetInfo <-
function(sig)
{
checkPtrType(sig, "GSignalId")
.Call("R_getGSignalInfo", sig, PACKAGE = "RGtk2")
}
gSignalEmit <-
function(obj, signal, ..., detail = NULL)
{
checkPtrType(obj, "GObject")
args <- list(...)
signal <- as.character(signal)
if (!is.null(detail))
signal <- paste(signal, detail, sep="::")
.RGtkCall("R_gSignalEmit", obj, signal, args, PACKAGE = "RGtk2")
}
# GObject properties
names.GObject <-
#
# return a vector of the names of the properties
# available for the given GObject, collapsing over
# all the inherited classes and removing the class::
# prefix.
#
function(x)
{
names(gObjectGetPropInfo(x, parents = TRUE, collapse = TRUE))
}
gObjectGetPropInfo <-
function(obj, parents = TRUE, collapse = TRUE)
{
checkPtrType(obj, "GObject")
real_classes <- class(obj)[-length(class(obj))]
props <- lapply(real_classes, gTypeGetPropInfo)
if (parents && collapse)
return(props[[1]])
# props is a list containing the properties for each class in the hierarchy
# as well as the parents of that class. We must remove the duplicates.
n_dups <- c(sapply(props, length), 0)
stripped <- lapply(1:length(props), function(ind)
if (n_dups[ind+1] > 0)
props[[ind]][-(1:n_dups[ind+1])]
else props[[ind]])
names(stripped) <- real_classes
result <- stripped
if (!parents)
result <- stripped[[1]]
result
}
gTypeGetPropInfo <-
function(type)
{
type <- as.GType(type)
if (!("GObject" %in% gTypeGetAncestors(type)))
stop("Cannot retrieve properties, because type is not a GObject type")
.RGtkCall("R_getGTypeParamSpecs", type)
}
gObjectGet <-
function(obj, ..., drop = T)
{
checkPtrType(obj, "GObject")
props <- .Call("R_getGObjectProps", obj, as.character(c(...)), PACKAGE = "RGtk2")
if (drop && length(props) == 1)
props[[1]]
else props
}
"[.GObject" <-
function(obj, value, ...)
{
gObjectGet(obj, c(value, ...))
}
gObjectSet <-
function(obj, ...)
{
args <- list(...)
checkPtrType(obj, "GObject")
if(any(names(args) == ""))
stop("All values must have a name")
invisible(.RGtkCall("R_setGObjectProps", obj, args, PACKAGE = "RGtk2"))
}
"[<-.GObject" <-
function(obj, propNames, value)
{
value <- list(value)
names(value) <- propNames
.RGtkCall("R_setGObjectProps", obj, value, PACKAGE = "RGtk2")
obj
}
gObject <- gObjectNew <-
function(type, ...)
{
args <- list(...)
type <- as.GType(type)
if (!("GObject" %in% gTypeGetAncestors(type)))
stop("GType must inherit from GObject")
if(any(names(args) == ""))
stop("All values must have a name")
invisible(.RGtkCall("R_gObjectNew", type, args, PACKAGE = "RGtk2"))
}
## Parameter specifications
GParamFlags <- c("readable" = 1, "writable" = 2, "construct" = 4,
"construct-only" = 8, "lax-validation" = 16, "static-name" = 32,
"private" = 32, "static-nick" = 64, "static-blurb" = 128)
gParamSpec <-
function(type, name, nick = NULL, blurb = NULL, flags = NULL, ...)
{
# map type to param spec type, pass on the args
spec <- list(name = name, nick = nick, blurb = blurb, flags = flags, ...)
if (type == "integer")
param_type <- "GParamInt"
else if (type == "numeric")
param_type <- "GParamDouble"
else if (type == "logical")
param_type <- "GParamBoolean"
else if (type == "character")
param_type <- "GParamString"
else if (type == "raw")
param_type <- "GParamUChar"
else if (type == "R")
param_type <- "RGtkParamSexp"
else param_type <- type
class(spec) <- c(param_type)
as.GParamSpec(spec)
}
as.GParamSpec <-
function(x)
{
type <- sub(".*Param", "", class(x)[1])
fields <- NULL
common_fields <- c("name", "nick", "blurb", "flags")
if (type %in% c("Boolean", "String", "Unichar"))
fields <- "default.value"
else if (type == "Flags")
fields <- c("flags.type", "default.value")
else if (type == "Enum")
fields <- c("enum.type", "default.value")
else if (type %in% c("Char", "UChar", "Int", "UInt", "ULong", "Long", "UInt64",
"Int64", "Float", "Double"))
fields <- c("minimum", "maximum", "default.value")
else if (type == "Param")
fields <- "param.type"
else if (type == "Boxed")
fields <- "boxed.type"
else if (type == "Object")
fields <- "object.type"
else if (type == "ValueArray")
fields <- "element.spec"
else if (type == "GType")
fields <- "is.a.type"
else if (type == "Sexp")
fields <- c("s.type", "default.value")
x <- as.struct(x, c(class(x)[1], "GParamSpec"), c(common_fields, fields))
x[[1]] <- as.character(x[[1]])
x[[2]] <- as.character(x[[2]])
x[[3]] <- as.character(x[[3]])
if (is.null(x[[4]]))
x[[4]] <- sum(GParamFlags[c("readable", "writable", "construct")])
if (type == "Boolean")
x[[5]] <- ifelse(is.null(x[[5]]), F, as.logical(x[[5]]))
else if (type == "String")
x[[5]] <- ifelse(is.null(x[[5]]), "", as.character(x[[5]]))
else if (type == "Unichar")
x[[5]] <- ifelse(is.null(x[[5]]), as.integer(0), as.integer(x[[5]]))
else if (type %in% c("Flags", "Enum", "Param", "Boxed", "Object", "GType"))
x[[5]] <- as.GType(x[[5]])
else if (type %in% c("Char", "UChar")) {
x[[5]] <- ifelse(is.null(x[[5]]), 0, as.raw(x[[5]]))
x[[6]] <- as.raw(x[[6]])
x[[7]] <- as.raw(x[[7]])
} else if (type == "Int") {
x[[5]] <- ifelse(is.null(x[[5]]), 0, as.integer(x[[5]]))
x[[6]] <- as.integer(x[[6]])
x[[7]] <- as.integer(x[[7]])
} else if (type %in% c("UInt", "ULong", "Long", "UInt64", "Int64", "Float", "Double")) {
x[[5]] <- ifelse(is.null(x[[5]]), 0, as.numeric(x[[5]]))
x[[6]] <- as.numeric(x[[6]])
x[[7]] <- as.numeric(x[[7]])
} else if (type == "ValueArray")
x[[5]] <- as.GParamSpec(x[[5]])
else if (type == "Sexp") {
# if there's no type, try to get it from the default value
if (is.null(x[[5]]) && !is.null(x[[6]]))
x[[5]] <- typeof(x[[6]])
else if (is.null(x[[5]])) # otherwise, fallback to ANY
x[[5]] <- "any"
# if there's no default value, create one given the type (ANY->NULL)
anysxp <- .RGtkCall("getNumericType", "any")
if (is.null(x[[6]]) && x[[5]] != "any" && x[[5]] != anysxp)
x[[6]] <- new(x[[5]])
# if type is numeric, assume it's a type code, otherwise assume it's a type
# name and ask the C side to query the for the code
if (!is.numeric(x[[5]]))
x[[5]] <- .RGtkCall("getNumericType", x[[5]])
}
return(x)
}
gObjectSetData <-
function(obj, key, data = NULL)
{
checkPtrType(obj, "GObject")
key <- as.character(key)
w <- .RGtkCall("S_g_object_set_data", obj, key, data, PACKAGE = "RGtk2")
return(invisible(w))
}
gObjectGetData <-
function(obj, key)
{
checkPtrType(obj, "GObject")
key <- as.character(key)
w <- .RGtkCall("S_g_object_get_data", obj, key, PACKAGE = "RGtk2")
return(w)
}
# Methods
parentHandler <-
function(method, obj = NULL, ...)
{
# untested stuff
# chaining up is only allowed/makes sense from inside a GObject implementation
stopifnot(implements(obj, "SGObject"))
if (is.null(attr(obj, ".private")))
stop("Parent methods should only be invoked within the instance")
if (FALSE) { # stuff that might work some day
parent_call <- sys.call(sys.parent(1))
parent_frame <- parent.frame()
formal_args <- formals(parent_call[[1]])
if (missing(obj))
obj <- get(names(formal_args)[1], parent_frame)
args <- list(...)
formal_names <- names(formal_args)[-1]
missing_names <- formal_names[!(formal_names %in% names(args))]
unnamed <- sapply(names(args), nchar) == 0
names(args)[unnamed] <- missing_names[seq(along=unnamed)]
missing_names <- missing_names[!(missing_names %in% names(args))]
args[missing_names] <- lapply(missing_names, get, parent_frame)
parent <- .Call("S_g_object_parent", obj, PACKAGE = "RGtk2")
if (!is.null(parent) && is.function(try(parent[[method]], T)))
fun <- parent[[method]]
else { # fallback to calling a wrapper of the C virtual
fun <- eval(substitute(gTypeGetClass(class(obj)[2])$sym, list(sym=method)))
args <- c(obj, args)
}
do.call(fun, args)
}
# assume looking for a function, does not make sense for fields
#function(...) {
# is this a function defined by a parent R class?
parent <- .Call("S_g_object_parent", obj, PACKAGE = "RGtk2")
if (!is.null(parent) && is.function(try(parent[[method]], T))) {
parent[[method]](...)
} else # fallback to calling a wrapper of the C virtual
eval(substitute(gTypeGetClass(class(obj)[2])$sym(obj, ...),
list(obj=obj,sym=method)))
#}
}
"$.<invalid>" <-
function(obj, name)
{
stop("attempt to call '", name, "' on invalid reference '", deparse(substitute(obj)), "'", call.=FALSE)
}
"$.GObject" <- "$.RGtkObject" <-
function(x, member)
{ # try for a declared method first, else fall back to member
result <- try(.getAutoMethodByName(x, member, parent.frame()), T)
if (inherits(result, "try-error"))
result <- x[[member]]
result
}
.getAutoMemberByName <-
function(obj, name)
{
# if we have an SGObject, try private env (includes protected) then public
stopifnot(implements(obj, "SGObject"))
attrs <- attributes(obj)
has_private <- ".private" %in% names(attrs)
if (has_private)
member <- try(get(name, attrs$.private), T)
if (!has_private || inherits(member, "try-error"))
member <- try(get(name, attrs$.public), T)
if (is.function(member)) {
# we need to add private env if it's not there
if (!has_private)
obj <- .Call("S_g_object_private", obj, PACKAGE="RGtk2")
function(...) member(obj, ...)
}
else member
}
.getAutoMethodByName <-
function(obj, name, where)
{
classes <- c(attr(obj, "interfaces"), class(obj))
sym <- paste(tolower(substring(classes, 1, 1)), substring(classes, 2), toupper(substring(name, 1, 1)),
substring(name,2), sep="")
which <- sapply(sym, exists, where)
if(!any(which))
stop(paste("No such method", name, "for classes", paste(class(obj), collapse=", ")))
method <- get(sym[which][1], where)
function(...) method(obj, ...)
#sym <- as.name(sym[which][1])
# evaluate it to turn it into a function
# and also get the correct environment
#eval(substitute( function(...) {
# sym(obj, ...)
# }, list(obj=obj,sym=sym)))
}
# Comparing pointers
.comparePointers <- function(x, y) {
.Call("comparePointers", x, y, PACKAGE="RGtk2")
}
"==.RGtkObject" <-
function(x, y) {
.comparePointers(x, y)
}
# Fields
"$<-.GObject" <- "[[<-.GObject" <-
function(obj, member, value)
{ # first try for prop, then fall back to private env
# this encourages the setting of properties, rather than using the back door
result <- try(obj[member] <- value, T)
if (inherits(result, "try-error")) {
env <- attr(obj, ".private")
if (is.null(env))
stop("Cannot find '", member, "' to set in ", paste(class(obj),collapse=", "))
protected_env <- parent.env(env)
if (exists(member, protected_env))
env <- protected_env
assign(member, value, env)
}
obj
}
"[[.GObject" <-
function(obj, member, where = parent.frame())
{
# check SGObject environments first, then fall back to field/property
val <- try(.getAutoMemberByName(obj, member), TRUE)
# check for C field (fast), then GObject prop
if (inherits(val, "try-error"))
val <- try(NextMethod("[[", where = where), TRUE)
if (inherits(val, "try-error"))
val <- try(obj$get(member), TRUE)
if (inherits(val, "try-error"))
stop("Cannot find '", member, "' for classes ", paste(class(obj), collapse=", "))
val
}
"[[.RGtkObject" <-
#
#
#
function(x, field, where = parent.frame())
{
fun <- try(.getAutoElementByName(x, field, error = FALSE, where = where),
TRUE)
if (!inherits(fun, "try-error"))
val <- fun(x)
else stop("Cannot find '", field, "' for classes ",
paste(class(x), collapse=", "))
return(val)
}
# C field setting is not allowed
if (FALSE) {
"[[<-.RGtkObject" <-
#
#
#
function(x, name, value)
{
sym <- try(.getAutoElementByName(x, name, op = "Set", error = FALSE))
if (!inherits(sym, "try-error"))
val <- eval(substitute(sym(x, value), list(sym=sym)))
else if(inherits(x, "GObject"))
val <- x$set(name)
else val <- sym
return(val)
}
}
.getAutoElementByName <-
function(obj, name, op = "Get", error = TRUE, where = parent.frame())
{
sym <- paste("S_", class(obj), op,
toupper(substring(name, 1, 1)), substring(name, 2), sep = "")
sym <- Find(function(x) is.loaded(x, PACKAGE = "RGtk2"), sym)
if(is.null(sym)) {
message <- paste("Could not", op, "field", name, "for classes",
paste(class(obj), collapse=", "))
if(error)
stop(message)
else {
v <- paste(message)
class(v) <- "try-error"
return(v)
}
}
function(obj) .Call(sym, obj, PACKAGE = "RGtk2")
}
# This attempts to coerce an R object to an RGClosure that is understood on the C side
as.GClosure <-
function(x)
{
if (inherits(x, "GClosure"))
x <- toRGClosure(x)
else x <- as.function(x)
class(x) <- "RGClosure"
x
}
# This attempts to convert a C GClosure to an R closure
# (with extra ref attribute that prevents recursion on C side)
toRGClosure <-
function(c_closure)
{
checkPtrType(c_closure, "GClosure")
closure <- function(...) {
.RGtkCall("R_g_closure_invoke", c_closure, c(...), PACKAGE = "RGtk2")
}
attr(closure, "ref") <- c_closure
closure
}
# virtuals for GObject
assign("GObject", c("set_property", "get_property"), .virtuals)
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.