Skip to content

Commit 98dcd96

Browse files
cpsievertcpsievert
committed
traces with missing axis object references should generate new plots
1 parent 975733d commit 98dcd96

File tree

5 files changed

+134
-43
lines changed

5 files changed

+134
-43
lines changed

‎NAMESPACE‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ S3method(ggplotly,ggplot)
1616
S3method(plotly_build,gg)
1717
S3method(plotly_build,plotly_built)
1818
S3method(plotly_build,plotly_hash)
19+
S3method(plotly_build,plotly_subplot)
1920
S3method(print,figure)
2021
S3method(print,plotly_built)
2122
S3method(print,plotly_hash)

‎R/ggplotly.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,7 @@
3232
#'
3333
ggplotly <- function(p = ggplot2::last_plot(), width = NULL, height = NULL,
3434
tooltip = "all", source = "A") {
35-
UseMethod("ggplotly")
35+
UseMethod("ggplotly", p)
3636
}
3737

3838
#' @export

‎R/plotly.R‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -254,9 +254,14 @@ plotly_build.plotly_built <- function(l = last_plot()) {
254254
l
255255
}
256256

257+
#' @export
258+
plotly_build.plotly_subplot <- function(l = last_plot()) {
259+
prefix_class(get_plot(l), "plotly_built")
260+
}
261+
257262
#' @export
258263
plotly_build.gg <- function(l = last_plot()) {
259-
structure(get_plot(ggplotly(l)), class = "plotly_built")
264+
prefix_class(get_plot(ggplotly(l)), "plotly_built")
260265
}
261266

262267
#' @export

‎R/subplots.R‎

Lines changed: 119 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -31,27 +31,73 @@
3131
subplot <- function(..., nrows = 1, widths = NULL, heights = NULL, shareX = FALSE,
3232
shareY = FALSE, margin = 0.02, which_layout = "merge",
3333
keep_titles = FALSE) {
34-
# build each plot and collect relevant info
35-
plots <- lapply(list(...), plotly_build)
34+
# build each plot
35+
plotz <- lapply(list(...), plotly_build)
36+
# ensure "axis-reference" trace attributes are properly formatted
37+
# TODO: should this go inside plotly_build()?
38+
plotz <- lapply(plotz, function(p) {
39+
p$data <- lapply(p$data, function(tr) {
40+
if (length(tr[["geo"]])) {
41+
tr[["geo"]] <- sub("^geo1$", "geo", tr[["geo"]][1]) %||% NULL
42+
tr[["xaxis"]] <- NULL
43+
tr[["yaxis"]] <- NULL
44+
} else {
45+
tr[["geo"]] <- NULL
46+
tr[["xaxis"]] <- sub("^x1$", "x", tr[["xaxis"]][1] %||% "x")
47+
tr[["yaxis"]] <- sub("^y1$", "y", tr[["yaxis"]][1] %||% "y")
48+
}
49+
tr
50+
})
51+
p
52+
})
53+
# Are any traces referencing "axis-like" layout attributes that are missing?
54+
# If so, move those traces to a "new plot", and inherit layout attributes,
55+
# which makes this sort of thing possible:
56+
# https://plot.ly/r/map-subplots-and-small-multiples/
57+
plots <- list()
58+
for (i in seq_along(plotz)) {
59+
p <- plots[[i]] <- plotz[[i]]
60+
layoutAttrs <- names(p$layout)
61+
xTraceAttrs <- sub("^x", "xaxis", sapply(p$data, function(tr) tr[["geo"]] %||% tr[["xaxis"]]))
62+
yTraceAttrs <- sub("^y", "yaxis", sapply(p$data, function(tr) tr[["geo"]] %||% tr[["yaxis"]]))
63+
missingAttrs <- setdiff(c(xTraceAttrs, yTraceAttrs), layoutAttrs)
64+
# move to next iteration if trace references are complete
65+
if (!length(missingAttrs)) next
66+
# remove each "missing" trace from this plot
67+
missingTraces <- xTraceAttrs %in% missingAttrs | yTraceAttrs %in% missingAttrs
68+
plots[[i]]$data[missingTraces] <- NULL
69+
# move traces with "similar missingness" to a new plot
70+
for (j in missingAttrs) {
71+
newPlot <- list(
72+
data = p$data[xTraceAttrs %in% j | yTraceAttrs %in% j],
73+
layout = p$layout
74+
)
75+
# reset the anchors
76+
newPlot$data <- lapply(newPlot$data, function(tr) {
77+
for (k in c("geo", "xaxis", "yaxis")) {
78+
tr[[k]] <- sub("[0-9]+", "", tr[[k]]) %||% NULL
79+
}
80+
tr
81+
})
82+
plots <- c(plots, list(newPlot))
83+
}
84+
}
85+
# main plot objects
3686
traces <- lapply(plots, "[[", "data")
3787
layouts <- lapply(plots, "[[", "layout")
3888
shapes <- lapply(layouts, "[[", "shapes")
39-
# keep non axis title annotations
4089
annotations <- lapply(layouts, function(x) {
90+
# keep non axis title annotations
4191
axes <- vapply(x$annotations, function(a) identical(a$annotationType, "axis"), logical(1))
4292
x$annotations[!axes]
4393
})
4494
# collect axis objects
45-
xAxes <- lapply(layouts, function(x) {
46-
x[grepl("^xaxis", names(x))] %||% list(xaxis = list(domain = c(0, 1), anchor = "y"))
47-
})
48-
yAxes <- lapply(layouts, function(x) {
49-
x[grepl("^yaxis", names(x))] %||% list(yaxis = list(domain = c(0, 1), anchor = "x"))
50-
})
95+
xAxes <- lapply(layouts, function(lay) lay[grepl("^xaxis|^geo", names(lay))])
96+
yAxes <- lapply(layouts, function(lay) lay[grepl("^yaxis|^geo", names(lay))])
5197
# remove their titles
5298
if (!keep_titles) {
53-
xAxes <- lapply(xAxes, function(x) lapply(x, function(y) { y$title <- NULL; y }))
54-
yAxes <- lapply(yAxes, function(x) lapply(x, function(y) { y$title <- NULL; y }))
99+
xAxes <- lapply(xAxes, function(ax) lapply(ax, function(y) { y$title <- NULL; y }))
100+
yAxes <- lapply(yAxes, function(ax) lapply(ax, function(y) { y$title <- NULL; y }))
55101
}
56102
# number of x/y axes per plot
57103
xAxisN <- vapply(xAxes, length, numeric(1))
@@ -68,14 +114,19 @@ subplot <- function(..., nrows = 1, widths = NULL, heights = NULL, shareX = FALS
68114
} else {
69115
seq_len(sum(yAxisN))
70116
}
71-
xAxisMap <- setNames(
72-
unlist(lapply(xAxes, names)),
73-
paste0("xaxis", sub("^1$", "", xAxisID))
117+
# current "axis" names
118+
xCurrentNames <- unlist(lapply(xAxes, names))
119+
yCurrentNames <- unlist(lapply(yAxes, names))
120+
xNewNames <- paste0(
121+
sub("[0-9]+$", "", xCurrentNames),
122+
sub("^1$", "", xAxisID)
74123
)
75-
yAxisMap <- setNames(
76-
unlist(lapply(yAxes, names)),
77-
paste0("yaxis", sub("^1$", "", yAxisID))
124+
yNewNames <- paste0(
125+
sub("[0-9]+$", "", yCurrentNames),
126+
sub("^1$", "", yAxisID)
78127
)
128+
xAxisMap <- setNames(xCurrentNames, xNewNames)
129+
yAxisMap <- setNames(yCurrentNames, yNewNames)
79130
# split the map by plot ID
80131
xAxisMap <- split(xAxisMap, rep(seq_along(plots), xAxisN))
81132
yAxisMap <- split(yAxisMap, rep(seq_along(plots), yAxisN))
@@ -93,35 +144,64 @@ subplot <- function(..., nrows = 1, widths = NULL, heights = NULL, shareX = FALS
93144
xDom <- as.numeric(domainInfo[i, c("xstart", "xend")])
94145
yDom <- as.numeric(domainInfo[i, c("yend", "ystart")])
95146
for (j in seq_along(xAxes[[i]])) {
96-
# before bumping axis anchor, bump trace info, where appropriate
147+
# TODO: support ternary as well!
148+
isGeo <- grepl("^geo", xMap[[j]])
149+
anchorKey <- if (isGeo) "geo" else "xaxis"
97150
traces[[i]] <- lapply(traces[[i]], function(tr) {
98-
tr$xaxis <- tr$xaxis %||% "x"
99-
tr$xaxis[sub("axis", "", xMap[[j]]) %in% tr$xaxis] <- sub("axis", "", names(xMap[j]))
151+
tr[[anchorKey]] <- tr[[anchorKey]] %||% sub("axis", "", anchorKey)
152+
# bump trace anchors, where appropriate
153+
if (sub("axis", "", xMap[[j]]) %in% tr[[anchorKey]]) {
154+
tr[[anchorKey]] <- sub("axis", "", names(xMap[j]))
155+
}
100156
tr
101157
})
102-
# bump anchors
103-
map <- yMap[yMap %in% sub("y", "yaxis", xAxes[[i]][[j]]$anchor %||% "y")]
104-
xAxes[[i]][[j]]$anchor <- sub("axis", "", names(map))
105-
xAxes[[i]][[j]]$domain <- sort(scales::rescale(
106-
xAxes[[i]][[j]]$domain %||% c(0, 1), xDom, from = c(0, 1)
107-
))
158+
if (isGeo) {
159+
xAxes[[i]][[j]]$domain$x <- sort(scales::rescale(
160+
xAxes[[i]][[j]]$domain$x %||% c(0, 1), xDom, from = c(0, 1)
161+
))
162+
xAxes[[i]][[j]]$domain$y <- sort(scales::rescale(
163+
xAxes[[i]][[j]]$domain$y %||% c(0, 1), yDom, from = c(0, 1)
164+
))
165+
} else {
166+
xAxes[[i]][[j]]$domain <- sort(scales::rescale(
167+
xAxes[[i]][[j]]$domain %||% c(0, 1), xDom, from = c(0, 1)
168+
))
169+
# for cartesian, bump corresponding axis
170+
map <- yMap[yMap %in% sub("y", "yaxis", xAxes[[i]][[j]]$anchor %||% "y")]
171+
xAxes[[i]][[j]]$anchor <- sub("axis", "", names(map))
172+
}
108173
}
109174
for (j in seq_along(yAxes[[i]])) {
175+
# TODO: support ternary as well!
176+
isGeo <- grepl("^geo", yMap[[j]])
177+
anchorKey <- if (isGeo) "geo" else "yaxis"
110178
traces[[i]] <- lapply(traces[[i]], function(tr) {
111-
tr$yaxis <- tr$yaxis %||% "y"
112-
tr$yaxis[sub("axis", "", yMap[[j]]) %in% tr$yaxis] <- sub("axis", "", names(yMap[j]))
179+
tr[[anchorKey]] <- tr[[anchorKey]] %||% sub("axis", "", anchorKey)
180+
# bump trace anchors, where appropriate
181+
if (sub("axis", "", yMap[[j]]) %in% tr[[anchorKey]]) {
182+
tr[[anchorKey]] <- sub("axis", "", names(yMap[j]))
183+
}
113184
tr
114185
})
115-
map <- xMap[xMap %in% sub("x", "xaxis", yAxes[[i]][[j]]$anchor %||% "x")]
116-
yAxes[[i]][[j]]$anchor <- sub("axis", "", names(map))
117-
yAxes[[i]][[j]]$domain <- sort(scales::rescale(
118-
yAxes[[i]][[j]]$domain %||% c(0, 1), yDom, from = c(0, 1)
119-
))
186+
if (isGeo) {
187+
yAxes[[i]][[j]]$domain$x <- sort(scales::rescale(
188+
yAxes[[i]][[j]]$domain$x %||% c(0, 1), xDom, from = c(0, 1)
189+
))
190+
yAxes[[i]][[j]]$domain$y <- sort(scales::rescale(
191+
yAxes[[i]][[j]]$domain$y %||% c(0, 1), yDom, from = c(0, 1)
192+
))
193+
} else {
194+
yAxes[[i]][[j]]$domain <- sort(scales::rescale(
195+
yAxes[[i]][[j]]$domain %||% c(0, 1), yDom, from = c(0, 1)
196+
))
197+
# for cartesian, bump corresponding axis
198+
map <- xMap[xMap %in% sub("x", "xaxis", yAxes[[i]][[j]]$anchor %||% "x")]
199+
yAxes[[i]][[j]]$anchor <- sub("axis", "", names(map))
200+
}
120201
}
121202
xAxes[[i]] <- setNames(xAxes[[i]], names(xMap))
122203
yAxes[[i]] <- setNames(yAxes[[i]], names(yMap))
123204
}
124-
125205
# start merging the plots into a single subplot
126206
p <- list(
127207
data = Reduce(c, traces),
@@ -131,7 +211,7 @@ subplot <- function(..., nrows = 1, widths = NULL, heights = NULL, shareX = FALS
131211
p$layout$shapes <- Reduce(c, shapes)
132212

133213
# merge non-axis layout stuff
134-
layouts <- lapply(layouts, function(x) x[!grepl("^[x-y]axis", names(x))] %||% list())
214+
layouts <- lapply(layouts, function(x) x[!grepl("^[x-y]axis|^geo", names(x))] %||% list())
135215
if (which_layout != "merge") {
136216
if (!is.numeric(which_layout)) warning("which_layout must be numeric")
137217
if (!all(idx <- which_layout %in% seq_along(plots))) {
@@ -141,7 +221,9 @@ subplot <- function(..., nrows = 1, widths = NULL, heights = NULL, shareX = FALS
141221
layouts <- layouts[which_layout]
142222
}
143223
p$layout <- c(p$layout, Reduce(modifyList, layouts))
144-
hash_plot(data.frame(), p)
224+
225+
res <- hash_plot(data.frame(), p)
226+
prefix_class(res, "plotly_subplot")
145227
}
146228

147229

@@ -160,7 +242,7 @@ get_domains <- function(nplots = 1, nrows = 1, margins = 0.01,
160242
stop("The length of the heights argument must be equal ",
161243
"to the number of rows", call. = FALSE)
162244
}
163-
if (any(widths < 0 | heights < 0)) {
245+
if (any(widths < 0) | any(heights < 0)) {
164246
stop("The widths and heights arguments must contain positive values")
165247
}
166248
if (sum(widths) > 1 | sum(heights) > 1) {
@@ -173,7 +255,6 @@ get_domains <- function(nplots = 1, nrows = 1, margins = 0.01,
173255
widths <- widths + (1 - max(widths)) / 2
174256
heights <- heights + (1 - max(heights)) / 2
175257

176-
177258
xs <- vector("list", ncols)
178259
for (i in seq_len(ncols)) {
179260
xs[[i]] <- c(

‎man/subplot.Rd‎

Lines changed: 7 additions & 3 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)