constructCondition <- function (hdata) {
library(reshape2)
library(plyr)
hdata$ID <- 1:nrow(hdata)
res.melt <- melt(hdata,id.var="ID")
res.melt$cond <- with(res.melt, sprintf("(%s == '%s')", variable, value))
NAs <- which(is.na(res.melt$value))
res.melt$cond[NAs] <- sprintf("is.na(%s)", res.melt$variable[NAs])
condis <- ddply(res.melt, .(ID), summarize, condi = paste("(", paste(cond, collapse=" & "), ")"))
paste(condis$condi, collapse="|")
}
paste_formula <- function(form) {
# form has pieces wt, marg and cond
# output is character - needs to be converted to formula afterwards
wtStr <- ""
if (length(form$wt) > 0)
wtStr <- form$wt[1]
margStr <- "1"
if (length(form$marg) > 0)
margStr <- paste(form$marg,collapse="+")
condStr <- ""
if (length(form$cond) > 0)
condStr <- paste("|", paste(form$cond, collapse="+"))
formstring <- paste(wtStr,"~", margStr, condStr)
return(formstring)
}
find_x_label <- function(form, divider) {
parsed <- productplots::parse_product_formula(form)
vars <- c(parsed$marg, parsed$cond)
xlabs <- rev(vars[grep("h",divider)])
paste(xlabs,"", collapse="+ ")
}
find_y_label <- function(form, divider) {
parsed <- productplots::parse_product_formula(form)
vars <- c(parsed$marg, parsed$cond)
ylabs <- rev(vars[grep("v",divider)])
paste(ylabs,"", collapse="+ ")
}
settitle <- function(form) {
# browser()
if (!is.null(form))
paste_formula(productplots::parse_product_formula(form))
}
extractVars <- function(form) {
setdiff(unlist(parse_product_formula(form)), "1")
}
##' Mosaic plot.
##' Create a mosaicplot using a formula (as described in prodplot)
##'
##' Interactive elements for mosaic plots are arrow keys for navigating through the mosaic hierarchy:
##' arrow up reduces complexity of the mosaic by one variable, arrow down increases the complexity by one, if possible.
##' Arrow left and right rotate a previously included variable into the last split position.
##' Conditioning/Unconditioning is done with keys 'C' and 'U'
##' Keys 'B' and 'S" switch to bar and spine representation, respectively
##' Key 'R' rotates the last split variable between horizontal and vertical display.
##'
##' @param data a mutaframe which is typically built upon a data frame
##' along with several row attributes
##' @param formula a formula to describe order in which variables go into the mosaicplot. The first variables are the ones visually most important, i.e. Y ~ X1 + X2 + X3 first splits according to X3, then according to X2, then according to X1
##' @param divider structure of the split in each direction. Choices are "hbar", "vbar" for horizontal/vertical barcharts, "hspine", "vspine" for horizontal/vertical spineplots.
##' @param cascade parameter for prodplot in package productplots
##' @param scale_max parameter for prodplot in package productplots
##' @param na.rm handling of missing values, defaults to FALSE
##' @param subset parameter for prodplot -
##' @param colour fill colour of rectangles - only used if colour is not used in the data
##' @param main parameter for prodplot
##' @param ...
##' @return NULL
##' @author Heike Hofmann
##' @export
##' @example inst/examples/qmosaic-ex.R
qmosaic <- function(data, formula, divider = productplots::mosaic(), cascade = 0, scale_max = TRUE, na.rm = FALSE, subset=NULL, colour="grey30", main=NULL, ...) {
data = check_data(data)
b = brush(data)
b$select.only = TRUE; b$draw.brush = FALSE # a selection brush
z = as.list(match.call()[-1])
s = attr(data, 'Scales')
var = extractVars(z$formula)
redoHiliting <- FALSE
redoColor <- FALSE
meta =
Mosaic.meta$new(var=var, form = as.formula(z$formula), origForm=as.formula(z$formula),
xlim=c(0,1), ylim=c(0,1), alpha = 1,
inactiveVar=NULL, inactiveDivider=NULL,
active = TRUE, main=settitle(z$formula), ylab="", xlab="", main=main)
if(is.null(divider)) divider = mosaic()
if (!is.character(divider)) {
form = parse_product_formula(z$formula)
splits = c(form$marg, form$cond)
divider = divider(length(splits))
}
meta$divider = divider
meta$origDivider = meta$divider
recalcColor = function() {
redoColor <<-FALSE
idx = visible(data)
if (sum(idx) > 0) {
df <- data.frame(data[idx,])
form <- parse_product_formula(meta$form)
df$wt <- 1
if (length(form$wt) == 1) df$wt <- df[,form$wt]
var <- unlist(c(form$marg, form$cond))
cols <- ddply(df, var, function(x) {
dc <- xtabs(wt~.color, data=x, exclude=NULL)/sum(x$wt)
dc[is.nan(dc)] <- 0
dc
})
require(reshape2)
cm <- melt(cols, id.var=var)
names(cm) <- gsub("variable", ".color",names(cm))
names(cm) <- gsub("value", "cval",names(cm))
colID <- grep(".color", names(meta$mdata))
if (length(colID) >0) meta$mdata <- meta$mdata[-colID]
meta$cdata <- merge(meta$mdata, cm, by=var)
## set order of the colors here
# browser()
meta$cdata$cid <- as.numeric(meta$cdata$.color)
meta$cdata <- ddply(meta$cdata, var, transform,
cval=cumsum(cval[order(cid)]),
.color=.color[order(cid)])
} else {
meta$cdata <- meta$mdata
meta$cid <- as.numeric(meta$cdata$.color)
meta$cdata$cval <- 0
}
split <- meta$divider[1]
if (length(grep("v", split))>0) split <- "hspine"
else split <- "vspine"
if (split =="vspine") {
meta$cdata$t = with(meta$cdata, b + (t-b)*cval)
meta$cdata <- ddply(meta$cdata, var, transform,
b = c(b[1], t[-length(t)]))
} else {
meta$cdata$r = with(meta$cdata, l + (r-l)*cval)
meta$cdata <- ddply(meta$cdata, var, transform,
l = c(l[1], r[-length(r)]))
}
}
recalcHiliting = function() {
redoHiliting <<-FALSE
idx = visible(data)
if (sum(idx) > 0) {
df <- data.frame(data[idx,])
form <- parse_product_formula(meta$form)
df$wt <- 1
if (length(form$wt) == 1) df$wt <- df[,form$wt]
var <- unlist(c(form$marg, form$cond))
hils <- ddply(df, var, summarize, hilited = sum(wt[.brushed])/sum(wt))
hils$hilited[is.nan(hils$hilited)] <- 0
hilID <- grep("hilited", names(meta$mdata))
if (length(hilID) >0) meta$mdata <- meta$mdata[-hilID]
meta$hdata <- merge(meta$mdata, hils, by=var)
} else {
meta$hdata <- meta$mdata
meta$hdata$hilited <- 0
}
split <- meta$divider[1]
if (length(grep("v", split))>0) split <- "hspine"
else split <- "vspine"
if (split =="vspine") {
meta$hdata$t = with(meta$hdata, b + (t-b)*hilited)
} else
meta$hdata$r = with(meta$hdata, l + (r-l)*hilited)
}
setylab <- function() {
parsed <- parse_product_formula(meta$form)
vars <- c(parsed$marg, parsed$cond)
yvars <- rev(vars[grep("v",meta$divider)])
meta$yat = seq(0,1, length=5)
meta$ylabels = round(seq(0,1, length=5),2)
if (length(yvars)>=1) {
yvar <- yvars[1]
df <- subset(meta$mdata, l==0)
at <- ddply(df, yvar, summarize, yat=(min(b)+max(t))/2)
meta$yat = at$yat
meta$ylabels = at[,1]
}
}
setxlab <- function() {
parsed <- parse_product_formula(meta$form)
vars <- c(parsed$marg, parsed$cond)
xvars <- rev(vars[grep("h",meta$divider)])
meta$xat = seq(0,1, length=5)
meta$xlabels = round(seq(0,1, length=5), 2)
if (length(xvars)>=1) {
xvar <- xvars[1]
# browser()
df <- subset(meta$mdata, b==0)
at <- ddply(df, xvar, summarize, xat=(min(l)+max(r))/2)
meta$xat = at$xat
meta$xlabels = at[,1]
}
}
recalc = function() {
idx = visible(data)
df <- data.frame(data[idx,])
mdata <- prodcalc(df, meta$form, meta$divider, cascade, scale_max, na.rm = na.rm)
meta$mdata <- subset(mdata, level==max(mdata$level), drop=FALSE)
meta$xlab <- find_x_label(meta$form, meta$divider)
meta$ylab <- find_y_label(meta$form, meta$divider)
setxlab()
setylab()
recalcColor()
recalcHiliting()
}
compute_coords = function() {
meta$limits = extend_ranges(cbind(meta$xlim, meta$ylim))
meta$minor = "xy"
recalc()
}
compute_coords()
recalcColor()
removeSplit = function() {
form = parse_product_formula(meta$form)
if (length(form$marg) > 1) {
meta$inactiveVar <- c(form$marg[1], meta$inactiveVar)
meta$inactiveDivider <- c(meta$divider[1], meta$inactiveDivider)
form$marg <- form$marg[-1]
meta$divider <- meta$divider[-1]
}
else return()
# if (length(form$marg) == 1) {
# if (form$marg[1] == "1") return()
# else {
# meta$inactiveVar <- c(form$marg[1], meta$inactiveVar)
# form$marg[1] = "1"
# }
#
# }
meta$form <- as.formula(paste_formula(form))
recalc()
layer.main$invalidateIndex()
qupdate(layer.main)
}
addSplit = function() {
form = parse_product_formula(meta$form)
if(length(meta$inactiveVar) < 1) return()
if ((length(form$marg) == 0) | (form$marg[1] == "1")) {
form$marg[1] <- meta$inactiveVar[1]
meta$inactiveVar <- meta$inactiveVar[-1]
} else {
form$marg <- c( meta$inactiveVar[1], form$marg)
meta$inactiveVar <- meta$inactiveVar[-1]
lastSplit <- length(form$marg)
meta$divider <- c(meta$inactiveDivider[1], meta$divider)
meta$inactiveDivider = meta$inactiveDivider[-1]
}
meta$form <- as.formula(paste_formula(form))
recalc()
layer.main$invalidateIndex()
qupdate(layer.main)
}
rotateLeft = function() {
form = parse_product_formula(meta$form)
if(length(meta$inactiveVar) < 1) return()
if ((length(form$marg) == 0) | (form$marg[1] == "1")) {
form$marg[1] <- meta$inactiveVar[1]
meta$inactiveVar <- meta$inactiveVar[-1]
} else {
save <- form$marg[1]
form$marg[1] <- meta$inactiveVar[1]
meta$inactiveVar <- c(meta$inactiveVar[-1], save)
}
meta$form <- as.formula(paste_formula(form))
recalc()
layer.main$invalidateIndex()
qupdate(layer.main)
}
rotateRight = function() {
form = parse_product_formula(meta$form)
if(length(meta$inactiveVar) < 1) return()
if ((length(form$marg) == 0) | (form$marg[1] == "1")) {
form$marg[1] <- meta$inactiveVar[1]
meta$inactiveVar <- meta$inactiveVar[-1]
} else {
save <- form$marg[1]
lastInactive <- length(meta$inactiveVar)
form$marg[1] <- meta$inactiveVar[lastInactive]
meta$inactiveVar <- c(save, meta$inactiveVar[-lastInactive])
}
meta$form <- as.formula(paste_formula(form))
recalc()
layer.main$invalidateIndex()
qupdate(layer.main)
}
rotateSplit = function() {
if (length(grep("v", meta$divider[1])) > 0)
meta$divider[1] <- gsub("v", "h", meta$divider[1])
else
meta$divider[1] <- gsub("h", "v", meta$divider[1])
recalc()
layer.main$invalidateIndex()
qupdate(layer.main)
}
unconditionVar = function() {
form = parse_product_formula(meta$form)
if (length(form$cond) < 1) return()
# take last conditioning variable and move in as first split
form$marg <- c(form$marg, form$cond[1])
form$cond <- form$cond[-1]
meta$form <- as.formula(paste_formula(form))
recalc()
layer.main$invalidateIndex()
qupdate(layer.main)
}
conditionVar = function() {
form = parse_product_formula(meta$form)
if (length(form$marg) < 1) return()
# take fist split and condition on it
firstSplit <- length(form$marg)
form$cond <- c(form$marg[firstSplit], form$cond)
form$marg <- form$marg[-firstSplit]
meta$form <- as.formula(paste_formula(form))
recalc()
layer.main$invalidateIndex()
qupdate(layer.main)
}
meta$brush.size = c(1, -1) * apply(meta$limits, 2, diff) / 15
main_draw = function(layer, painter) {
if (redoColor) recalcColor()
color <- "grey30"
with(meta$mdata, qdrawRect(painter,l,b,r,t, fill="white", stroke=color))
with(meta$cdata, qdrawRect(painter,l,b,r,t, fill=as.character(.color), stroke=as.character(.color)))
zeroes <- subset(meta$mdata, .wt==0, drop=FALSE)
if (nrow(zeroes) > 0) {
qdrawCircle(painter, zeroes$l, zeroes$b, r = 3,
stroke = color, fill = "white")
}
}
brush_draw = function(layer, painter) {
if (redoHiliting) recalcHiliting()
color <- b$color
with(meta$hdata, qdrawRect(painter,l,b,r,t, fill=color, stroke=color))
draw_brush(layer, painter, data, meta)
}
brush_mouse_press = function(layer, event) {
common_mouse_press(layer, event, data, meta)
}
brush_mouse_move = function(layer, event) {
rect = qrect(update_brush_size(meta, event))
hits = layer$locate(rect)
hits <- hits[hits < nrow(meta$mdata)]
if (length(hits)) {
## rectangles are drawn in the same order as in mdata
# print(hits)
form <- parse_product_formula(meta$form)
var <- unlist(c(form$marg, form$cond))
selected <- meta$mdata[hits+1, var, drop=FALSE]
condstr = constructCondition(selected)
hits = with(data.frame(data), which(eval(parse(text=condstr))))
}
selected(data) = mode_selection(selected(data), hits, mode = b$mode)
common_mouse_move(layer, event, data, meta)
}
brush_mouse_release = function(layer, event) {
brush_mouse_move(layer, event)
common_mouse_release(layer, event, data, meta)
}
key_press = function(layer, event) {
common_key_press(layer, event, data, meta)
key <- event$key()
if (key == Qt$Qt$Key_Up) { # arrow up
removeSplit()
}
if (key == Qt$Qt$Key_Down) { # arrow down
addSplit()
}
if (key == Qt$Qt$Key_Right) { # arrow right
rotateRight()
}
if (key == Qt$Qt$Key_Left) { # arrow right
rotateLeft()
}
if (key == Qt$Qt$Key_R) { # 'r' or 'R' for 'rotate'
rotateSplit()
}
if (key == Qt$Qt$Key_U) { # 'u' or 'U' for 'uncondition'
unconditionVar()
}
if (key == Qt$Qt$Key_C) { # 'c' or 'C' for 'condition'
conditionVar()
}
if (key == Qt$Qt$Key_B) { # 'b' or 'B' for 'spine to Bar'
firstletter <- substr(meta$divider[1],1,1)
meta$divider[1] <- sprintf("%sbar", firstletter)
recalc()
layer.main$invalidateIndex()
qupdate(layer.main)
}
if (key == Qt$Qt$Key_S) { # 's' or 'S' for 'bar to Spine'
firstletter <- substr(meta$divider[1],1,1)
meta$divider[1] <- sprintf("%sspine", firstletter)
recalc()
layer.main$invalidateIndex(); qupdate(layer.main)
}
}
key_release = function(layer, event) {
common_key_release(layer, event, data, meta)
}
identify_hover = function(layer, event) {
if (!b$identify) return()
b$cursor = 2L
meta$pos = as.numeric(event$pos())
meta$identified = layer$locate(identify_rect(meta))
qupdate(layer.identify)
}
identify_draw = function(layer, painter) {
if (!b$identify || !length(idx <- meta$identified)) return()
idx <- idx[idx <= nrow(meta$mdata)]
if (length(idx) == 0) return()
idx = idx + 1
form <- parse_product_formula(meta$form)
var <- rev(unlist(c(form$marg, form$cond)))
for(i in var)
meta$mdata[,i] <- as.character(meta$mdata[,i])
id <- paste(var, meta$mdata[idx, var], sep=": ", collapse="\n")
sumwt <- sum(meta$mdata[, ".wt"])
ivals <- paste(sprintf("\ncount: %s\nproportion: %.2f%%",
meta$mdata[idx, ".wt"],
meta$mdata[idx, ".wt"]/sumwt*100), collapse="\n")
meta$identify.labels = paste(id, ivals, collapse="")
draw_identify(layer, painter, data, meta)
qdrawRect(painter, meta$mdata$l[idx], meta$mdata$b[idx], meta$mdata$r[idx],
meta$mdata$t[idx], stroke = b$color, fill = NA)
}
scene = qscene()
layer.root = qlayer(scene)
layer.main =
qlayer(paintFun = main_draw,
mousePressFun = brush_mouse_press, mouseReleaseFun = brush_mouse_release,
mouseMoveFun = brush_mouse_move, hoverMoveFun = identify_hover,
keyPressFun = key_press, keyReleaseFun = key_release,
focusInFun = function(layer, event) {
common_focus_in(layer, event, data, meta)
}, focusOutFun = function(layer, event) {
common_focus_out(layer, event, data, meta)
},
limits = qrect(meta$limits))
layer.brush = qlayer(paintFun = brush_draw, limits = qrect(meta$limits))
layer.identify = qlayer(paintFun = identify_draw, limits = qrect(meta$limits))
layer.title = qmtext(meta = meta, side = 3)
layer.xlab = qmtext(meta = meta, side = 1)
layer.ylab = qmtext(meta = meta, side = 2)
layer.xaxis = qaxis(meta = meta, side = 1)
layer.yaxis = qaxis(meta = meta, side = 2)
layer.grid = qgrid(meta = meta)
layer.keys = key_layer(meta)
layer.root[0, 2] = layer.title
layer.root[2, 2] = layer.xaxis
layer.root[3, 2] = layer.xlab
layer.root[1, 1] = layer.yaxis
layer.root[1, 0] = layer.ylab
layer.root[1, 2] = layer.grid
layer.root[1, 2] = layer.main
layer.root[1, 2] = layer.brush
layer.root[1, 2] = layer.keys
layer.root[1, 2] = layer.identify
layer.root[1, 3] = qlayer()
set_layout = function() {
fix_dimension(layer.root,
row = list(id = c(0, 2, 3), value = c(prefer_height(meta$main),
prefer_height(meta$xlabels),
prefer_height(meta$xlab))),
column = list(id = c(1, 0, 3), value = c(prefer_width(meta$ylabels),
prefer_width(meta$ylab, FALSE),
10)))
}
set_layout()
meta$mainChanged$connect(set_layout)
meta$xlabChanged$connect(set_layout); meta$ylabChanged$connect(set_layout)
meta$xlabelsChanged$connect(set_layout); meta$ylabelsChanged$connect(set_layout)
view = qplotView(scene = scene)
view$setWindowTitle(sprintf('Mosaic plot: %s', meta$main))
meta$xlabChanged$connect(setxlab)
meta$ylabChanged$connect(setylab)
meta$formChanged$connect(function() {
meta$main = settitle(meta$form)
view$setWindowTitle(sprintf('Mosaic plot: %s', meta$main))
})
d.idx = add_listener(data, function(i, j) {
switch(j, .brushed = { redoHiliting <<-TRUE; qupdate(layer.main)},
.color = {
redoColor <<-TRUE;
qupdate(layer.main)
}, {
compute_coords(); redoHiliting<<- TRUE
redoColor <<- TRUE; flip_coords()
layer.main$invalidateIndex()
qupdate(layer.grid); qupdate(layer.xaxis); qupdate(layer.yaxis)
qupdate(layer.main)
})
})
qconnect(layer.main, 'destroyed', function(x) {
## b$colorChanged$disconnect(b.idx)
remove_listener(data, d.idx)
})
b$cursorChanged$connect(function() {
set_cursor(view, b$cursor)
})
sync_limits(meta, layer.main, layer.brush, layer.identify)
meta$manual.brush = function(pos) {
brush_mouse_move(layer = layer.main, event = list(pos = function() pos))
}
attr(view, 'meta') = meta
view
}
Mosaic.meta =
setRefClass("Mosaic_meta", contains = "CommonMeta",
fields = properties(list(
var = 'character',
form='formula',
divider='character',
origForm='formula',
origDivider='character',
inactiveVar='character',
inactiveDivider='character',
mdata='data.frame',
hdata='data.frame',
cdata='data.frame'
)))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.