#' plotly Multiple
#'
#' Generates multiple plotly graphics, driven by specs in a data frame
#'
#' Generates multiple \code{plotly} traces and combines them with \code{plotly::subplot}. The traces are controlled by specifications in data frame \code{data} plus various arguments. \code{data} must contain these variables: \code{x}, \code{y}, and \code{tracename} (if \code{color} is not an "AsIs" color such as \code{~ I('black')}), and can contain these optional variables: \code{xhi}, \code{yhi} (rows containing \code{NA} for both \code{xhi} and \code{yhi} represent points, and those with non-\code{NA} \code{xhi} or \code{yhi} represent segments, \code{connect} (set to \code{TRUE} for rows for points, to connect the symbols), \code{legendgroup} (see \code{plotly} documentation), and \code{htext} (hovertext). If the \code{color} argument is given and it is not an "AsIs" color, the variable named in the \code{color} formula must also be in \code{data}. Likewise for \code{size}. If the \code{multplot} is given, the variable given in the formula must be in \code{data}. If \code{strata} is present, another level of separate plots is generated by levels of \code{strata}, within levels of \code{multplot}.
#'
#' If \code{fitter} is specified, x,y coordinates for an individual plot are
#' run through \code{fitter}, and a line plot is made instead of showing data points. Alternatively you can specify \code{fitter='ecdf'} to compute and plot emirical cumulative distribution functions.
#'
#' @param data input data frame
#' @param x formula specifying the x-axis variable
#' @param y formula for y-axis variable
#' @param xhi formula for upper x variable limits (\code{x} taken to be lower value)
#' @param yhi formula for upper y variable limit (\code{y} taken to be lower value)
#' @param htext formula for hovertext variable
#' @param multplot formula specifying a variable in \code{data} that when stratified on produces a separate plot
#' @param strata formula specifying an optional stratification variable
#' @param fitter a fitting such as \code{loess} that comes with a \code{predict} method. Alternatively specify \code{fitter='ecdf'} to use an internal function for computing and displaying ECDFs, which moves the analysis variable from the y-axis to the x-axis
#' @param color \code{plotly} formula specifying a color variable or e.g. \code{~ I('black')}. To keep colors constant over multiple plots you will need to specify an AsIs color when you don't have a variable representing color groups.
#' @param size \code{plotly} formula specifying a symbol size variable or AsIs
#' @param showpts if \code{fitter} is given, set to \code{TRUE} to show raw data points in addition to smooth fits
#' @param rotate set to \code{TRUE} to reverse the roles of \code{x} and \code{y}, for example to get horizontal dot charts with error bars
#' @param xlab x-axis label. May contain html.
#' @param ylab a named vector of y-axis labels, possibly containing html (see example below). The names of the vector must correspond to levels of the \code{multplot} variable. \code{ylab} can be unnamed if \code{multplot} is not used.
#' @param ylabpos position of y-axis labels. Default is on top left of plot. Specify \code{ylabpos='y'} for usual y-axis placement.
#' @param xlim 2-vector of x-axis limits, optional
#' @param ylim 2-vector of y-axis limits, optional
#' @param shareX specifies whether x-axes should be shared when they align vertically over multiple plots
#' @param shareY specifies whether y-axes should be shared when they align horizontally over multiple plots
#' @param nrows the number of rows to produce using \code{subplot}
#' @param ncols the number of columns to produce using \code{subplot} (specify at most one of \code{nrows,ncols})
#' @param height height of the combined image in pixels
#' @param width width of the combined image in pixels
#' @param colors the color palette. Leave unspecified to use the default \code{plotly} palette
#' @param alphaSegments alpha transparency for line segments (when \code{xhi} or \code{yhi} is not \code{NA})
#' @param alphaCline alpha transparency for lines used to connect points
#' @param digits number of significant digits to use in constructing hovertext
#' @param zeroline set to \code{FALSE} to suppress vertical line at x=0
#'
#' @return \code{plotly} object produced by \code{subplot}
#' @author Frank Harrell
#' @examples
#' \dontrun{
#' set.seed(1)
#' pts <- expand.grid(v=c('y1', 'y2', 'y3'), x=1:4, g=c('a', 'b'), yhi=NA,
#' tracename='mean', legendgroup='mean',
#' connect=TRUE, size=4)
#'
#' pts$y <- round(runif(nrow(pts)), 2)
#'
#' segs <- expand.grid(v=c('y1', 'y2', 'y3'), x=1:4, g=c('a', 'b'),
#' tracename='limits', legendgroup='limits',
#' connect=NA, size=6)
#' segs$y <- runif(nrow(pts))
#' segs$yhi <- segs$y + runif(nrow(pts), .05, .15)
#'
#' z <- rbind(pts, segs)
#'
#' xlab <- labelPlotmath('X<sub>12</sub>', 'm/sec<sup>2</sup>', html=TRUE)
#' ylab <- c(y1=labelPlotmath('Y1', 'cm', html=TRUE),
#' y2='Y2',
#' y3=labelPlotmath('Y3', 'mm', html=TRUE))
#'
#' W=plotlyM(z, multplot=~v, color=~g, xlab=xlab, ylab=ylab, ncols=2,
#' colors=c('black', 'blue'))
#'
#' W2=plotlyM(z, multplot=~v, color=~I('black'), xlab=xlab, ylab=ylab,
#' colors=c('black', 'blue'))
#'
#' }
#' @export
plotlyM <- function(data, x=~x, y=~y, xhi=~xhi, yhi=~yhi, htext=NULL,
multplot=NULL, strata=NULL, fitter=NULL,
color=NULL, size=NULL,
showpts=! length(fitter),
rotate=FALSE, xlab=NULL, ylab=NULL,
ylabpos=c('top', 'y'),
xlim=NULL, ylim=NULL,
shareX=TRUE, shareY=FALSE, height=NULL, width=NULL,
nrows=NULL, ncols=NULL,
colors=NULL, alphaSegments=1, alphaCline=0.3, digits=4,
zeroline=TRUE) {
if (!requireNamespace("plotly"))
stop("This function requires the 'plotly' package.")
auto <- .Options$plotlyauto
if(length(auto) && auto) height <- width <- NULL
ylabpos <- match.arg(ylabpos)
if(rotate) {
xf <- y #~ y
yf <- x #~ x
xfe <- yhi #~ yhi
yfe <- xhi #~ xhi
} else {
xf <- x #~ x
yf <- y #~ y
xfe <- xhi #~ xhi
yfe <- yhi #~ yhi
}
xn <- all.vars(xf) #x)
yn <- all.vars(yf) #y)
xhin <- all.vars(xfe) #xhi)
yhin <- all.vars(yfe) #yhi)
n <- nrow(data)
if(! length(multplot)) {
multplot <- ~ .v.
data$.v. <- rep(' ', n)
} else data$.v. <- data[[all.vars(multplot)]]
vlevs <- levels(as.factor(data$.v.))
lastv <- vlevs[length(vlevs)]
strpres <- length(strata) > 0
strata <- if(strpres) as.factor(data[[all.vars(strata)]])
else
as.factor(rep('', nrow(data)))
stlevs <- levels(strata)
lasts <- stlevs[length(stlevs)]
if(! length(nrows) && ! length(ncols) && strpres)
ncols <- length(stlevs)
if(length(ylab) && ! length(names(ylab))) names(ylab) <- vlevs
if(! length(ylab)) ylab <- structure(vlevs, names=vlevs)
fmt <- function(x) htmlSN(x, digits=digits)
nam <- names(data)
if(xhin %nin% nam) data[[xhin]] <- rep(NA, n)
if(yhin %nin% nam) data[[yhin]] <- rep(NA, n)
if('connect' %nin% nam) data$connect <- rep(FALSE, n)
if('tracename' %in% nam && 'legendgroup' %nin% nam)
data$legendgroup <- data$tracename
if(length(color)) {
## ~ I('black') will not show inherits('AsIs') but all.vars is char(0)
colasis <- ! length(all.vars(color))
traceform <- if(colasis) ~ tracename
legendgroupform <- if(colasis) ~ legendgroup
colvar <- if(! colasis) all.vars(color)
}
else if(length(size)) {
sizeasis <- ! length(all.vars(color))
traceform <- if(sizeasis) ~ tracename
legendgroupform <- if(sizeasis) ~ legendgroup
sizevar <- if(! sizeasis) all.vars(size)
}
else {
traceform <- if('tracename' %in% nam) ~ tracename
legendgroupform <- if('legendgroup' %in% nam) ~ legendgroup
colasis <- FALSE
colvar <- NULL
sizeasis <- FALSE
sizevar <- NULL
}
if(length(color)) legendgroupform <- color
usualfitter <- length(fitter) && is.function(fitter)
is.ecdf <- length(fitter) && is.character(fitter) && fitter == 'ecdf'
xpresent <- ! is.ecdf
runfit <- if(usualfitter) function() {
xv <- all.vars(xf)
yv <- all.vars(yf)
x <- pt[[xv]]
y <- pt[[yv]]
g <- if(length(colvar))
pt[[colvar]] else rep('', nrow(pt))
g <- as.factor(g)
d <- data.frame(x, y, g)
Dp <- NULL
xgrid <- seq(min(x, na.rm=TRUE), max(x, na.rm=TRUE), length=150)
dx <- data.frame(x = xgrid)
for(gv in levels(g)) {
f <- fitter(y ~ x, data=subset(d, g == gv))
y <- predict(f, newdata=dx)
dp <- cbind(dx, y, g=gv)
Dp <- rbind(Dp, dp)
}
names(Dp) <- c(xv, yv, if(length(colvar)) colvar else 'g')
Dp
}
else
if(is.ecdf) function() {
yv <- all.vars(xf)
y <- pt[[yv]]
g <- if(length(colvar))
pt[[colvar]] else rep('', nrow(pt))
g <- as.factor(g)
Dp <- NULL
rng <- range(y, na.rm=TRUE)
for(gv in levels(g)) {
j <- g == gv & ! is.na(y)
yg <- sort(y[j])
n <- length(yg)
vals <- unique(yg) # see stats::ecdf
a <- approx(vals, cumsum(tabulate(match(yg, vals))) / n,
method='constant', yleft=0, yright=1, f=0,
ties='ordered', xout=vals)
delta <- diff(rng) * 0.025
a$x <- c(min(a$x) - delta, a$x, max(a$x) + delta)
a$y <- c(0, a$y, 1)
dp <- data.frame(x = a$x, y = a$y, g=gv)
Dp <- rbind(Dp, dp)
}
names(Dp) <- c(yv, 'ecdf', if(length(colvar)) colvar else 'g')
Dp
}
xlabc <- if(length(xlab)) paste0(xlab, ': ')
llab <- ifelse('tracename' %in% nam,
as.character(data$tracename), 'Limits')
wl <- function(n, hin)
paste0(xlabc, fmt(data[[hin]]),
'<br>', llab, ':[',
fmt(data[[n]]), ', ',
fmt(data[[hin]]), ']')
if(! length(htext)) {
nhi <- is.na(data[[xhin]]) + is.na(data[[yhin]])
whi <- ifelse(nhi == 2, 'xy', ## which vars missing hi?
ifelse(nhi == 0, '',
ifelse(is.na(data[[xhin]]), 'x', 'y')))
data$htxt <- ifelse(whi == 'xy',
paste0(xlabc, fmt(data[[xn]]),
'<br>',
ylab[data$.v.], ':', fmt(data[[yn]])),
ifelse(whi == 'x', wl(yn, yhin),
ifelse(whi == 'y', wl(xn, xhin),
paste0(xlabc, fmt(data[[xn]]),
'<br>', xn, ' ', llab, ': [',
fmt(data[[xn]]), ', ', fmt(data[[xhin]]), ']',
'<br>', yn, ' ', llab, ': [',
fmt(data[[yn]]), ', ', fmt(data[[yhin]]), ']'))))
htext <- ~ htxt
}
p <- plotly::plot_ly(height=height, width=width, colors=colors)
## For some reason colors doesn't always take in add_*
P <- list()
iv <- 0
# axislab <- character(0)
# axn1 <- if(rotate) 'yaxis' else 'xaxis'
# axn2 <- if(rotate) 'xaxis' else 'yaxis'
for(vn in vlevs) {
for(sn in stlevs) {
iv <- iv + 1
whichaxis <- if(iv == 1) '' else iv
if(is.ecdf) {
ax1 <- ylab[vn]
ax2 <- 'Cumulative Probability'
xn <- yn
xf <- yf
yf <- ~ ecdf
} else {
ax1 <- if(rotate) ylab[vn] else xlab
ax2 <- if(rotate) xlab else ylab[vn]
}
w <- subset(data, .v. == vn & strata == sn)
wxn <- w[[xn]] # if(xpresent) w[[xn]] else 1 : nrow(w)
j <- if(length(colvar)) order(w[[colvar]], wxn)
else
if(length(sizevar)) order(w[[sizevar]], wxn)
else order(wxn)
w <- w[j, ]
r <- p
ipt <- is.na(w[[yhin]]) & is.na(w[[xhin]])
pt <- w[ipt, ]
conct <- is.logical(pt$connect) && pt$connect[1]
if(nrow(pt)) {
if(length(fitter)) {
Dp <- runfit()
r <- plotly::add_lines(r, data=Dp, x=xf, y=yf,
name=traceform, legendgroup=legendgroupform,
showlegend=vn==lastv & sn==lasts,
color=color, size=size,
colors=colors,
line=if(is.ecdf) list(shape='hv'))
}
if(showpts) {
r <- plotly::add_markers(r, data=pt, x=xf, y=yf,
name=traceform, legendgroup=legendgroupform,
showlegend=vn==lastv & sn==lasts,
color=color, size=size,
text=htext, hoverinfo='text', colors=colors)
if(conct)
r <- plotly::add_lines(r, data=pt, x=xf, y=yf,
name=traceform, legendgroup=legendgroupform,
showlegend=FALSE, color=color,
size=I(1),
hoverinfo='none', colors=colors, alpha=alphaCline)
}
}
s <- w[! ipt, ]
if(nrow(s)) {
## If only one of xhi and yhi is missing, need to copy non-NA
## value from x/y. Must go to extra trouble to preserve factors
m <- is.na(s[[xhin]])
if(any(m)) {
a <- s[[xn]]
a[! m] <- s[! m, xhin]
s[[xhin]] <- a
}
m <- is.na(s[[yhin]])
if(any(m)) {
a <- s[[yn]]
a[! m] <- s[! m, yhin]
s[[yhin]] <- a
}
r <-
plotly::add_segments(r, data=s, x=xf, y=yf, xend=xfe, yend=yfe,
name=traceform, legendgroup=legendgroupform,
showlegend=vn==lastv & sn==lasts,
color=color, size=size,
colors=colors, alpha=alphaSegments,
text=htext, hoverinfo='text')
}
## rdocumentation.org/packages/plotly/versions/4.7.1/topics/add_annotations
## https://plot.ly/r/text-and-annotations/
## plot.ly/r/text-and-annotations/#set-annotation-coordinate-references
firstst <- length(stlevs) > 1 && vn == vlevs[1]
if(firstst || ylabpos == 'top') {
lab <- ax2
if(firstst) lab <- paste0(lab, '<br>', sn)
r <- plotly::add_annotations(r, x=0, y=1,
xref='paper', xanchor='left',
yref='paper', yanchor='bottom',
text=paste0('<b>', lab, '</b>'),
showarrow=FALSE,
font=list(color='rgba(25, 25, 112, 1.0)',
size=14))
## midnight blue
}
r <- plotly::layout(r, xaxis=list(title=ax1, range=xlim,
zeroline=zeroline),
yaxis=list(title=if(ylabpos == 'y') ax2 else '',
range=ylim))
P[[iv]] <- r
}
}
if(length(ncols)) nrows <- ceil(iv / ncols)
if(length(stlevs) > 1) shareY <- TRUE
if(length(P) == 1) P <- P[[1]]
else {
P <- if(length(nrows))
plotly::subplot(P, shareX=shareX, shareY=shareY,
titleX=TRUE, titleY=TRUE, nrows=nrows)
else
plotly::subplot(P, shareX=shareX, shareY=shareY,
titleX=TRUE, titleY=TRUE)
}
P
}
utils::globalVariables('.v.')
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.