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.
paracoord_arules <- function(x, measure= "support", shading = "lift",
control=list(), ...) {
control <- .get_parameters(list(
main =paste("Parallel coordinates plot for", length(x), "rules"),
reorder = FALSE,
interactive = FALSE,
gp_labels = gpar(),
newpage = TRUE,
alpha = NULL,
quality = 2,
verbose = FALSE
), control)
## remove short rules
x <- x[size(x)>1]
## sort rules to minimize occlusion
x <- sort(x, by=shading, decreasing = FALSE)
lwd <- map(quality(x)[[measure]], c(1,5))
col <- gray(map(quality(x)[[shading]], c(0.8,0.1)))
l <- LIST(lhs(x))
r <- LIST(rhs(x))
u <- union(unlist(l), unlist(r))
n <- length(u)
maxLenLHS <- max(sapply(l, length))
pl <- t(sapply(l, FUN = function(x) {
x <- match(x, u)
# reordering items of antecedent
#if(control$reorder) x <- sort(x, decreasing = TRUE)
length(x) <- maxLenLHS
rev(x) ## so NAs are to the left (we could also use na.last for sort)
}))
## make the items increasing
pl <- t(apply(pl, MARGIN=1, sort, na.last=FALSE, decreasing=FALSE))
## RHS is always 1 for now
pr <- sapply(r, FUN = function(x) match(x, u))
m <- cbind(pl,pr)
if(control$reorder) {
count <- countCrossovers(m)
noswapcount <- 0
order <- seq(n)
while(noswapcount < control$quality*n) {
if(control$verbose) {
cat("Current best count...", count,
"(no swaps for",noswapcount,"/",control$quality*n,"tries)\n")
}
### try a random swap
ij <- sample(n,2)
i <- ij[1]
j <- ij[2]
order_tmp <- order
order_tmp[j] <- order[i]
order_tmp[i] <- order[j]
pl_tmp <- matrix(order_tmp[pl], nrow=nrow(pl))
pl_tmp <- t(apply(pl_tmp, MARGIN=1, sort, na.last=FALSE, decreasing=FALSE))
pr_tmp <- order_tmp[pr]
count_tmp <- countCrossovers(cbind(pl_tmp, pr_tmp))
if(count_tmp < count) {
noswapcount <- 0
order <- order_tmp
count <- count_tmp
}else{
noswapcount <- noswapcount+1
}
}
pl <- matrix(order[pl], nrow=nrow(pl))
pl <- t(apply(pl, MARGIN=1, sort, na.last=FALSE, decreasing=FALSE))
pr <- order[pr]
m <- cbind(pl,pr)
colnames(m) <- c(ncol(pl):1, "rhs")
u <- u[order]
}
## start plot
if(control$newpage) grid.newpage()
## main
gTitle(control$main)
## plot
leftSpace <- max(stringWidth(u))
pushViewport(viewport(x=unit(2,"lines")+leftSpace, y=unit(4,"lines"),
just = c("left","bottom"),
width = unit(1, "npc")-unit(4,"lines")-leftSpace,
height = unit(1, "npc")-unit(4+4,"lines"),
default.units = "native", gp=control$gp_labels,
name="paracoord"))
gParacoords(m, xlab="Position", discreteNames = u,
col=col, lwd=lwd, arrowPos =ncol(m),
gp_lines=gpar(alpha=control$alpha))
}
paracoord_items <- function(x, measure= "support", shading = NULL,
control=list(), ...) {
control <- .get_parameters(list(
main =paste("Parallel coordinates plot for",
length(x), "itemsets"),
reorder = FALSE,
interactive = FALSE,
gp_labels = gpar(),
newpage = TRUE,
alpha = NULL
), control)
## remove single items
x <- x[size(x)>1]
## sort to minimize occlusion
x <- sort(x, by=measure, decreasing = FALSE)
lwd <- map(quality(x)[[measure]], c(1,5))
#col <- gray(map(quality(x)[[shading]], c(0.8,0.1)))
col <- NULL
i <- LIST(items(x))
u <- unique(unlist(i))
## reorder
## maybe we can do better here (reorder items and positions)
maxLen <- max(size(x))
m <- t(sapply(i, FUN = function(x) {
x <- match(x, u)
if(control$reorder) x <- sort(x, decreasing = TRUE)
length(x) <- maxLen
x
}))
colnames(m) <- c(1:ncol(m))
## start plot
if(control$newpage) grid.newpage()
## main
gTitle(control$main)
## plot
leftSpace <- max(stringWidth(u))
pushViewport(viewport(x=unit(2,"lines")+leftSpace, y=unit(4,"lines"),
just = c("left","bottom"),
width = unit(1, "npc")-unit(4,"lines")-leftSpace,
height = unit(1, "npc")-unit(4+4,"lines"),
default.units = "native", gp=control$gp_labels,
name="paracoord"))
gParacoords(m, xlab="Position", discreteNames = u,
col=col, lwd=lwd,
gp_lines=gpar(alpha=control$alpha))
}
#no use of this funtion can be deleted later
makeMatrix <- function(l=NULL, r=NULL, u=NULL, control=NULL)
{
maxLenLHS <- max(sapply(l, length))
pl <- t(sapply(l, FUN = function(x) {
x <- match(x, u)
if(control$reorder) x <- sort(x, decreasing = TRUE)
length(x) <- maxLenLHS
rev(x) ## so NAs are to the left (we could also use na.last for sort)
}))
## RHS is always 1 for now
pr <- sapply(r, FUN = function(x) match(x, u))
m <- cbind(pl, pr)
colnames(m) <- c(ncol(pl):1, "rhs")
m
}
swap <- function(v=NULL, i=NULL, j=NULL)
{
temp <- v[i]
v[i] <- v[j]
v[j] <- temp
v
}
countCrossovers <- function(m=NULL)
{
count <- 0
for(i in 1:(ncol(m)-1))
{
for(j in 2:nrow(m))
{
if(!is.na(m[j,i]))
{
x <- m[j,i]
y <- m[j,i+1]
o <- which(m[1:j-1,i+1] > y)
#print(o)
# p <- which(m[1:j-1,i] < x)
#print(p)
l <- which(m[1:j-1,i] > x)
#print(l)
if(as.integer(length(o)) != 0)
{
for(k in 1:length(o))
{
#print(paste(o[k],i, sep=","))
if(!is.na(m[o[k],i]))
if(m[o[k],i] < x)
{
# print(paste(o[k],i, sep=","))
count <- count+1
}
}
}
if(as.integer(length(l)) != 0)
{
for(k in 1:length(l))
{
if(!is.na(m[l[k],i+1]))
if(m[l[k],i+1] < y)
count <- count+1
}
}
}
}
}
count
}
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.