Nothing
#######################################################################
# arulesViz - Visualizing Association Rules and Frequent Itemsets
# Copyrigth (C) 2011 Michael Hahsler and Sudheer Chelluboina
#
# 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 2 of the License, or
# 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, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
## Simple Grid Interactions
## gInteraction class
gInteraction <- function(buttons=data.frame(), buttonCol=NULL) {
if(is.null(buttonCol)) buttonCol <- c("lightblue","orange")
#do some checks
if(!is(buttons, "data.frame")) stop("gInteraction expects a data.frame to specify 'buttons'!")
if(nrow(buttons)>0) {
if(any(is.na(match(c("active","y","x","w","h"),
names(buttons)))))
stop("gInteraction: 'buttons' does not contain all required information!")
for(f in c("x", "y", "w", "h"))
if(!is(buttons[,f], "unit")) buttons[,f] <- I(unit(buttons[,f], "npc"))
}
## last contains the last button pressed
## sel contains the current selection
structure(
list(buttons=buttons, buttonCol=buttonCol,
lastButton=NULL, sel=NULL),
class = "gInteraction"
)
}
print.gInteraction <- function(object) {
writeLines(paste("Object of class 'gInteraction' with",
nrow(object$buttons), "buttons."))
print(t(object$buttons[, "active", drop=FALSE]))
}
## functions for buttons
drawButtons <- function(gI, which=NULL) {
if(nrow(gI$buttons)<1) return(invisible())
if(!is.null(which)) gI$buttons <- gI$buttons[which,]
for(i in 1:nrow(gI$buttons)) {
b <- gI$buttons[i,]
grid.rect(x=b$x, y=b$y, width=b$w, height=b$h,
default.units="npc",
gp=gpar(col=gI$buttonCol[b$active+1L],
fill=gI$buttonCol[b$active+1L]))
grid.text(rownames(b), b$x, y=b$y,
default.units="npc",
gp=gpar(col="black"))
}
}
lastButton <- function(gI, activeOnly=TRUE) {
if(activeOnly && !isActiveButton(gI, gI$lastButton)) return(NULL)
else return(gI$lastButton)
}
selection <- function(gI) gI$sel
isActiveButton <- function(gI, which=NULL) {
## fixme: check if button exists
if(nrow(gI$buttons)<1) return(logical(0))
if(is.null(which)) which <- rownames(gI$buttons)
structure(gI$buttons[which,]$active, names = which)
}
changeButton <- function(gI, which=NULL, to=NULL, redraw=TRUE) {
## fixme: check if button exists
if(nrow(gI$buttons)<1) return(gI$buttons)
if(is.null(which)) which <- rownames(gI$buttons)
if(is.null(to)) to <- !gI$buttons[which,]$active
gI$buttons[which,]$active <- to
if(redraw) drawButtons(gI, which)
gI
}
resetButtons <- function(gI, redraw=TRUE) {
gI <- changeButton(gI, to=FALSE, redraw=redraw)
gI$lastButton <- NULL
gI$sel <- NULL
gI
}
whichButton <- function(gI, location) {
if(nrow(gI$buttons)<1) return(NULL)
## we need npc
location$x <- convertX(location$x, "npc", valueOnly=TRUE)
location$y <- convertY(location$y, "npc", valueOnly=TRUE)
pressed <- NULL
for(i in 1:nrow(gI$buttons)) {
b <- gI$buttons[i,]
if(location$x > convertX(b$x, "npc", valueOnly=TRUE)
-convertX(b$w, "npc", valueOnly=TRUE)/2
&& location$x < convertX(b$x, "npc", valueOnly=TRUE)
+convertX(b$w, "npc", valueOnly=TRUE)/2
&& location$y > convertY(b$y, "npc", valueOnly=TRUE)
-convertY(b$h, "npc", valueOnly=TRUE)/2
&& location$y < convertY(b$y, "npc", valueOnly=TRUE)
+convertY(b$h, "npc", valueOnly=TRUE)/2
) {
pressed <- rownames(b)
gI <- changeButton(gI, pressed)
break
}
}
gI$lastButton <- pressed
gI
}
## Selection classes
gPointSelection <- function(loc, col="red") {
loc <- convertLoc(loc, "native")
name <- paste(c("sel", unlist(loc)), collapse="-")
grid.points(x=loc$x, y=loc$y, pch=3, gp = gpar(col=col, cex=0.5),
name=name)
structure(list(loc=loc, name=name), class = "gPointSelection")
}
gBoxSelection <- function(loc1, loc2, box=TRUE , col="red") {
if(is(loc1, "gPointSelection")) loc1 <- loc1$loc
if(is(loc2, "gPointSelection")) loc2 <- loc2$loc
loc1 <- convertLoc(loc1, "native")
loc2 <- convertLoc(loc2, "native")
name <- paste(c("sel", unlist(loc1), unlist(loc2)), collapse ="-")
locs <- rbind(unlist(loc1), unlist(loc2))
x <- sort(locs[,1])
y <- sort(locs[,2])
## draw box
if(box) grid.rect(x=x[1], y=y[1], width=diff(x), height=diff(y),
default.units = "native", just=c("left", "bottom"),
gp=gpar(col=col, fill=col, alpha=0.1),
name=name)
structure(list(loc=loc1, loc2=loc2, name=name), class = "gBoxSelection")
}
## S3 dispatch for filterSelection
filterSelection <- function(sel, ...) UseMethod("filterSelection")
foo.default <- function(sel, ...) stop("Unknown gSelection type!")
filterSelection.gBoxSelection <- function(sel, x) {
locs <- rbind(unlist(convertLoc(sel$loc, "native", valueOnly=TRUE)),
unlist(convertLoc(sel$loc2, "native", valueOnly=TRUE)))
x[,1] >= min(locs[,"x"]) & x[,1] <= max(locs[,"x"]) &
x[,2] >= min(locs[,"y"]) & x[,2] <= max(locs[,"y"])
}
filterSelection.gPointSelection <- function(sel, x, sensitivity=0.01) {
loc1 <- sel$loc
loc1$x <- loc1$x-unit(sensitivity, "npc")
loc1$y <- loc1$y+unit(sensitivity, "npc")
loc2 <- sel$loc
loc2$x <- loc2$x+unit(sensitivity, "npc")
loc2$y <- loc2$y-unit(sensitivity, "npc")
filterSelection(gBoxSelection(loc1, loc2, box=FALSE), x)
}
clearSelection <- function(sel, redraw=TRUE) {
## make box invisible
## maybe the is a way to use its own viewport for selections
grid.edit(sel$name, gp = gpar(alpha=0), redraw=redraw)
}
## identifyer
gIdentify <- function(gI, checkPlotBoundaries=TRUE) {
location <- grid.locator("npc")
if(!is.null(gI$sel)) {
clearSelection(gI$sel)
gI$sel <- NULL
}
if(checkPlotBoundaries && !insidePlot(location)) return(gI)
gI$sel <- gPointSelection(location)
gI
}
## simple event loop
gGetEvent <- function(gI, box=TRUE, checkPlotBoundaries=TRUE) {
while(TRUE){
location <- grid.locator("npc")
gI <- whichButton(gI, location)
b <- gI$lastButton
if(!is.null(b)) {
## buttons
if(isActiveButton(gI, b)) return(gI)
}else{
## selection
if(checkPlotBoundaries && !insidePlot(location)) next
if(is(gI$sel, "gPointSelection") && !box) {
clearSelection(gI$sel)
gI$sel <- NULL
}
if(is(gI$sel, "gBoxSelection")) {
clearSelection(gI$sel)
gI$sel <- NULL
}
if(is.null(gI$sel)) {
## point
gI$sel <- gPointSelection(location)
}else if(is(gI$sel, "gPointSelection")) {
## box
clearSelection(gI$sel, redraw=FALSE)
gI$sel <- gBoxSelection(gI$sel, location)
}
}
}
}
## location helpers
convertLoc <- function(location, unitTo=NULL, valueOnly = FALSE) {
if(is.null(location)) return(NULL)
if(!is.null(unitTo)) {
location$x <- convertX(location$x, unitTo)
location$y <- convertY(location$y, unitTo)
}
if(valueOnly) location <- lapply(location, as.numeric)
location
}
insidePlot <- function(location) all(sapply(convertLoc(location, "npc",
valueOnly=TRUE), FUN = function(z) z>=0 && z<=1))
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.