1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
|
#' 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.')
|
