dotchart3 <-
function (x, labels = NULL, groups = NULL, gdata = NULL, cex = par("cex"),
pch = 21, gpch = pch, bg = par("bg"), color = par("fg"),
gcolor = par("fg"), lcolor = "gray",
xlim = range(c(x, gdata), na.rm=TRUE), main = NULL,
xlab = NULL, ylab = NULL, auxdata=NULL, auxtitle=NULL,
auxgdata=NULL, axisat=NULL, axislabels=NULL,
cex.labels = cex, cex.group.labels = cex.labels*1.25,
cex.auxdata = cex, groupfont=2,
auxwhere=NULL, height=NULL, width=NULL, ...)
{
opar <- par("mai", "mar", "cex", "yaxs")
on.exit(par(opar))
par(cex = cex, yaxs = "i")
if (! is.numeric(x))
stop("'x' must be a numeric vector or matrix")
x <- as.matrix(x)
n <- nrow(x)
nc <- ncol(x)
pch <- rep(pch, length.out=nc)
if(! length(labels)) labels <- rownames(x)
if(! length(labels)) stop('labels not defined')
if(length(groups)) groups <- as.factor(groups)
glabels <- levels(groups)
plot.new()
linch <- max(strwidth(labels, "inch"), na.rm = TRUE)
if (! length(glabels)) {
ginch <- 0
goffset <- 0
}
else {
ginch <- max(strwidth(glabels, "inch", cex=cex.group.labels,
font=groupfont),
na.rm = TRUE)
goffset <- 0.4
}
if(length(labels) + length(glabels) > 0) {
nmai <- par("mai")
nmai[2L] <- max(nmai[2L], nmai[4L] + max(linch + goffset, ginch) + 0.1)
## Run strwidth separately because on of the 3 variables might
## be an expression, in which case an overall c(...) would combine the
## widths of character vectors
if(length(auxdata) + length(auxgdata) > 0)
nmai[4L] <- .2 + 1.1 * max(strwidth(auxtitle, 'inch', cex=cex.auxdata),
strwidth(auxdata, 'inch', cex=cex.auxdata),
strwidth(auxgdata, 'inch', cex=cex.auxdata))
par(mai = nmai)
}
if (! length(groups)) {
o <- n:1L
y <- o
ylim <- c(.5, n + .5)
x <- x[o, , drop=FALSE]
labels <- labels[o]
if(length(auxdata)) auxdata <- auxdata[o]
}
else {
# Added: For each group reverse order of data so plotting will
# put first levels at top
o <- sort.list(as.numeric(groups), decreasing = TRUE)
groups <- groups[o]
# for(g in levels(groups)) {
# i <- groups == g
# o[i] <- rev(o[i])
# }
x <- x[o, , drop=FALSE] # ascending within region
labels <- labels[o]
if(length(auxdata)) auxdata <- auxdata[o]
# End added
# groups <- groups[o] (put earlier)
color <- rep(color, length.out = length(groups))[o]
lcolor <- rep(lcolor, length.out = length(groups))[o]
offset <- cumsum(c(0, diff(as.numeric(groups)) != 0))
y <- 1L:n + 2 * offset
ylim <- range(0.5, y + 1.5) # range(0, y + 2)
}
plot.window(xlim = xlim, ylim = ylim, log = "")
lheight <- par("csi")
if(length(labels)) {
linch <- max(strwidth(labels, "inch", cex=cex.labels), na.rm = TRUE)
loffset <- (linch + 0.1) / lheight
# was line=loffset
mtext(labels, side = 2, line = .1*loffset, at = y, adj = 1,
col = color, las = 2, cex = cex.labels, ...)
}
abline(h = y, lty = "dotted", col = lcolor)
if(length(auxtitle)) {
upedge <- par('usr')[4]
outerText(auxtitle,
upedge + strheight(auxtitle, cex=cex) / 2,
cex=cex)
}
gpos <- if(length(groups))
rev(cumsum(rev(tapply(groups, groups, length)) + 2) - 1)
if(length(auxdata) + length(auxgdata) > 0)
outerText(c(auxdata, auxgdata), c(y, if(length(auxgdata)) gpos),
cex=cex.auxdata)
for(i in 1:nc)
points(x[,i], y, pch = pch[i], col = color, bg = bg)
if(length(groups)) {
ginch <- max(strwidth(glabels, "inch", font=groupfont,
cex=cex.group.labels),
na.rm = TRUE)
goffset <- (max(linch + 0.2, ginch, na.rm = TRUE) + 0.1)/lheight
mtext(glabels, side = 2, line = .2, at = gpos, adj = 1, # was adj=0
col = gcolor, las = 2, cex = cex.group.labels, font=groupfont, ...)
if (length(gdata)) {
abline(h = gpos, lty = "dotted")
if(is.matrix(gdata))
for(j in 1:ncol(gdata))
points(gdata[, j], gpos, pch=gpch[j], col=gcolor, bg=bg, ...)
else
points(gdata, gpos, pch = gpch, col = gcolor, bg = bg,
...)
}
}
if(length(axisat)) axis(1, at=axisat, labels=axislabels)
else
axis(1)
box()
title(main = main, xlab = xlab, ylab = ylab, ...)
invisible()
}
dotchartp <-
function (x, labels = NULL, groups = NULL, gdata = NULL,
xlim = range(c(x, gdata), na.rm=TRUE), main=NULL,
xlab = NULL, ylab = '', auxdata=NULL, auxtitle=NULL,
auxgdata=NULL, auxwhere=c('right', 'hover'),
symbol='circle', col=colorspace::rainbow_hcl,
legendgroup=NULL,
axisat=NULL, axislabels=NULL, sort=TRUE, digits=4, dec=NULL,
height=NULL, width=700, layoutattr=FALSE, showlegend=TRUE,
...)
{
if (!requireNamespace("plotly", quietly=TRUE))
stop("This function requires the 'plotly' package.")
auxwhere <- match.arg(auxwhere)
fmt <- if(length(dec)) function(x) format(round(x, dec))
else
function(x) format(x, digits=digits)
mu <- markupSpecs$html
lspace <- mu$lspace
if (! is.numeric(x))
stop("'x' must be a numeric vector or matrix")
x <- as.matrix(x)
n <- nrow(x)
nc <- ncol(x)
symbol <- rep(symbol, length.out=nc)
col <- if(length(col)) {
if(! is.function(col)) col
else col(ncol(x))
}
col <- rep(col, length.out=nc)
if(length(gdata)) {
gdata <- as.matrix(gdata)
if(ncol(gdata) != nc) stop('gdata must have same columns as x')
}
if(! length(labels)) labels <- rownames(x)
if(! length(labels)) stop('labels not defined')
if(length(groups)) groups <- as.factor(groups)
glabels <- levels(groups)
groups.pres <- length(groups) > 0
if(groups.pres && is.character(sort))
warning('specifying sort does not makes sense with groups present')
if(! groups.pres) {
y <- n : 1
if(is.logical(sort)) sort <- if(sort) 'descending' else 'none'
if(sort != 'none') {
o <- order(if(sort == 'ascending') x[, 1] else - x[, 1])
x <- x[o, , drop=FALSE]
labels <- labels[o]
if(length(auxdata))
auxdata <- if(is.matrix(auxdata))
auxdata[o,, drop=FALSE] else auxdata[o]
}
} else { # groups present
if(is.character(sort) || sort) {
o <- if(is.character(sort)) {
if(sort == 'ascending') order(x[, 1])
else
order(-x[, 1])
} else order(as.integer(groups)) ###, as.integer(labels))
groups <- groups[o]
x <- x[o, , drop=FALSE]
labels <- labels[o]
if(length(auxdata))
auxdata <- if(is.matrix(auxdata))
auxdata[o,, drop=FALSE] else auxdata[o]
}
lgroups <- Lag(as.character(groups))
lgroups[1] <- 'NULL'
first.in.group <- groups != lgroups
y <- cumsum(1 + 1.5 * first.in.group)
yg <- y[first.in.group] - 1
y <- -y
yg <- -yg
} # end groups present
X <- x[, 1]
tly <- y
auxd <- NULL
auxh <- auxwhere == 'hover'
auxt <- if(length(auxtitle) && auxtitle != '')
# ifelse(auxh, paste0(auxtitle, '<br>'), paste0(auxtitle, ':'))
paste0(auxtitle, ':')
else ''
if(auxh)
auxd <- if(length(auxdata))
paste0(auxt,
if(is.matrix(auxdata)) auxdata[, 1] else auxdata)
else rep('', length(X))
if(length(gdata) || (auxh && length(auxgdata))) {
X <- c(X, if(length(gdata)) gdata[, 1] else rep(NA, length(auxgdata)))
tly <- c(tly, yg)
if(auxh) auxd <- c(auxd,
if(length(auxgdata))
paste0(auxt, # was lspace after auxt,
if(is.matrix(auxgdata)) auxgdata[, 1]
else auxgdata)
else rep('', length(yg)))
}
nx <- if(nc == 1) '' else colnames(x)[1]
ht <- if(nx == '') fmt(X)
else paste(nx, '<br>', fmt(X))
if(auxh && any(auxd != '')) ht <- paste0(ht, '<br>', auxd) # <br> was lspace
d <- data.frame(X, y=tly, ht=ht)
if(length(height) && height == 'auto')
height <- plotlyParm$heightDotchart(n)
auto <- .Options$plotlyauto
if(length(auto) && auto) height <- width <- NULL
p <- plotly::plot_ly(d, x=~ X, y=~ y, mode='markers', type='scatter',
marker=list(symbol=symbol[1], color=col[1]),
text = ~ ht,
hoverinfo = 'text',
name=nx,
legendgroup=if(length(legendgroup)) legendgroup[1],
width = width, height=height)
if(nc > 1)
for(i in 2 : nc) {
X <- x[, i]
tly <- y
if(length(gdata)) {
X <- c(X, gdata[, i])
tly <- c(tly, yg)
}
ax <- if(length(auxdata) && is.matrix(auxdata)) auxdata[, i] else ''
d <- data.frame(X=X, y=tly,
ht=paste0(colnames(x)[i], '<br>',
fmt(X), lspace, ax))
p <- plotly::add_markers(p, data=d, x=~ X, y=~ y, #mode='markers',
marker=list(symbol=symbol[i], color=col[i]),
text = ~ ht, hoverinfo='text',
legendgroup=if(length(legendgroup)) legendgroup[i],
name=colnames(x)[i])
}
dx <- 0.1 * diff(xlim)
lenaux <- length(auxdata) + length(auxgdata)
if(auxwhere == 'right' && lenaux) {
yb <- tb <- NULL
if(length(auxdata)) {
yb <- y
tb <- auxdata
}
if(groups.pres && length(auxgdata)) {
yb <- c(yb, yg)
tb <- c(tb, auxgdata)
}
if(length(auxtitle)) {
yb <- c(yb, min(yb) - 2)
tb <- c(tb, auxtitle)
}
if(length(auxgdata)) {
yb <- c(yb, yg)
tb <- c(tb, paste('<b>', auxgdata, '</b>', sep=''))
}
z <- data.frame(xb=xlim[2] + dx, yb, tb)
p <- plotly::add_text(p, data=z, x=~ xb, y=~ yb, text=~ tb, # mode='text',
textposition='left',
textfont=list(size=10), hoverinfo='none', name='')
}
if(length(axisat)) {tlx <- axisat; ttx <- axislabels}
else {
tlx <- pretty(xlim, 10)
tlxs <- pretty(xlim, 5)
ttx <- format(tlx)
for(j in 1 : length(tlx))
if(! any(abs(tlxs - tlx[j]) < 1e-10)) ttx[j] <- ''
}
tly <-y
tty <- as.character(labels)
if(groups.pres) {
tly <- c(tly, yg)
tty <- c(tty, paste('<b>', glabels, '</b>', sep=''))
}
if(! length(ylab)) ylab <- ''
tty <- ifelse(nchar(tty) >= 40, mu$smaller2(tty),
ifelse(nchar(tty) > 20, mu$smaller(tty), tty))
leftmargin <- plotlyParm$lrmargin(tty)
rx <- if(auxwhere == 'right' && lenaux > 0) dx else dx / 2
ylim <- c(min(y) - .15, max(y) + 1.5)
lo <- list(title=main,
xaxis=list(title=xlab,
range=c(xlim[1] - 0.2 * dx,
xlim[2] + rx),
zeroline=FALSE,
tickvals=tlx, ticktext=ttx),
yaxis=list(title=ylab, range=ylim,
zeroline=FALSE,
tickvals=tly, ticktext=tty),
# width=width,
# height=if(length(height) && height == 'auto')
# plotlyParm$heightDotchart(n) else height,
autosize=(length(width) + length(height)) == 0,
margin=list(l=leftmargin, t=5),
showlegend=showlegend)
if(layoutattr) {
attr(p, 'layout') <- lo
return(p)
}
plotly::layout(p,
title = main,
xaxis = list(title=xlab,
range=c(xlim[1] - 0.2 * dx,
xlim[2] + rx),
zeroline=FALSE,
tickvals=tlx, ticktext=ttx),
yaxis = list(title=ylab, range=ylim,
zeroline=FALSE,
tickvals=tly, ticktext=tty),
# width = width,
# height= if(length(height) && height == 'auto')
# plotlyParm$heightDotchart(n) else height,
# autosize=(length(width) + length(height)) == 0,
margin = list(l=leftmargin, t=5),
legendgroup=legendgroup, showlegend = showlegend)
}
summaryD <- function(formula, data=NULL, fun=mean, funm=fun,
groupsummary=TRUE, auxvar=NULL, auxtitle='',
auxwhere=c('hover', 'right'),
vals=length(auxvar) > 0, fmtvals=format,
symbol=if(use.plotly) 'circle' else 21,
col=if(use.plotly) colorspace::rainbow_hcl else 1:10,
legendgroup=NULL,
cex.auxdata=.7, xlab=v[1], ylab=NULL,
gridevery=NULL, gridcol=gray(.95), sort=TRUE, ...) {
use.plotly <- grType() == 'plotly'
auxwhere <- match.arg(auxwhere)
if(! missing(fmtvals)) vals <- TRUE
data <- if(! length(data)) environment(formula)
else list2env(data, parent=environment(formula))
if(length(auxvar) && is.character(auxvar) && missing(auxtitle))
auxtitle <- auxvar
v <- all.vars(formula)
m <- length(v) - 1
yn <- v[1]; xn <- v[-1]
two <- length(xn) == 2
y <- get(yn, envir=data)
x1 <- get(xn[1], envir=data)
x2 <- if(two) get(xn[2], envir=data)
s <- summarize(y, if(two) llist(x1, x2) else llist(x1), fun,
type='matrix', keepcolnames=TRUE)
## if(is.matrix(s$y)) colnames(s$y) <- colnames(y)
cx1 <- if(is.factor(s$x1)) as.integer(s$x1)
else
s$x1
yy <- if(is.matrix(s$y)) s$y[, 1, drop=FALSE] else s$y
if(sort) s <- if(two) s[order(cx1, - yy), ] else s[order(- yy), ]
auxd <- function(z) {
sy <- z$y
if(length(auxvar)) {
if(! is.matrix(sy))
stop('auxvar is only used when fun returns > 1 statistic')
f <- if(vals) fmtvals(sy[, auxvar])
sy <- if(is.numeric(auxvar)) sy[, -auxvar, drop=FALSE]
else
sy[, setdiff(colnames(sy), auxvar), drop=FALSE]
}
else
f <- if(vals) fmtvals(if(is.matrix(sy)) sy[, 1] else sy)
list(sy=sy, fval=f) # sy = remaining y, fval = formatted auxvar
}
z <- auxd(s)
if(two) {
if(groupsummary) {
s2 <- summarize(y, llist(x1), funm, type='matrix', keepcolnames=TRUE)
z2 <- auxd(s2)
}
z <- auxd(s)
col <- if(length(col)) {
if(! is.function(col)) col
else
col(if(is.matrix(z$sy)) ncol(z$sy) else 1)
}
## if already sorted (group variable order first) don't re-sort
## sort causes problems to dotchart3
res <- if(use.plotly)
dotchartp(z$sy, s$x2, groups=s$x1,
auxdata=z$fval, auxtitle=if(vals) auxtitle,
auxwhere=auxwhere,
cex.auxdata=cex.auxdata,
gdata =if(groupsummary) z2$sy,
auxgdata=if(groupsummary) z2$fval,
xlab=xlab, ylab=ylab, symbol=symbol, col=col,
legendgroup=legendgroup, sort=FALSE, ...)
else
dotchart3(z$sy, s$x2, groups=s$x1,
auxdata=z$fval, auxtitle=if(vals) auxtitle,
cex.auxdata=cex.auxdata,
gdata =if(groupsummary) z2$sy,
auxgdata=if(groupsummary) z2$fval,
xlab=xlab, ylab=ylab, pch=symbol, ...)
}
else
res <- if(use.plotly)
dotchartp(z$sy, s$x1, auxdata=z$fval,
auxtitle=if(vals) auxtitle,
auxwhere=auxwhere,
cex.auxdata=cex.auxdata, xlab=xlab, ylab=ylab,
symbol=symbol, col=col, legendgroup=legendgroup,
sort=FALSE, ...)
else
dotchart3(z$sy, s$x1, auxdata=z$fval,
auxtitle=if(vals) auxtitle, pch=symbol,
cex.auxdata=cex.auxdata, xlab=xlab, ylab=ylab, ...)
if(! use.plotly && length(gridevery)) {
xmin <- par('usr')[1]
xmin <- ceiling(xmin / gridevery) * gridevery
xmax <- if(length(xn) == 1) max(s$y, na.rm=TRUE)
else
max(c(s$y, s2$y), na.rm=TRUE)
abline(v=seq(xmin, xmax, by=gridevery), col=gridcol)
}
if(use.plotly) res else invisible(res)
}
summaryDp <-
function(formula,
fun=function(x) c(Mean=mean(x, na.rm=TRUE),
N=sum(! is.na(x))),
overall=TRUE, xlim=NULL, xlab=NULL,
data=NULL, subset=NULL, na.action=na.retain,
ncharsmax=c(50, 30), digits=4, ...) {
Y <- if(length(subset))
model.frame(formula, data=data, subset=subset, na.action=na.action)
else
model.frame(formula, data=data, na.action=na.action)
X <- Y[-1]
y <- Y[[1]]
swr <- function(w, ...)
sapply(strwrap(w, ..., simplify=FALSE),
function(x) paste(x, collapse='<br>'))
addbr <- markupSpecs$html$addBreak
width <- ncharsmax[1]; minbreak <- ncharsmax[2]
if(! length(xlab)) xlab <- swr(label(y, default=names(Y)[1]), width=width)
major <- minor <- ht <- character(0)
x <- numeric(0)
funlabs <- names(fun(y))
nx <- names(X)
if(overall) nx <- c(nx, 'Overall')
for(v in nx) {
if(v == 'Overall') {
by <- rep('Overall', length(y))
bylab <- 'Overall'
} else {
by <- X[[v]]
bylab <- addbr(label(by, default=v), minbreak=minbreak)
}
s <- summarize(y, by, fun)
i <- order(- s[, 2])
s <- s[i, ]
m <- s[, 2]
faux <- paste0(funlabs[1], ': ', format(m, digits=digits))
if(NCOL(s) > 2) {
j <- 0
aux <- s[-(1:2)]
for(a in names(aux)) {
j <- j + 1
faux <- paste0(faux, '<br>', funlabs[j + 1], ': ',
format(aux[[a]], digits=digits))
}
}
major <- c(major, rep(bylab, length(m)))
minor <- c(minor, if(v == 'Overall') '' else as.character(s[, 1]))
ht <- c(ht, faux)
x <- c(x, unname(m))
}
if(! length(xlim)) {
r <- range(x)
xlim <- r + c(-1, 1) * diff(r) / 20
}
dotchartpl(x, major, minor, htext=ht, xlim=xlim, xlab=xlab, ...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.