if (interactive()) {
## 1. A toggle button to draw "Hello world" text.
## constructor function
helloTool <- function(playState) {
quickTool(playState,
label = "Greeting",
icon = "gtk-yes",
tooltip = "Draw 'Hello world' text",
f = hello_handler,
post.plot.action = hello_postplot_action,
isToggle = TRUE)
}
## this is called when the button is clicked
hello_handler <- function(widget, playState) {
## need to re-draw plot to remove label
if (!widget["active"]) {
playReplot(playState)
return()
}
hello_postplot_action(widget, playState)
}
## this is called after the plot is drawn (or re-drawn)
hello_postplot_action <- function(widget, playState) {
## do nothing if the toggle button is off
if (!widget["active"]) return()
## draw text centered on the page
grid.text("Hello world", gp=gpar(cex=2))
}
## add new button to a plot window (the bottom toolbar)
playwith(plot(1:10), bottom=list(helloTool))
## 2. Select subset of data and show marginal histograms.
## It stores state info in the local environment.
## constructor function
subsetTool <- function(playState) {
## set up a list to store state
playState$subsetTool <- list()
quickTool(playState,
label = "Data subset",
icon = "gtk-justify-fill",
tooltip = "Select a subset of data points for stats",
f = subset_handler,
post.plot.action = subset_postplot_action)
}
## this is called when the button is clicked
subset_handler <- function(widget, playState) {
foo <- playSelectData(playState)
if (is.null(foo)) return()
nSubsets <- length(playState$subsetTool)
playState$subsetTool[[nSubsets+1]] <- foo
drawSubsetBox(playState, foo)
}
## draw one subset box with marginal histograms
drawSubsetBox <- function(playState, foo) {
xy <- xyCoords(playState, space=foo$space)
playDo(playState, with(foo, {
xc <- mean(coords$x)
yc <- mean(coords$y)
wd <- abs(diff(coords$x))
ht <- abs(diff(coords$y))
pushViewport(viewport(default.units="native",
x=xc, y=yc, width=wd, height=ht,
xscale=range(coords$x), yscale=range(coords$y),
gp=gpar(alpha=0.3), clip="off"))
grid.rect(gp=gpar(fill="yellow"))
## draw sample size text
grid.text(paste("n=", length(x), sep=""),
x=unit(0.98, "npc"), y=unit(0.98, "npc"),
just=c("right", "top"), gp=gpar(cex=1.5))
## histogram of x values, outside x-axis
h <- hist(x, plot=FALSE)
hval <- unit(4 * h$counts / length(x), "cm")
grid.rect(x=h$breaks[-1], y=unit(0, "npc"),
height=hval, width=diff(h$breaks),
just=c("right", "top"), default.units="native",
gp=gpar(fill="purple"))
## histogram of y values, outside y-axis
h <- hist(y, plot=FALSE)
hval <- unit(4 * h$counts / length(x), "cm")
grid.rect(y=h$breaks[-1], x=unit(0, "npc"),
height=diff(h$breaks), width=hval,
just=c("right", "top"), default.units="native",
gp=gpar(fill="purple"))
popViewport()
}), space=foo$space)
}
## this is called after the plot is drawn (or re-drawn)
subset_postplot_action <- function(widget, playState) {
for (foo in playState$subsetTool)
drawSubsetBox(playState, foo)
}
## add new button to a plot window (the bottom toolbar)
playwith(xyplot(temperature ~ radiation, environmental),
bottom=list(subsetTool))
## 3. A button to interactively add or remove data points.
## constructor function, with handler in-line
addTool <- function(playState) {
quickTool(playState,
label = "Add points",
icon = "gtk-add",
tooltip = "Add data points by clicking",
f = function(widget, playState) repeat {
foo <- playSelectData(playState, prompt=paste(
"Click to add a point.",
"Shift-click to delete.",
"Right-click to stop."))
if (is.null(foo)) return()
xy <- xyData(playState)
if (foo$modifiers & GdkModifierType["shift-mask"]) {
## shift-click: delete data points
xy$x[foo$which] <- NA
xy$y[foo$which] <- NA
} else {
## add data point at click location
xy$x <- c(xy$x, foo$coords$x[1])
xy$y <- c(xy$y, foo$coords$y[1])
}
## store in local environment
playState$env$localxy <- xy
if (playState$is.lattice) {
## lattice plot: use `data` argument
callArg(playState, 1) <- quote(y ~ x)
callArg(playState, "data") <- quote(localxy)
} else {
## otherwise set first argument to plot
callArg(playState, 1) <- quote(localxy)
callArg(playState, "y") <- NULL
}
playReplot(playState)
})
}
ydata <- c(1:4, 2:1, 5:8)
playwith(xyplot(ydata ~ 1:10, type=c("p", "smooth"), pch=8),
left=list(addTool))
## 4. A more complex toolbar item: a "spinbutton" to
## group the data into `n` clusters (in plot or xyplot).
## constructor function
clusterTool <- function(playState) {
spinner <- gtkSpinButton(min=1, max=10, step=1)
spinner["value"] <- 1
gSignalConnect(spinner, "value-changed", cluster_handler,
data=playState)
vbox <- gtkVBox()
vbox$packStart(gtkLabel("Clusters:"))
vbox$packStart(spinner)
foo <- gtkToolItem()
foo$add(vbox)
foo
}
## this is called when the spinner value changes
cluster_handler <- function(widget, playState) {
n <- widget["value"]
xy <- xyCoords(playState)
groups <- NULL
if (n > 1) {
clusts <- kmeans(cbind(xy$x,xy$y), n)
labels <- paste("#", 1:n, "(n = ", clusts$size, ")", sep="")
groups <- factor(clusts$cluster, labels=labels)
}
## avoid a big vector inline in the call, store in local env
if (playState$is.lattice) {
playState$env$auto.groups <- groups
callArg(playState, "groups") <- quote(auto.groups)
} else {
playState$env$auto.groups <- unclass(groups)
callArg(playState, "col") <- quote(auto.groups)
if (is.null(groups)) callArg(playState, "col") <- NULL
}
playReplot(playState)
}
## need to generate random data outside the plot call!
xdata <- rnorm(100)
ydata <- rnorm(100) * xdata / 2
## works with lattice::xyplot
playwith(xyplot(ydata ~ xdata, aspect="iso",
auto.key=list(space="right")),
left=list(clusterTool))
## same tool works with graphics::plot
playwith(plot(ydata ~ xdata), left=list(clusterTool))
}Run the code above in your browser using DataLab