latexDotchart <-
function(data, labels, groups = NULL, gdata = NA,
xlab = "", auxdata, auxgdata=NULL, auxtitle,
w=4, h=4, margin, lines = TRUE, dotsize = .075, size='small',
size.labels = 'small', size.group.labels = 'normalsize',
ttlabels = FALSE, sort.=TRUE, xaxis=TRUE, lcolor='gray',
...)
{
txt <- function(x, y, s, size=NULL, just=c('c','l','r'), tt=FALSE) {
just <- match.arg(just)
s <- latexTranslate(s)
n <- max(length(x), length(y), length(s))
x <- rep(x, length.out=n)
y <- rep(y, length.out=n)
s <- rep(s, length.out=n)
z <- character(n)
if(tt) s <- paste('\\texttt{', s, '}', sep='')
if(length(size)) s <- paste('\\', size, ' ', s, sep='')
for(i in 1:n)
z[i] <- sprintf('\\put(%g,%g){\\makebox(.001,.001)[%s]{%s}}',
x[i], y[i], just, s[i])
z
}
ln <- function(x1, y1, x2, y2, color='black') {
n <- max(length(x1), length(x2), length(y1), length(y2))
x1 <- rep(x1, length.out=n)
y1 <- rep(y1, length.out=n)
x2 <- rep(x2, length.out=n)
y2 <- rep(y2, length.out=n)
z <- character(n)
for(i in 1:n)
z[i] <- if(x1[i] == x2[i])
sprintf('\\put(%g,%g){\\line(0,%g){%g}}', x1[i], y1[i],
1*(y2[i] >= y1[i]) - 1*(y2[i] < y1[i]), abs(y2[i]-y1[i]))
else if(y1[i] == y2[i])
sprintf('\\put(%g,%g){\\line(%g,0){%g}}', x1[i], y1[i],
1*(x2[i] >= x1[i]) - 1*(x2[i] < x1[i]), abs(x2[i]-x1[i]))
else
sprintf('\\drawline(%g,%g)(%g,%g)',
x1[i], y1[i], x2[i], y2[i])
if(color != 'black')
z <- c(if(color == 'gray') '\\color[gray]{0.8}' else
sprintf('\\color{%s}', color),
z, '\\color{black}')
z
}
## Approximate length in inches of longest char. string
acl <- function(s) 0.09 * max(nchar(s))
f <- sprintf
if(size.labels == size) size.labels <- NULL
if(size.group.labels == size) size.group.labels <- NULL
z <- c('\\setlength{\\unitlength}{1in}',
f('\\begin{picture}(%g,%g)', w, h),
f('\\%s', size))
ndata <- length(data)
if(missing(labels)) {
if(length(names(data)))
labels <- names(data)
else labels <- paste("#", seq(along = ndata))
}
else labels <- rep(as.character(labels), length = ndata)
if(missing(groups)) {
glabels <- NULL
gdata <- NULL
if(sort.) {
ord <- order(-data)
data <- data[ord]
labels <- labels[ord]
if(! missing(auxdata)) auxdata <- auxdata[ord]
}
} else {
if(! sort.) {
##assume data sorted in groups, but re-number groups
##to be as if groups given in order 1,2,3,...
ug <- unique(as.character(groups))
groups <- factor(as.character(groups), levels=ug)
}
groups <- unclass(groups)
glabels <- levels(groups)
gdata <- rep(gdata, length = length(glabels))
ord <- if(sort.) order(groups, -data) else
order(groups, seq(along = groups))
groups <- groups[ord]
data <- data[ord]
labels <- labels[ord]
if(! missing(auxdata)) auxdata <- auxdata[ord]
}
alldat <- c(data, gdata)
if(! missing(auxdata)) auxdata <- format(c(auxdata, auxgdata))
alllab <- c(labels, glabels)
## set up margins and user coordinates, draw box
xl <- range(p <- pretty(alldat))
yl <- c(1, length(alldat))
if(missing(margin))
margin <- c(acl(alllab),
ifelse(xlab == '', .2, .4),
ifelse(missing(auxdata), 0, acl(auxdata)),
ifelse(missing(auxtitle), 0, .1))
xt <- function(x) round((w - sum(margin[c(1,3)]))*(x - xl[1])/diff(xl) +
margin[1], 5)
yt <- function(y) round((h - sum(margin[c(2,4)]))*(y - yl[1])/diff(yl) +
margin[2], 5)
## \color screws up line and circle placement if first multiputlist
## and put occur after \color
if(xaxis) {
z <- c(z, paste(f('\\multiputlist(%g,%g)(%g,%g){',
xt(xl[1]), yt(yl[1]) - .15, diff(xt(p[1:2])), 0),
paste(p, collapse=','), '}', sep=''))
z <- c(z, ln(xt(p), yt(yl[1]) - 0.05, xt(p), yt(yl[1])))
if(xlab != '')
z <- c(z, txt(xt(xl[1] + diff(xl)/2), .1, xlab))
}
z <- c(z, ln(xt(xl), yt(yl[1]), xt(xl), yt(yl[2])),
ln(xt(xl[1]), yt(yl), xt(xl[2]), yt(yl)))
den <- ndata + 2 * length(glabels) + 1
delt <- ( - (yl[2] - yl[1]))/den
ypos <- seq(yl[2], by = delt, length = ndata)
if(! missing(groups)) {
ypos1 <- ypos + 2 * delt * (if(length(groups)>1)
cumsum(c(1, diff(groups) > 0))
else 1)
diff2 <- c(3 * delt, diff(ypos1))
ypos2 <- ypos1[abs(diff2 - 3 * delt) < abs(0.001 * delt)] -
delt
ypos <- c(ypos1, ypos2) - delt
}
##put on labels and data
ypos <- ypos + delt
nongrp <- 1:ndata
if(lines)
z <- c(z, ln(xt(xl[1]), yt(ypos[nongrp]), xt(xl[2]), yt(ypos[nongrp]),
color=lcolor))
for(i in seq(along = alldat))
if(! is.na(alldat[i] + ypos[i]))
z <- c(z, f('\\put(%g,%g){\\circle*{%g}}',
xt(alldat[i]), yt(ypos[i]), dotsize))
if(! missing(auxdata)) {
z <- c(z, txt(w - 0.02, yt(ypos[nongrp]), auxdata,
size=size.labels, just='r'))
if(! missing(auxtitle))
z <- c(z, txt(w - 0.02, yt(yl[2]) + 0.1, auxtitle,
size=size.labels, just='r'))
}
labng <- alllab[nongrp]
yposng <- ypos[nongrp]
z <- c(z, txt(margin[1] - 0.05, yt(yposng), labng,
size=size.labels, just='r', tt=ttlabels))
if(! missing(groups))
z <- c(z, txt(margin[1] - 0.05, yt(ypos[-nongrp]), alllab[-nongrp],
size=size.group.labels, just='r'))
z <- c(z, '\\end{picture}')
z
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.