Skip to content

Commit 6bd3f5b

Browse files
cpsievertcpsievert
committed
Improve trace splitting/legend generation algorithm. Fixes #635, #607 
1 parent 6b311a1 commit 6bd3f5b

File tree

3 files changed

+86
-48
lines changed

3 files changed

+86
-48
lines changed

‎R/ggplotly.R

+5-6
Original file line numberDiff line numberDiff line change
@@ -227,14 +227,13 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A
227227
# --------------------------------------------------------------------
228228

229229
aesMap <- lapply(p$layers, function(x) {
230+
# layer level mappings (including stat generated aesthetics)
230231
map <- c(
231-
# plot level aes mappings
232-
as.character(p$mapping),
233-
# layer level mappings
234-
as.character(x$mapping),
235-
# stat specific mappings
232+
as.character(x$mapping),
236233
grep("^\\.\\.", as.character(x$stat$default_aes), value = TRUE)
237234
)
235+
# add on plot-level mappings, if they're inherited
236+
if (isTRUE(x$inherit.aes)) map <- c(map, as.character(p$mapping))
238237
# "hidden" names should be taken verbatim
239238
idx <- grepl("^\\.\\.", map) & grepl("\\.\\.$", map)
240239
hiddenMap <- sub("^\\.\\.", "", sub("\\.\\.$", "", map))
@@ -523,7 +522,7 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A
523522
# To do so, we borrow some of the body of ggplot2:::guides_build().
524523
# ------------------------------------------------------------------------
525524
# will there be a legend?
526-
gglayout$showlegend <- sum(unlist(lapply(traces, "[[", "showlegend"))) > 1
525+
gglayout$showlegend <- sum(unlist(lapply(traces, "[[", "showlegend"))) >= 1
527526

528527
# legend styling
529528
gglayout$legend <- list(

‎R/group2NA.R

+1
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@
2525
group2NA <- function(data, groupNames = "group", nested = NULL, ordered = NULL,
2626
retrace.first = inherits(data, "GeomPolygon")) {
2727
if (NROW(data) == 0) return(data)
28+
data <- data[!duplicated(names(data))]
2829
# a few workarounds since dplyr clobbers classes that we rely on in ggplotly
2930
retrace <- force(retrace.first)
3031
datClass <- class(data)

‎R/layers2traces.R

+80-42
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
# layer -> trace conversion
22
layers2traces <- function(data, prestats_data, layout, p) {
3-
# Attach a "geom class" to each layer of data for method dispatch
3+
# Attach a "geom class" to each layer of data for method dispatch
44
data <- Map(function(x, y) prefix_class(x, class(y$geom)[1]), data, p$layers)
55
# Extract parameters for each layer
66
params <- lapply(p$layers, function(x) {
@@ -20,7 +20,7 @@ layers2traces <- function(data, prestats_data, layout, p) {
2020
datz <- list()
2121
paramz <- list()
2222
for (i in seq_along(data)) {
23-
# This has to be done in a loop, since some layers are really two layers,
23+
# This has to be done in a loop, since some layers are really two layers,
2424
# (and we need to replicate the data/params in those cases)
2525
d <- to_basic(data[[i]], prestats_data[[i]], layout, params[[i]], p)
2626
if (is.data.frame(d)) d <- list(d)
@@ -29,54 +29,47 @@ layers2traces <- function(data, prestats_data, layout, p) {
2929
paramz <- c(paramz, params[j])
3030
}
3131
}
32-
32+
3333
# now to the actual layer -> trace conversion
3434
trace.list <- list()
3535
for (i in seq_along(datz)) {
3636
d <- datz[[i]]
37-
# always split on discrete scales, and other geom specific aesthetics that
38-
# can't translate to a single trace
39-
split_by <- c(split_on(d), names(discreteScales))
40-
# always split on PANEL and domain values (for trace ordering)
41-
split_by <- c("PANEL", paste0(split_by, "_plotlyDomain"))
42-
# split "this layers" data into a list of data frames
43-
idx <- names(d) %in% split_by
44-
# ensure the factor level orders (which determies traces order)
37+
# variables that produce multiple traces and deserve their own legend entries
38+
split_legend <- paste0(names(discreteScales), "_plotlyDomain")
39+
# add variable that produce multiple traces, but do _not_ deserve entries
40+
split_by <- c(split_legend, "PANEL", split_on(d))
41+
# ensure the factor level orders (which determines traces order)
4542
# matches the order of the domain values
46-
lvls <- unique(d[idx])
43+
split_vars <- intersect(split_by, names(d))
44+
lvls <- unique(d[split_vars])
4745
lvls <- lvls[do.call(order, lvls), , drop = FALSE]
46+
separator <- new_id()
4847
fac <- factor(
49-
apply(d[idx], 1, paste, collapse = "@%&"),
50-
levels = apply(lvls, 1, paste, collapse = "@%&")
48+
apply(d[split_vars], 1, paste, collapse = separator),
49+
levels = apply(lvls, 1, paste, collapse = separator)
5150
)
5251
if (all(is.na(fac))) fac <- 1
5352
dl <- split(d, fac, drop = TRUE)
5453
# list of traces for this layer
5554
trs <- Map(geom2trace, dl, paramz[i], list(p))
56-
# are we splitting by a discrete scale on this layer?
57-
# if so, set name/legendgroup/showlegend
58-
isDiscrete <- names(d) %in% paste0(names(discreteScales), "_plotlyDomain")
59-
if (length(trs) > 1 && sum(isDiscrete) >= 1) {
60-
nms <- names(trs)
61-
# ignore "non-discrete" scales that we've split on
62-
for (w in seq_len(sum(names(d) %in% c("PANEL", split_on(d))))) {
63-
nms <- sub("^[^@%&]@%&", "", nms)
64-
}
65-
nms <- strsplit(nms, "@%&")
55+
# if we need a legend, set name/legendgroup/showlegend
56+
# note: this allows us to control multiple traces from one legend entry
57+
if (any(split_legend %in% names(d))) {
58+
nms <- strsplit(names(trs), separator, fixed = TRUE)
6659
nms <- vapply(nms, function(x) {
67-
if (length(x) > 1) paste0("(", paste0(x, collapse = ","), ")") else x
60+
paste(unique(x[seq_along(split_legend)]), collapse = ", ")
6861
}, character(1))
6962
trs <- Map(function(x, y) {
7063
x$name <- y
7164
x$legendgroup <- y
72-
# depending on the geom (e.g. smooth) this may be FALSE already
65+
# depending on the geom (e.g. smooth) this may be FALSE already
7366
x$showlegend <- x$showlegend %||% TRUE
7467
x
7568
}, trs, nms)
7669
} else {
7770
trs <- lapply(trs, function(x) { x$showlegend <- FALSE; x })
7871
}
79-
72+
8073
# each trace is with respect to which axis?
8174
for (j in seq_along(trs)) {
8275
panel <- unique(dl[[j]]$PANEL)
@@ -94,12 +87,12 @@ layers2traces <- function(data, prestats_data, layout, p) {
9487

9588

9689
#' Convert a geom to a "basic" geom.
97-
#'
90+
#'
9891
#' This function makes it possible to convert ggplot2 geoms that
99-
#' are not included with ggplot2 itself. Users shouldn't need to use
92+
#' are not included with ggplot2 itself. Users shouldn't need to use
10093
#' this function. It exists purely to allow other package authors to write
10194
#' their own conversion method(s).
102-
#'
95+
#'
10396
#' @param data the data returned by \code{ggplot2::ggplot_build()}.
10497
#' @param prestats_data the data before statistics are computed.
10598
#' @param layout the panel layout.
@@ -133,7 +126,7 @@ to_basic.GeomBoxplot <- function(data, prestats_data, layout, params, p, ...) {
133126
}
134127
vars <- c("PANEL", "group", aez, grep("_plotlyDomain$", names(data), value = T))
135128
prefix_class(
136-
merge(prestats_data, data[vars], by = c("PANEL", "group"), sort = FALSE),
129+
merge(prestats_data, data[vars], by = c("PANEL", "group"), sort = FALSE),
137130
"GeomBoxplot"
138131
)
139132
}
@@ -311,7 +304,7 @@ to_basic.GeomJitter <- function(data, prestats_data, layout, params, p, ...) {
311304

312305
#' @export
313306
to_basic.GeomErrorbar <- function(data, prestats_data, layout, params, p, ...) {
314-
# width for ggplot2 means size of the entire bar, on the data scale
307+
# width for ggplot2 means size of the entire bar, on the data scale
315308
# (plotly.js wants half, in pixels)
316309
data <- merge(data, layout, by = "PANEL", sort = FALSE)
317310
data$width <- (data$xmax - data$x) /(data$x_max - data$x_min)
@@ -321,7 +314,7 @@ to_basic.GeomErrorbar <- function(data, prestats_data, layout, params, p, ...) {
321314

322315
#' @export
323316
to_basic.GeomErrorbarh <- function(data, prestats_data, layout, params, p, ...) {
324-
# height for ggplot2 means size of the entire bar, on the data scale
317+
# height for ggplot2 means size of the entire bar, on the data scale
325318
# (plotly.js wants half, in pixels)
326319
data <- merge(data, layout, by = "PANEL", sort = FALSE)
327320
data$width <- (data$ymax - data$y) / (data$y_max - data$y_min)
@@ -350,12 +343,12 @@ to_basic.default <- function(data, prestats_data, layout, params, p, ...) {
350343
}
351344

352345
#' Convert a "basic" geoms to a plotly.js trace.
353-
#'
346+
#'
354347
#' This function makes it possible to convert ggplot2 geoms that
355-
#' are not included with ggplot2 itself. Users shouldn't need to use
348+
#' are not included with ggplot2 itself. Users shouldn't need to use
356349
#' this function. It exists purely to allow other package authors to write
357350
#' their own conversion method(s).
358-
#'
351+
#'
359352
#' @param data the data returned by \code{plotly::to_basic}.
360353
#' @param params parameters for the geom, statistic, and 'constant' aesthetics
361354
#' @param p a ggplot2 object (the conversion may depend on scales, for instance).
@@ -453,10 +446,50 @@ geom2trace.GeomBar <- function(data, params, p) {
453446
#' @export
454447
geom2trace.GeomPolygon <- function(data, params, p) {
455448
data <- group2NA(data)
449+
# find data value(s) mapped to this polygon for the hoverinfo
450+
# since hoveron=fills, text needs to be of length 1
451+
452+
# Generate text field from data when hoveron=fills
453+
#
454+
# Text needs to be of length 1 in order for tooltip to work
455+
#
456+
# @param data a data frame
457+
# @param a names character vector. The names should match columns in data
458+
# values values are used as variable names in the resulting text
459+
# hovertext_fill <- function(data, labels) {
460+
# # add the special text field, if it exists
461+
# if ("text" %in% names(data)) {
462+
# labels <- c(labels, c("text" = "text"))
463+
# }
464+
# labels <- labels[names(labels) %in% names(data)]
465+
# if (length(labels) == 0) return(NULL)
466+
# # convert factors to strings so they aren't converted to integers
467+
# # when we combine values
468+
# isFactor <- which(vapply(data, is.factor, logical(1)))
469+
# for (i in isFactor) {
470+
# data[, i] <- as.character(data[, i])
471+
# }
472+
# udata <- unique(data[names(data) %in% names(labels)])
473+
# if (NROW(udata) > 1) {
474+
# warning(
475+
# "When hoveron=fill, can't display more than one value for a given variable",
476+
# call. = FALSE
477+
# )
478+
# }
479+
# paste(
480+
# paste0(labels, ":"),
481+
# as.character(data[1, names(labels)]),
482+
# collapse = "<br />"
483+
# )
484+
# }
485+
# doms <- grep("_plotlyDomain$", names(data), value = TRUE)
486+
# p$labels <- c(p$labels, setNames(sub("_plotlyDomain", "", doms), doms))
487+
# txt <- hovertext_fill(data, p$labels)
488+
456489
L <- list(
457490
x = data$x,
458491
y = data$y,
459-
text = data$hovertext,
492+
text = data$hovertext[1],
460493
key = data$key,
461494
type = "scatter",
462495
mode = "lines",
@@ -472,13 +505,14 @@ geom2trace.GeomPolygon <- function(data, params, p) {
472505
fillcolor = toRGB(
473506
aes2plotly(data, params, "fill"),
474507
aes2plotly(data, params, "alpha")
475-
)
508+
),
509+
hoveron = "fills"
476510
)
477511
if (inherits(data, "GeomSmooth")) {
478512
L$hoverinfo <- "x+y"
479513
}
480514
L
481-
515+
482516
}
483517

484518
#' @export
@@ -542,7 +576,7 @@ geom2trace.GeomTile <- function(data, params, p) {
542576
g <- g[order(g$order), ]
543577
# put fill domain on 0-1 scale for colorscale purposes
544578
g$fill_plotlyDomain <- scales::rescale(g$fill_plotlyDomain)
545-
# create the colorscale
579+
# create the colorscale
546580
colScale <- unique(g[, c("fill_plotlyDomain", "fill")])
547581
# colorscale goes crazy if there are NAs
548582
colScale <- colScale[stats::complete.cases(colScale), ]
@@ -598,6 +632,10 @@ split_on <- function(dat) {
598632
GeomErrorbarh = "colour",
599633
GeomText = "colour"
600634
)
635+
for (i in names(lookup)) {
636+
lookup[[i]] <- paste0(lookup[[i]], "_plotlyDomain")
637+
}
638+
lookup$GeomPolygon <- c(lookup$GeomPolygon, "hovertext")
601639
splits <- lookup[[geom]]
602640
# make sure the variable is in the data, and is non-constant
603641
splits <- splits[splits %in% names(dat)]
@@ -610,7 +648,7 @@ split_on <- function(dat) {
610648
splits
611649
}
612650

613-
# make trace with errorbars
651+
# make trace with errorbars
614652
make_error <- function(data, params, xy = "x") {
615653
color <- aes2plotly(data, params, "colour")
616654
e <- list(
@@ -670,7 +708,7 @@ aes2plotly <- function(data, params, aes = "size") {
670708
height = function(x) { x / 2}
671709
)
672710
if (is.null(converter)) {
673-
warning("A converter for ", aes, " wasn't found. \n",
711+
warning("A converter for ", aes, " wasn't found. \n",
674712
"Please report this issue to: \n",
675713
"https://github.com/ropensci/plotly/issues/new", call. = FALSE)
676714
converter <- identity

0 commit comments

Comments
 (0)