setUserCallbacks.RdThis function sets user mouse callbacks in R or
rglwidget displays.
Which button should this callback apply to? Can
be numeric from 0:4, or character from "none", "left", "right", "center", "wheel".
Functions to call when events occur. See Details.
Optional block of Javascript code to be included (at the global level).
Which subscene do these callbacks apply to?
Which scene?
Should these changes apply to the scene object?
Should these changes apply to the current device?
If applyToScene is TRUE, this function adds Javascript
callbacks to the scene object.
If applyToDev is TRUE, it adds R
callbacks to the current RGL device.
For Javascript,
the callbacks are specified as strings; these will be
evaluated within the browser in the global context to define the functions,
which will then be called with the Javascript
this object set to the current
rglwidgetClass object.
For R, they may be strings or R functions.
Both options may be TRUE, in which case the
callbacks must be specified as strings which are
both valid Javascript and valid R. The usual way to
do this is to give just a function name, with the
function defined elsewhere, as in the Example below.
The begin and update functions should be
of the form
function(x, y) { ... }. The end function
will be called with no arguments.
The rotate callback can only be set on the
mouse wheel. It is called when the mouse
wheel is rotated. It should be of the form
function(away), where away will be 1
while rotating the wheel “away” from you,
and 2 while rotating it towards you. If rotate
is not set but other callbacks are set on the wheel
“button”, then each click of the mouse wheel
will trigger all start, update,
then end calls in sequence.
The javascript argument is an optional block
of code which will be evaluated once during the
initialization of the widget. It can define functions
and assign them as members of the window object,
and then the names of those functions can be given
in the callback arguments; this allows the callbacks
to share information.
Invisibly returns an rglScene object. This
object will record the changes if applyToScene
is TRUE.
If applyToDev is TRUE, it will also
have the side effect of attempting to install the
callbacks using rgl.setMouseCallbacks
and rgl.setWheelCallback.
setAxisCallbacks for user defined axes.
# This example identifies points in both the rgl window and
# in WebGL
verts <- cbind(rnorm(11), rnorm(11), rnorm(11))
idverts <- plot3d(verts, type = "s", col = "blue")["data"]
# Plot some invisible text; the Javascript will move it
idtext <- text3d(verts[1,,drop = FALSE], texts = 1, adj = c(0.5, -1.5), alpha = 0)
# Define the R functions to use within R
fns <- local({
idverts <- idverts
idtext <- idtext
closest <- -1
update <- function(x, y) {
save <- par3d(skipRedraw = TRUE)
on.exit(par3d(save))
rect <- par3d("windowRect")
size <- rect[3:4] - rect[1:2]
x <- x / size[1];
y <- 1 - y / size[2];
verts <- rgl.attrib(idverts, "vertices")
# Put in window coordinates
vw <- rgl.user2window(verts)
dists <- sqrt((x - vw[,1])^2 + (y - vw[,2])^2)
newclosest <- which.min(dists)
if (newclosest != closest) {
if (idtext > 0)
pop3d(id = idtext)
closest <<- newclosest
idtext <<- text3d(verts[closest,,drop = FALSE], texts = closest, adj = c(0.5, -1.5))
}
}
end <- function() {
if (idtext > 0)
pop3d(id = idtext)
closest <<- -1
idtext <<- -1
}
list(rglupdate = update, rglend = end)
})
rglupdate <- fns$rglupdate
rglend <- fns$rglend
# Define the Javascript functions with the same names to use in WebGL
js <-
' var idverts = %id%, idtext = %idtext%, closest = -1,
subid = %subid%;
window.rglupdate = function(x, y) {
var obj = this.getObj(idverts), i, newdist, dist = Infinity, pt, newclosest;
x = x/this.canvas.width;
y = y/this.canvas.height;
for (i = 0; i < obj.vertices.length; i++) {
pt = obj.vertices[i].concat(1);
pt = this.user2window(pt, subid);
pt[0] = x - pt[0];
pt[1] = y - pt[1];
pt[2] = 0;
newdist = rglwidgetClass.vlen(pt);
if (newdist < dist) {
dist = newdist;
newclosest = i;
}
}
if (newclosest !== closest) {
closest = newclosest
var text = this.getObj(idtext);
text.vertices[0] = obj.vertices[closest];
text.colors[0][3] = 1; // alpha is here!
text.texts[0] = (closest + 1).toString();
text.initialized = false;
this.drawScene();
}
};
window.rglend = function() {
var text = this.getObj(idtext);
closest = -1;
text.colors[0][3] = 0;
text.initialized = false;
this.drawScene();
}'
js <- sub("%id%", idverts, js)
js <- sub("%subid%", subsceneInfo()$id, js)
js <- sub("%idtext%", idtext, js)
# Install both
setUserCallbacks("left",
begin = "rglupdate",
update = "rglupdate",
end = "rglend",
javascript = js)
rglwidget()
3D plot
# This example doesn't affect the rgl window, it only modifies
# the scene object to implement panning
# Define the Javascript functions to use in WebGL
js <-
' window.subid = %subid%;
window.panbegin = function(x, y) {
var activeSub = this.getObj(subid),
viewport = activeSub.par3d.viewport,
activeModel = this.getObj(this.useid(activeSub.id, "model")),
l = activeModel.par3d.listeners, i;
this.userSave = {x:x, y:y, viewport:viewport,
cursor:this.canvas.style.cursor};
for (i = 0; i < l.length; i++) {
activeSub = this.getObj(l[i]);
activeSub.userSaveMat = new CanvasMatrix4(activeSub.par3d.userMatrix);
}
this.canvas.style.cursor = "grabbing";
};
window.panupdate = function(x, y) {
var objects = this.scene.objects,
activeSub = this.getObj(subid),
activeModel = this.getObj(this.useid(activeSub.id, "model")),
l = activeModel.par3d.listeners,
viewport = this.userSave.viewport,
par3d, i, zoom;
if (x === this.userSave.x && y === this.userSave.y)
return;
x = (x - this.userSave.x)/this.canvas.width;
y = (y - this.userSave.y)/this.canvas.height;
for (i = 0; i < l.length; i++) {
activeSub = this.getObj(l[i]);
par3d = activeSub.par3d;
/* NB: The right amount of zoom depends on the scaling of the data
and the position of the observer. This might
need tweaking.
*/
zoom = rglwidgetClass.vlen(par3d.observer)*par3d.zoom;
activeSub.par3d.userMatrix.load(objects[l[i]].userSaveMat);
activeSub.par3d.userMatrix.translate(zoom*x, zoom*y, 0);
}
this.drawScene();
};
window.panend = function() {
this.canvas.style.cursor = this.userSave.cursor;
};
'
js <- sub("%subid%", subsceneInfo()$id, js)
scene <- setUserCallbacks("left",
begin = "panbegin",
update = "panupdate",
end = "panend",
applyToDev = FALSE, javascript = js)
rglwidget(scene)
3D plot