Nothing
## panel.likert calls panel.barchart2
## panel.barchart2 is based on panel.barchart
## The changes are
## * the heights in each horizontal stacked bar are constant.
## * the widths in each vertical stacked bar are constant.
## * the panel.barchart heights and widths are based on the box.width argument.
## * the panel.barchart2 heights and widths when stack==TRUE are also based
## on the new stackWidth argument.
## scaling of stackWidth
## stackWidth <- stackWidth/mean(stackWidth) ## and maybe smaller with another /2
panel.barchart2 <-
function (x, y, box.ratio = 1, box.width = box.ratio/(1 + box.ratio),
horizontal = TRUE, origin = NULL, reference = TRUE, stack = FALSE,
groups = NULL, col = if (is.null(groups)) plot.polygon$col else superpose.polygon$col,
border = if (is.null(groups)) plot.polygon$border else superpose.polygon$border,
lty = if (is.null(groups)) plot.polygon$lty else superpose.polygon$lty,
lwd = if (is.null(groups)) plot.polygon$lwd else superpose.polygon$lwd,
..., identifier = "barchart",
stackWidth=NULL)
{
plot.polygon <- trellis.par.get("plot.polygon")
superpose.polygon <- trellis.par.get("superpose.polygon")
reference.line <- trellis.par.get("reference.line")
keep <- (function(x, y, groups, subscripts, ...) {
!is.na(x) & !is.na(y) & if (is.null(groups))
TRUE
else !is.na(groups[subscripts])
})(x = x, y = y, groups = groups, ...)
if (!any(keep))
return()
x <- as.numeric(x[keep])
y <- as.numeric(y[keep])
if (!is.null(groups)) {
groupSub <- function(groups, subscripts, ...) groups[subscripts[keep]]
if (!is.factor(groups))
groups <- factor(groups)
nvals <- nlevels(groups)
groups <- as.numeric(groupSub(groups, ...))
}
if (horizontal) {
if (is.null(groups)) {
if (is.null(origin)) {
origin <- current.panel.limits()$xlim[1]
reference <- FALSE
}
height <- box.width
if (reference)
panel.abline(v = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd,
identifier = paste(identifier, "abline", sep = "."))
panel.rect(x = rep(origin, length(y)), y = y, height = rep(height,
length(y)), width = x - origin, border = border,
col = col, lty = lty, lwd = lwd, just = c("left",
"centre"), identifier = identifier)
}
else if (stack) {
if (!is.null(origin) && origin != 0)
warning("'origin' forced to 0 for stacked bars")
col <- rep(col, length.out = nvals)
border <- rep(border, length.out = nvals)
lty <- rep(lty, length.out = nvals)
lwd <- rep(lwd, length.out = nvals)
height <- box.width
if (reference)
panel.abline(v = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd,
identifier = paste(identifier, "abline", sep = "."))
## recover()
if (is.null(stackWidth)) stackWidth <- rep(1, length(unique(y)))
for (i in unique(y)) {
ok <- y == i
ord <- sort.list(groups[ok])
pos <- x[ok][ord] > 0
nok <- sum(pos, na.rm = TRUE)
if (nok > 0)
panel.rect(x = cumsum(c(0, x[ok][ord][pos][-nok])),
y = rep(i, nok), col = col[groups[ok][ord][pos]],
border = border[groups[ok][ord][pos]], lty = lty[groups[ok][ord][pos]],
lwd = lwd[groups[ok][ord][pos]], height = rep(height,
nok)*stackWidth[i], width = x[ok][ord][pos], just = c("left",
"centre"), identifier = paste(identifier,
"pos", i, sep = "."))
neg <- x[ok][ord] < 0
nok <- sum(neg, na.rm = TRUE)
if (nok > 0)
panel.rect(x = cumsum(c(0, x[ok][ord][neg][-nok])),
y = rep(i, nok), col = col[groups[ok][ord][neg]],
border = border[groups[ok][ord][neg]], lty = lty[groups[ok][ord][neg]],
lwd = lwd[groups[ok][ord][neg]], height = rep(height,
nok)*stackWidth[i], width = x[ok][ord][neg], just = c("left",
"centre"), identifier = paste(identifier,
"neg", i, sep = "."))
}
}
else {
if (is.null(origin)) {
origin <- current.panel.limits()$xlim[1]
reference <- FALSE
}
col <- rep(col, length.out = nvals)
border <- rep(border, length.out = nvals)
lty <- rep(lty, length.out = nvals)
lwd <- rep(lwd, length.out = nvals)
height <- box.width/nvals
if (reference)
panel.abline(v = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd,
identifier = paste(identifier, "abline", sep = "."))
for (i in unique(y)) {
ok <- y == i
nok <- sum(ok, na.rm = TRUE)
panel.rect(x = rep(origin, nok), y = (i + height *
(groups[ok] - (nvals + 1)/2)), col = col[groups[ok]],
border = border[groups[ok]], lty = lty[groups[ok]],
lwd = lwd[groups[ok]], height = rep(height,
nok), width = x[ok] - origin, just = c("left",
"centre"), identifier = identifier)
}
}
}
else {
if (is.null(groups)) {
if (is.null(origin)) {
origin <- current.panel.limits()$ylim[1]
reference <- FALSE
}
width <- box.width
if (reference)
panel.abline(h = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd,
identifier = paste(identifier, "abline", sep = "."))
panel.rect(x = x, y = rep(origin, length(x)), col = col,
border = border, lty = lty, lwd = lwd, width = rep(width,
length(x)), height = y - origin, just = c("centre",
"bottom"), identifier = identifier)
}
else if (stack) {
if (!is.null(origin) && origin != 0)
warning("'origin' forced to 0 for stacked bars")
col <- rep(col, length.out = nvals)
border <- rep(border, length.out = nvals)
lty <- rep(lty, length.out = nvals)
lwd <- rep(lwd, length.out = nvals)
width <- box.width
if (reference)
panel.abline(h = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd,
identifier = paste(identifier, "abline", sep = "."))
if (is.null(stackWidth)) stackWidth <- rep(1, length(unique(x)))
for (i in unique(x)) {
ok <- x == i
ord <- sort.list(groups[ok])
pos <- y[ok][ord] > 0
nok <- sum(pos, na.rm = TRUE)
if (nok > 0)
panel.rect(x = rep(i, nok), y = cumsum(c(0,
y[ok][ord][pos][-nok])), col = col[groups[ok][ord][pos]],
border = border[groups[ok][ord][pos]], lty = lty[groups[ok][ord][pos]],
lwd = lwd[groups[ok][ord][pos]], width = rep(width,
nok)*stackWidth[i], height = y[ok][ord][pos], just = c("centre",
"bottom"), identifier = paste(identifier,
"pos", i, sep = "."))
neg <- y[ok][ord] < 0
nok <- sum(neg, na.rm = TRUE)
if (nok > 0)
panel.rect(x = rep(i, nok), y = cumsum(c(0,
y[ok][ord][neg][-nok])), col = col[groups[ok][ord][neg]],
border = border[groups[ok][ord][neg]], lty = lty[groups[ok][ord][neg]],
lwd = lwd[groups[ok][ord][neg]], width = rep(width,
nok)*stackWidth[i], height = y[ok][ord][neg], just = c("centre",
"bottom"), identifier = paste(identifier,
"neg", i, sep = "."))
}
}
else {
if (is.null(origin)) {
origin <- current.panel.limits()$ylim[1]
reference = FALSE
}
col <- rep(col, length.out = nvals)
border <- rep(border, length.out = nvals)
lty <- rep(lty, length.out = nvals)
lwd <- rep(lwd, length.out = nvals)
width <- box.width/nvals
if (reference)
panel.abline(h = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd,
identifier = paste(identifier, "abline", sep = "."))
for (i in unique(x)) {
ok <- x == i
nok <- sum(ok, na.rm = TRUE)
panel.rect(x = (i + width * (groups[ok] - (nvals +
1)/2)), y = rep(origin, nok), col = col[groups[ok]],
border = border[groups[ok]], lty = lty[groups[ok]],
lwd = lwd[groups[ok]], width = rep(width, nok),
height = y[ok] - origin, just = c("centre",
"bottom"), identifier = identifier)
}
}
}
}
## <bytecode: 0x109029200>
## <environment: namespace:lattice>
panel.likert <- function(..., horizontal=TRUE, reference.line.col="gray65") {
if (horizontal)
panel.abline(v=0, col=reference.line.col)
else
panel.abline(h=0, col=reference.line.col)
panel.barchart2(...)
}
if (FALSE) {
PoorChildrenPlot <-
likert( ~ ., PoorChildren,
col=PCWPpalette, as.percent=TRUE,
ylab="Percent of poor households in area",
xlab="Percent of Children",
xlab.top=c("No Working Parents", "One or more Working Parents"),
ylab.right="Row Count Totals",
main="Poor Children, Working Parents",
strip=FALSE,
rightAxisLabels=format(rowCounts, big.mark=","),
par.settings=list(
axis.line=list(col="transparent"),
layout.widths=list(ylab.right=1, axis.key.padding=10)
),
box.ratio=500,
## layout=c(1,6),
between=list(y=0),
scales=list(y=list(relation="free", tck=c(0,3))),
## h.resizePanels=rowCounts,
stackWidth=rev(rowCounts)/mean(rowCounts)/2,
panel=panel.likert
)
PoorChildrenPlot
}
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.