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.
scatterplot_arules <- function(rules, measure = c("support","confidence"),
shading = "lift", control = NULL, ...){
control <- .get_parameters(list(
main =paste("Scatter plot for", length(rules), "rules"),
interactive = FALSE,
pch = 22,
cex = .5,
xlim = NULL,
ylim = NULL,
zlim = NULL,
alpha = NULL,
col = hcl(c=0, l=seq(10,80, length.out=100)),
#gray_range = c(.1,.8),
newpage = TRUE,
jitter = 0
), control)
## handle order
if(shading=="order") quality(rules) <- cbind(quality(rules),
order=size(rules))
## call workhorse
scatterplot_int(rules, measure, shading, control, ...)
if(!control$interactive) return(invisible())
## interactive mode
cat("Interactive mode.\nSelect a region with two clicks!\n")
## go to scatterplot viewport
downViewport("scatterplot")
## add buttons
gI <- gInteraction(data.frame(
row.names = c("inspect", "filter","zoom in", "zoom out", "end"),
active = rep(FALSE, 5),
x = c(0.1, 0.3, 0.5, 0.7, 0.9),
y = I(rep(unit(-4.5, "lines"), 5)),
w = I(rep(unit(3.5, "lines"), 5)),
h = I(rep(unit(1, "lines"), 5))
)
)
drawButtons(gI)
q <- quality(rules)[, c(measure[1], measure[2])]
sel_r <- rules
while(TRUE){
gI <- gGetEvent(gI)
b <- lastButton(gI)
if(is.null(b)) next
## actions
if(b=="end") {
## fixme: is a pop missing?
cat("Leaving interactive mode (returning selection).\n")
return(sel_r)
}
if(b=="filter") {
if(is.na(shading) || shading=="order") {
cat("No filtering fo order/no shading!\n")
gI <- changeButton(gI,"filter", FALSE)
next
}
cat("Select minimum", shading,"in colorkey.\n")
seekViewport("colorkey")
location <- grid.locator()
if(insidePlot(location)) {
colSel <- gPointSelection(location)
sel_r <- rules[quality(rules)[,shading]>=
convertLoc(colSel$loc, "native", valueOnly=TRUE)$y]
if(length(sel_r)>1) {
if(is.null(control$xlim)) control$xlim <- range(q[,1])
if(is.null(control$ylim)) control$ylim <- range(q[,2])
ret <- scatterplot_arules(sel_r, measure,
shading, control)
if(!identical(ret, "zoom out")) return(ret)
## replot and reset
scatterplot_int(rules, measure, shading, control, ...)
downViewport("scatterplot")
gI <- resetButtons(gI)
#drawButton(gI)
}else{
cat("Not enough rules pass the filter!\n")
}
}
seekViewport("scatterplot")
gI <- changeButton(gI, "filter", FALSE)
}
if(b=="zoom out") {
## fixme: is a pop missing?
cat("Going up.\n")
return("zoom out")
}
## zoom in if inside selection box
if(b=="zoom in") {
sel <- selection(gI)
if(is.null(sel) || !is(sel, "gBoxSelection")) {
## no box selected!
cat("Select a region first!\n")
gI <- changeButton(gI, "zoom in", FALSE)
next
}
sel_r <- rules[filterSelection(sel, q)]
if(length(sel_r)<2) {
cat("Select more rules!\n")
next
}
## xlim, ylim for zooming makes no sense
control$xlim <- NULL
control$ylim <- NULL
ret <- scatterplot_arules(sel_r, measure,
shading, control)
if(!identical(ret, "zoom out")) return(ret)
## replot and reset
scatterplot_int(rules, measure, shading, control, ...)
downViewport("scatterplot")
gI <- resetButtons(gI)
#drawButton(gI)
}
if(b=="inspect") {
gI <- changeButton(gI, "inspect", FALSE)
sel <- selection(gI)
if(is.null(sel)) {
cat("Nothing selected!\n")
next
}
sel_r <- rules[filterSelection(sel, q)]
if(length(sel_r) > 0) {
cat("\nNumber of rules selected:", length(sel_r),"\n")
inspect(sort(sel_r, by = shading))
cat("\n")
} else cat("No rules selected!\n")
}
## unknown button
next
}
}
scatterplot_int <- function(rules, measure, shading, control, ...){
## reverse colors
colors <- rev(control$col)
q <- quality(rules)
if(control$newpage) grid.newpage()
if(control$interactive) addspace <- 2.5
else addspace <- 0
## main
gTitle(control$main)
## colorkey
if(!is.na(shading)) {
pushViewport(viewport(x=unit(1, "npc")-unit(3+2, "lines"),
y=unit(4+addspace, "lines"),
height=unit(1,"npc")-unit(4+4+addspace, "lines"),
width=unit(2, "lines"),
just = c("left", "bottom")))
## shading range
if(is.null(control$zlim)) range_shading <- range(q[[shading]])
else range_shading <- control$zlim
if(shading=="order") {
max_size <- max(q$order)
min_size <- min(q$order)
steps <- (max_size-min_size)+1
ypos <- rev((1:steps -.5)/steps)
#col <- gray(map(min_size:max_size, control$gray_range))
col <- colors[map_int(min_size:max_size, c(1,length(colors)))]
grid.points(x=rep(0,steps),
y=ypos, pch=control$pch,
gp=gpar(col=NA, fill=rev(col), alpha=control$alpha), size=unit(.5,"npc"))
grid.text(paste("order", max_size:min_size, sep=" "),
x=rep(1,steps), y=ypos)
} else {
if(diff(range_shading) != 0) {
gColorkey(range_shading,
colors,
#gray(1-map(1:20, control$gray_range)),
name="colorkey", label=shading)
}else{
grid.text(paste(shading, "=",
round(range_shading[1],3)), .5,
unit(-1,"lines"))
}
}
## reduce overplotting
o <- order(q[[shading]])
q <- q[o,]
upViewport(1)
}
## scatterplot
pushViewport(viewport(x=unit(4, "lines"),
y=unit(4+addspace, "lines"),
height=unit(1,"npc")-unit(4+4+addspace, "lines"),
width=unit(1,"npc")-unit(4+2+3+2, "lines"),
just = c("left", "bottom")))
x <- q[, c(measure[1], measure[2])]
if(control$jitter >0) {
x[,1] <- jitter(x[,1], factor=control$jitter)
x[,2] <- jitter(x[,2], factor=control$jitter)
}
## get colors for shading
if(!is.na(shading)) {
#col <- 1-map(q[[shading]],
# control$gray_range, from.range=range_shading)
col <- colors[map_int(q[[shading]], c(1,length(colors)), from.range=range_shading)]
## not in range!
#x[is.na(col),] <- c(NA,NA)
#col[is.na(col)] <- 1
#col <- gray(col)
}else col <- 1
gScatterplot(x,
xlim=control$xlim, ylim=control$ylim,
xlab=measure[1], ylab=measure[2],
col=col, cex=control$cex, alpha=control$alpha, pch=control$pch,
name="scatterplot", new=FALSE)
upViewport(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.