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.
grouped_matrix_arules <- function(rules, measure, shading, control=NULL, ...){
## measure controls circle size
## shading controls color
control <- .get_parameters(list(
main =paste("Grouped matrix for", length(rules), "rules"),
k = 20,
aggr.fun=median,
## fix lift so serveral plots are comparable (NA: take max)
max.shading=NA,
interactive = FALSE,
col = hcl(c=0, l=seq(10,80, length.out=100)),
newpage=TRUE
), control)
x <- grouped_matrix_int(rules, measure, shading,
k=control$k,
aggr.fun=control$aggr.fun,
max.shading=control$max.shading,
col=control$col
)
if(!control$interactive) return(invisible(x))
## interactive mode
cat("Interactive mode.\n")
## fix max.shading
control$max.shading <- x$max.shading
seekViewport("grouped_matrix")
## draw buttons
gI <- gInteraction(data.frame(
row.names = c("inspect","zoom in", "zoom out", "end"),
active = rep(FALSE, 4),
x = c(0.3, 0.5, 0.7, 0.9),
y = I(rep(unit(-3, "lines"), 4)),
w = I(rep(unit(3.5, "lines"), 4)),
h = I(rep(unit(1, "lines"), 4))
)
)
drawButtons(gI)
## event loop
while(TRUE) {
gI <- gGetEvent(gI, box=FALSE, checkPlotBoundaries=FALSE)
b <- lastButton(gI)
if(is.null(b)) next
## actions
if(b=="end") {
cat("Leaving interactive mode.\n")
return(rules)
}
if(b=="zoom out") {
cat("Going up.\n")
return("zoom out")
}
select <- convertLoc(selection(gI)$loc,
"native", valueOnly=TRUE)$x
if(is.null(select)) {
cat("Select a LHS first!\n")
gI <- resetButtons(gI)
next
}
select <- round(select)
if(select>0 && select <= control$k) {
select <- get_order(x$order[2])[select]
rulesSelected <- rules[x$cl==select]
}else{
cat("Illegal selection! Choose a LHS.\n")
next
}
if(b=="zoom in") {
if(length(unique(lhs(rulesSelected)))<2) {
cat("Can't zoom in any further. Use inspect!\n")
gI <- changeButton(gI, "zoom in", FALSE)
next
}
cat("Zooming in. This might take a while\n")
ret <- grouped_matrix_arules(rulesSelected, measure,
shading, control, ...)
if(!identical(ret, "zoom out")) return(ret)
## we come back up so replot
plot(x)
seekViewport("grouped_matrix")
gI <- resetButtons(gI)
}
if(b=="inspect") {
cat("Selected rules:\n")
## FIXME: click on bubble
#selectRHS <- round(as.numeric(convertY(location$Y, "native")))
inspect(sort(rulesSelected, by="lift"))
gI <- changeButton(gI, "inspect", FALSE)
}
## nothing else to do
next
}
}
## helper
rowMaxs <- function(x, na.rm=FALSE) apply(x, MARGIN=1, max, na.rm=na.rm)
.aggr <- function(m, cl, aggr.fun = median) {
ma <- matrix(nrow=nrow(m), ncol=0)
for(i in 1:max(cl)) {
ma <- cbind(ma, apply(m[, cl==i, drop=FALSE],
MARGIN=1, aggr.fun , na.rm=TRUE))
}
ma[!is.finite(ma)] <- NA
ma
}
## create an grouped_matrix
grouped_matrix_int <- function(rules, measure, shading,
k=15, aggr.fun=median, max.shading=NA,
col=hcl(c=0, l=seq(10,80, length.out=100))) {
## check k
if(length(unique(lhs(rules)))< k) k <- length(unique(lhs(rules)))
## cluster for shading
s <- rulesAsMatrix(rules, shading)
if(is.na(max.shading)) max.shading <- max(s, na.rm=TRUE)
## fixme: this handling of na for clustering is not great!
s_clust <- s
if(shading=="lift") naVal <- 1
else naVal <- 0
s_clust[is.na(s_clust)] <- naVal
s_clust <- t(s_clust)
if(nrow(s_clust)>k) km <- kmeans(s_clust, k, iter.max=50, nstart=10)$cl
else km <- 1:nrow(s_clust)
sAggr <- .aggr(s, km, aggr.fun)
## reorder for shading
order <- ser_permutation(
order(apply(sAggr, MARGIN=1, FUN=aggr.fun, na.rm=TRUE),
decreasing=TRUE),
order(apply(sAggr, MARGIN=2, FUN=aggr.fun, na.rm=TRUE),
decreasing=TRUE)
)
cl <- vector()
enc <- attr(s, "encoding")
for(i in 1:ncol(enc)) cl[enc[,i]] <- km[i]
## use measure for size
mAggr <- .aggr(rulesAsMatrix(rules, measure[1]), km, aggr.fun)
ret <- list(rules=rules, measure=measure, shading=shading,
cl=cl, km= km, max.shading=max.shading,
aggr.fun=aggr.fun,
order=order, k=k, sAggr=sAggr, mAggr=mAggr)
class(ret) <- "grouped_matrix"
## call plotting work horse
plot(ret, col=col)
ret
}
## display grouped_matrix
plot.grouped_matrix <- function(x, col = hcl(c=0, l=seq(10,80, length.out=100))) {
## circle size
sn <- x$mAggr
## shading
ln <- x$sAggr
## get most important item in the lhs
f <- lapply(split(x$rules, x$cl), FUN = function(r) itemFrequency(lhs(r)))
most_imp_item <- lapply(f, FUN =
function(f) paste(names(which.max(f)), " +",sum(f>0)-1,
sep=""))
grouped_matrix_plot_int(
x = map(sn, c(0.2,1)),
y = map(ln, range = c(1,.2),
from.range = c(min(x$sAggr, na.rm=TRUE), x$max.shading)),
order = x$order,
options = list(
panel = panel.circles,
spacing = -1,
reverse=TRUE,
ylab=paste(#1:max(x$cl), "-",
table(x$cl),
paste('(',most_imp_item, ')', sep='')),
main = paste("Grouped matrix for", length(x$rules), "rules"),
legend = paste("size:",x$measure, "\ncolor:",x$shading),
col = col
)
)
}
## inspect rules inside an grouped_matrix
inspect.grouped_matrix <- function(x, cluster, measure="lift") {
inspect(sort(x$rules[x$cl==cluster], by=measure))
}
## workhorse for plotting
## based on bertinplot in package seriation
grouped_matrix_plot_int <- function (x, y, order = NULL, options = NULL) {
if (!is.matrix(x))
stop("Argument 'x' must be a matrix.")
options <- .get_parameters(list(
panel.function = panel.circles,
reverse = FALSE,
xlab = NULL,
ylab = NULL,
frame = FALSE,
spacing = 0.2,
gp_labels = gpar(cex=.8),
gp_panels = gpar(),
newpage = TRUE,
main = "Grouped matrix",
col = hcl(c=0, l=seq(10,80, length.out=100)),
legend = ""
), options)
if (!is.null(options$xlab)) rownames(x) <- options$xlab
if (!is.null(options$ylab)) colnames(x) <- options$ylab
if (!is.null(order)) {
x <- permute(x, order)
y <- permute(y, order)
}
if (options$reverse) {
x <- t(x)
y <- t(y)
tmp <- options$xlab
options$xlab <- options$ylab
options$ylab <- tmp
order <- rev(order)
}
if (options$newpage) grid.newpage()
## main
gTitle(options$main, name="main")
## legend
downViewport("main")
grid.text(options$legend,
x=unit(1, "npc")-unit(1,"lines"),
y=unit(-2, "lines"),
just=c("right", "top"), gp=options$gp_labels)
### FIXME: a color and size key would be great!
#gColorkey(c(0,1), options$col, label = "FIXME",
# name = "colorkey", gp = gpar())
upViewport(1)
## determine margins
topSpace <- max(stringWidth(rownames(x)))
rightSpace <- max(stringWidth(colnames(x)))
pushViewport(viewport(x=unit(2,"lines"), y=unit(4,"lines"),
just <-c("left","bottom"),
width = unit(1, "npc")-rightSpace-unit(3,"lines"),
height = unit(1, "npc")-topSpace-unit(4+3,"lines"),
#xscale = c(1, nrow(x)), yscale = c(1, ncol(x)),
xscale = c(.5, nrow(x)+.5), yscale = c(.5, ncol(x)+.5),
default.units = "native", gp=options$gp_labels,
name="grouped_matrix"))
## grid
yLabPos <- unit(ncol(x), "native")
xLabPos <- unit(nrow(x), "native")
gp_lines <- gpar(col="gray", lty=3)
for(i in 1:nrow(x)) grid.lines(x = c(i,i),
y=c(1, yLabPos),
default.units = "native", gp=gp_lines)
for(i in 1:ncol(x)) grid.lines(y = c(i,i),
x=c(1, xLabPos),
default.units = "native", gp=gp_lines)
## symbols
for (variable in 1:ncol(x)) {
size <- x[, variable]
shading <- y[, variable]
shading <- options$col[map_int(shading, c(1, length(options$col)), from.range=c(0,1))]
options$panel.function(ncol(x)-variable+1L, size,
shading, options$spacing)
}
## labels
yLabPos <- yLabPos + unit(1, "lines")
xLabPos <- xLabPos + unit(1, "lines")
grid.text(rownames(x), x = 1:nrow(x), y = yLabPos,
rot = 90, just = "left",
default.units = "native")
# gpar is already set in viewport
# gp = options$gp_labels)
grid.text(rev(colnames(x)), x = xLabPos, y = (1:ncol(x)),
just = "left",
default.units = "native")
# gpar is already set in viewport
# gp = options$gp_labels)
## add lhs, rhs
gp <- gpar(fontface = "bold", cex = 1.2)
grid.text("LHS",
x = unit(1, "native")-unit(1,"lines"), y = yLabPos,
rot = 90, just = "left",
default.units = "native",
gp = gp)
grid.text("RHS", x = xLabPos,
y = unit(ncol(x), "native")+unit(1,"lines"),
just = "left",
default.units = "native", gp = gp)
upViewport(1)
}
panel.circles <- function (row, size, shading, spacing)
{
size[size == 0] <- NA
#NAs are white
shading[is.na(shading)] <- 1
grid.circle(x = c(1:length(size)), y=row, r = size/2 * (1 - spacing),
default.units = "native",
gp = gpar(fill = shading, alpha=.9))
}
panel.squares <- function (row, size, shading, spacing)
{
size[size == 0] <- NA
shading[is.na(shading)] <- 1
grid.rect(x = c(1:length(size)), y=row, width = size * (1 - spacing),
height = size * (1 - spacing),
default.units = "native",
gp = gpar(fill = shading, alpha=.9))
}
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.