pagenum = 1
maxrows = 20
sortidx = TRUE
sortvar = NA
sortdecreasing = FALSE
sortMe = function(x) {
x = deparse(substitute(x))
sortdecreasing <<- !is.na(sortvar) && sortvar == x && !sortdecreasing
sortidx <<- order(a[[x]],
decreasing = sortdecreasing) # reverse the sort if the same var selected
sortvar <<- x
}
a.s = a[sortidx,]
rowidx = array(TRUE, NROW(a.s))
if (tableFind != "")
rowidx = apply(a.s, FUN = function(x) any(grep(tableFind, x)), MARGIN = 1)
if (tableExclude != "")
rowidx = rowidx & apply(a.s, FUN = function(x) !any(grep(tableExclude, x)), MARGIN = 1)
rowidx = which(rowidx)
pagemax = ceiling(length(rowidx) / maxrows)
if (pagenum < 1) pagenum = 1
if (pagenum > pagemax) pagenum = pagemax
if (length(rowidx) > maxrows) {
pagingidx = (1 + (pagenum-1)*maxrows) : min(pagenum*maxrows, length(rowidx))
rowidx = rowidx[pagingidx]
}
x = a.s[rowidx,]
x.formatted <- as.matrix(format(x))
x.formatted[is.na(x) | is.nan(x)] <- " "
x.formatted[grep("^ *(NA|NaN) *$", x.formatted)] <- " "
HTMLon()
H("div", class = "RpadTableHolder",
H("table",
H("tbody",
H("tr", # HEADER ROW
H("th",
H("div", style = "cursor: pointer;",
onclick = paste('javascript:thisPage.sendThenRecalc("sortMe(', colnames(x), ')");', sep = ""),
colnames(x), collapseContents = FALSE))), # collapseContents keeps the
library(reshape)
HTMLon()
agFunNames = c("count", "sum", "mean", "var", "q05", "q25", "median", "q75", "q95")
q05 = function(x, ...) quantile(x, 0.05, names = FALSE, ...)
q25 = function(x, ...) quantile(x, 0.25, names = FALSE, ...)
q75 = function(x, ...) quantile(x, 0.75, names = FALSE, ...)
q95 = function(x, ...) quantile(x, 0.95, names = FALSE, ...)
count = function(x, ...) length(x)
varNames = c("NONE","variable",names(a))
numericVariables = sapply(a, is.numeric)
#VARS = list(Data = as.list(names(numericVariables)[numericVariables]),
# Rows = list(variable = "variable"))
#allFUN = TRUE
variableButtons =
H("span", class="variableButton", isNumeric = ifelse(numericVariables, "true", "false"),
style = ifelse(numericVariables, "color:darkblue; z-index:2; position:relative;", "color:green; z-index:2; position:relative;"),
names(a),
H("input", name=paste("VARS[[activeType]]$", names(a), sep = ""),
value=names(a), type="hidden", rpadType="Rstring", collapseContents = FALSE),
collapseContents = FALSE)
H("form",
HTMLinput(name="VARS", value="list()", type="hidden", rpadType="Rvariable"),
H("table",
H("tr",
H("td", "Data: "),
H("td",
HTMLinput(name="activeType", value="Data", type="hidden", rpadType="Rstring"),
H("div", id="dataDrops", class="dropZone",
H(NULL, variableButtons[numericVariables]))),
H("td", valign="top", rowspan = 3,
HTMLinput(name="activeType", value="Other", type="hidden", rpadType="Rstring"),
H("div", id = "dragSources", class="dropZone", style="min-height:6.2em; height:auto !important; height: 6.2em;",
H(NULL, variableButtons[!numericVariables])),
H("div", style="position:relative; border: red; left:15px; bottom:4em; width:400px; height:1px; font-style: italic; color: #D3D3D3;",
H("p", "Variable drop zone: drag and drop variables to change the summary table.")))),
H("tr",
H("td", "Rows: "),
H("td",
HTMLinput(name="activeType", value="Rows", type="hidden", rpadType="Rstring"),
H("div", id="rowDrops", " ", class="dropZone",
H("span", class="variableButton", style="color:red; z-index:2; position:relative;",
"variable",
H("input", name=paste("VARS[[activeType]]$", "variable", sep = ""),
value="variable", type="hidden", rpadType="Rstring", collapseContents = FALSE))))),
H("tr",
H("td", "Cols: "),
H("td",
HTMLinput(name="activeType", value="Cols", type="hidden", rpadType="Rstring"),
H("div", " ",
H("div", id="colDrops", " ", class="dropZone"))))),
BR,
H("input", type = "checkbox", name="count.FUN", id="count.FUN", checked="checked"),
H("label", "for"="count.FUN", "count"),
H(NULL,
sapply(agFunNames[-1], function(name)
H(NULL,
H("input", type = "checkbox",
name = paste(name, ".FUN", sep = ""),
id = paste(name, ".FUN", sep = "")),
H("label", "for"=paste(name, ".FUN", sep = ""), name))
)),
H("input", type = "checkbox", name="allFUN", checked="checked"),
H("label", "for"="allFUN", "All functions"),
BR,
H("input", type="button", value="Update summary", onclick="javascript:thisPage.calcTab2()"))
dojo.dnd.dragManager.dropTargets = []; // This removes old dropTargets
thisPage.d1 = new dojo.dnd.HtmlDropTarget(dojo.byId("dragSources"), ["num", "other"]);
thisPage.d2 = new dojo.dnd.HtmlDropTarget(dojo.byId("dataDrops"), ["num"]);
thisPage.d3 = new dojo.dnd.HtmlDropTarget(dojo.byId("rowDrops"), ["num", "other"]);
thisPage.d4 = new dojo.dnd.HtmlDropTarget(dojo.byId("colDrops"), ["num", "other"]);
updateDragSources = function(lis) {
for(var x=0;x < lis.length; x++){
if (lis[x].getAttribute("isNumeric") == "true") {
new dojo.dnd.HtmlDragSource(lis[x], "num");
} else {
new dojo.dnd.HtmlDragSource(lis[x], "other");
}
}
}
updateDragSources(dojo.byId("dragSources").getElementsByTagName("span"));
updateDragSources(dojo.byId("dataDrops").getElementsByTagName("span"));
updateDragSources(dojo.byId("rowDrops").getElementsByTagName("span"));
updateDragSources(dojo.byId("colDrops").getElementsByTagName("span"));
dojo.event.connect(thisPage.d1, "onDrop", thisPage, "calcTab2")
dojo.event.connect(thisPage.d2, "onDrop", thisPage, "calcTab2")
dojo.event.connect(thisPage.d3, "onDrop", thisPage, "calcTab2")
dojo.event.connect(thisPage.d4, "onDrop", thisPage, "calcTab2")
" "
funNames = agFunNames
if (!allFUN)
funNames = agFunNames[sapply(paste(agFunNames, "FUN", sep = "."), get)] # only checked names
FUN = function(x) sapply(funNames, function(F) do.call(F, list(x, na.rm = TRUE)))
ROW = paste(VARS$Row, collapse = "+")
if (ROW == "") ROW = "."
COL = paste(VARS$Col, collapse = "+")
if (COL == "") COL = "."
frm = paste(ROW, "~", COL)
id = setdiff(c(unlist(VARS$Row), unlist(VARS$Col)), "variable")
aa = a
for (n in id)
if (is.numeric(aa[[n]]) && length(unique(aa[[n]])) > 6)
aa[[n]] = cut(aa[[n]], unique(quantile(aa[[n]], na.rm = TRUE)), include.lowest = TRUE)
a.m = melt(aa, meas = unlist(VARS$Data))
margins = length(funNames) == 1 # gets around a reshape bug with multiple function args
x = cast(a.m, frm, fun = FUN, margins = margins)
colheader = cbind(t(rcolnames(x)), names(rcolnames(x)))
colheader[is.na(colheader)] = " "
rowheader = matrix("", NCOL(rcolnames(x)), NCOL(rrownames(x)) + 1)
rowheader[NROW(rowheader), 1:(NCOL(rowheader) - 1)] = names(rrownames(x))
tableheader = cbind(rowheader, colheader)
x = cbind(x[,1:(NCOL(rowheader)-1), drop = FALSE],
rep(" ", NROW(x)), # blank separation column
x[, -(1:(NCOL(rowheader)-1)), drop = FALSE])
x.formatted <- as.matrix(format(x))
x.formatted[is.na(x) | is.nan(x)] <- " "
x.formatted[grep("^ *(NA|NaN) *$", x.formatted)] <- " "
HTMLon()
H("div", class = "RpadTableHolder",
H("table",
H("tbody",
H(NULL, # NULL groups consecutive tags together
apply(tableheader, MARGIN = 1, # HEADER ROWS - sweep the rows
FUN = function (x)
H("tr",
H("th", x)))),
H(NULL, # NULL groups consecutive tags together
apply(x.formatted, MARGIN = 1, # MAIN BODY - sweep the rows
FUN = function (x)
H("tr",
H("td", x)))))))
Summary and pivot table functionality is based on the reshape package by Hadley Wickham.
library(lattice)
# defaults:
Y = names(a)[1]; X = names(a)[2]; panel = group = "NONE"; lineFit = FALSE
autoAgFunNames = c("mean", "q05", "q25", "median", "q75", "q95")
HTMLon()
H("form",
H("p",
"Y variable:",
HTMLselect("Y", names(a)),
"X variable:",
HTMLselect("X", names(a), default = 2),
"Panel variable:",
HTMLselect("panel", c("NONE",names(a))),
"Grouping variable:",
HTMLselect("group", c("NONE",names(a)))),
H("p",
"Auto-aggregation function:",
HTMLselect("agFun", c("NONE",autoAgFunNames))),
H("input", name="lineFit", id="lineFit", type="checkbox"),
H("label", "for"="lineFit", "Include line fit"),
H("input", name="lowessFit", id="lowessFit", type="checkbox"),
H("label", "for"="lowessFit", "Include lowess fit"),
BR,
H("input", type="button", value="Plot", onclick="javascript:rpad.calculateTree(dojo.byId('tab3'))"))
if (!is.null(panel) && panel == "NONE") panel = NULL
if (!is.null(group) && group == "NONE") group = NULL
plotType = c("p", if (lineFit) "r", if (lowessFit) "smooth")
## make group and/or panel numerics into factors:
ag = a
if (!is.null(panel) && is.numeric(ag[[panel]]) && length(unique(ag[[panel]])) > 6) {
ag[[panel]] = cut(ag[[panel]], unique(quantile(ag[[panel]], na.rm = TRUE)), include.lowest = TRUE)
}
if (!is.null(panel) && is.numeric(ag[[panel]])) {
ag[[panel]] = factor(ag[[panel]])
}
if (!is.null(panel)) {
levels(ag[[panel]]) = paste(panel, ": ", levels(ag[[panel]]), sep = "")
}
if (!is.null(group) && is.numeric(ag[[group]]) && length(unique(ag[[group]])) > 6) {
ag[[group]] = cut(ag[[group]], unique(quantile(ag[[group]], na.rm = TRUE)), include.lowest = TRUE)
}
## auto-aggregate:
if (agFun != "NONE") {
agVar = ""; otherVar = ""
if (length(unique(a[[Y]])) > 6*length(unique(a[[X]]))) {
agVar = Y
otherVar = X
agVarName = paste(agVar, "___", agFun, sep = "")
ag[[agVarName]] = ag[[agVar]]
Y = agVarName
} else if (length(unique(a[[X]])) > 6*length(unique(a[[Y]]))) {
agVar = X
otherVar = Y
agVarName = paste(agVar, "___", agFun, sep = "")
ag[[agVarName]] = ag[[agVar]]
X = agVarName
}
if (agVar != "") {
ag =
aggregate(ag[agVarName],
ag[,c(otherVar,panel,group),drop=FALSE],
function(x) do.call(agFun, list(x,na.rm=TRUE)))
if (is.numeric(a[[otherVar]]))
ag[[otherVar]] = as.numeric(as.character(ag[[otherVar]]))
}
}
newgraph(width = 7)
trellis.par.set(theme = col.whitebg())
frm = as.formula(paste(Y, "~", X, if (!is.null(panel)) "|" else "", panel))
xyplot(frm, data = ag,
as.table = TRUE,
type = plotType,
groups = if (!is.null(group)) ag[[group]] else NULL,
auto.key = list(title=group, space = "right"),
pch = 20,
lwd = 1.8,
par.settings = list(superpose.symbol=list(pch = 20)) # this gets the key right
)
HTMLon()
showgraph(link = TRUE)
BR
This uses the lattice package by Deepayan Sarkar.