-
Notifications
You must be signed in to change notification settings - Fork 633
/
Copy pathhighlight.R
170 lines (159 loc) · 6.74 KB
/
highlight.R
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
#' Highlight graphical elements in multiple linked views
#'
#' This function sets a variety of options for brushing (i.e., highlighting)
#' plotly graphs. Use this function to set options (or populate widgets)
#' for a \emph{single} plot. When linking multiple plots, use
#' \code{\link{options}()} to set "global" options, where the option name
#' matches the relevant argument name. For instance,
#' to link multiple plots with \code{persistent} selection, set
#' \code{options(persistent = TRUE)}. To see an example linking plotly to
#' leaflet, see \code{demo("highlight-leaflet", package = "leaflet")}
#'
#' @param p a plotly visualization.
#' @param on turn on a selection on which event(s)? Likely candidates are
#' 'plotly_hover', 'plotly_click', 'plotly_selected'. To disable on events
#' altogether, use \code{NULL}.
#' @param off turn off a selection on which event(s)? Likely candidates are
#' 'plotly_unhover', 'plotly_doubleclick', 'plotly_deselect'. To disable off
#' events altogether, use \code{NULL}.
#' @param persistent should selections persist (i.e., accumulate)?
#' @param dynamic should a widget for changing selection colors be included?
#' @param color character string of color(s) to use for
#' highlighting selections. See \code{\link{toRGB}()} for valid color
#' specifications. If \code{NULL} (the default), the color of selected marks
#' are not altered (only their opacity).
#' @param selectize provide a selectize.js widget for selecting keys? Note that
#' the label used for this widget derives from the groupName of the SharedData object.
#' @param defaultValues a vector of values for setting a "default selection".
#' These values should match the key attribute.
#' @param opacityDim a number between 0 and 1 used to reduce the
#' opacity of non-selected traces (by multiplying with the existing opacity).
#' @param hoverinfo hoverinfo attributes for the selected traces. The default,
#' \code{NULL}, means to inherit the hoverinfo attribute from the non-selected traces.
#' @param showInLegend populate an additional legend entry for the selection?
#' @export
#' @author Carson Sievert
#' @references \url{https://cpsievert.github.io/plotly_book/linking-views-without-shiny.html}
#' @examples
#'
#' library(crosstalk)
#' d <- SharedData$new(txhousing, ~city)
#' p <- ggplot(d, aes(date, median, group = city)) + geom_line()
#' ggplotly(p, tooltip = "city") %>%
#' highlight(on = "plotly_hover", color = "red")
#'
#' # The group name is currently used to populate a title for the selectize widget
#' sd <- SharedData$new(txhousing, ~city, "Choose a city")
#' plot_ly(sd, x = ~date, y = ~median) %>%
#' group_by(city) %>%
#' add_lines(text = ~city, hoverinfo = "text") %>%
#' highlight(on = "plotly_hover", persistent = TRUE, selectize = TRUE)
#'
highlight <- function(p, on = "plotly_selected", off = "plotly_relayout",
persistent = FALSE, dynamic = FALSE, color = NULL,
selectize = FALSE, defaultValues = NULL,
opacityDim = 0.2, hoverinfo = NULL, showInLegend = FALSE) {
if (opacityDim < 0 || 1 < opacityDim) {
stop("opacityDim must be between 0 and 1", call. = FALSE)
}
if (dynamic && length(color) < 2) {
message("Adding more colors to the selection color palette")
color <- c(color, RColorBrewer::brewer.pal(4, "Set1"))
}
if (!dynamic && length(color) > 1) {
warning(
"Can only use a single color for selections when dynamic=FALSE",
call. = FALSE
)
color <- color[1]
}
# attach HTML dependencies (these libraries are used in the HTMLwidgets.renderValue() method)
if (selectize) {
p$dependencies <- c(p$dependencies, list(selectizeLib()))
}
if (dynamic) {
p$dependencies <- c(p$dependencies, list(colourPickerLib()))
}
if (system.file(package = "rmarkdown") != "") {
p$dependencies <- c(p$dependencies, list(rmarkdown::html_dependency_bootstrap("default")))
} else {
message("Install the rmarkdown package for nice font styling in widget labels ")
}
# main (non-plotly.js) spec passed along to HTMLwidgets.renderValue()
p$x$highlight <- list(
# NULL may be used to disable on/off events
on = if (!is.null(on)) match.arg(on, paste0("plotly_", c("click", "hover", "selected"))),
off = if (!is.null(off)) match.arg(off, paste0("plotly_", c("unhover", "doubleclick", "deselect", "relayout"))),
persistent = persistent,
dynamic = dynamic,
# TODO: convert to hex...see colourpicker:::formatHEX()
color = toRGB(color),
selectize = selectize,
defaultValues = defaultValues,
opacityDim = opacityDim,
hoverinfo = hoverinfo,
showInLegend = showInLegend
)
p
}
highlight_defaults <- function() {
formals(highlight)[-1]
}
selectizeLib <- function(bootstrap = TRUE) {
htmltools::htmlDependency(
"selectize", "0.12.0", depPath("selectize"),
stylesheet = if (bootstrap) "selectize.bootstrap3.css",
script = "selectize.min.js"
)
}
colourPickerLib <- function() {
htmltools::htmlDependency(
"colourpicker", "1.1", depPath("colourpicker"),
stylesheet = "colourpicker.min.css",
script = "colourpicker.min.js"
)
}
depPath <- function(...) {
system.file('htmlwidgets', 'lib', ..., package = 'plotly')
}
# ----------------------------------------------------------------------------
# Artifacts from b4 we injected HTML content via JavaScript (so things "just work"
# in all contexts). Hopefully someday htmlwidgets::preprendContent() is
# supported in shiny....
# ----------------------------------------------------------------------------
#
# # Heavily inspired by https://github.com/rstudio/crosstalk/blob/209ac2a2c0cb1e6e23ccec6c1bc1ac7b6ba17ddb/R/controls.R#L105-L125
# selectizeDIV <- function(id, multiple = TRUE, label = NULL, width = "80%", height = "10%") {
# htmltools::tags$div(
# id = id,
# style = sprintf("width: %s; height: '%s'", width, height),
# class = "form-group crosstalk-input-plotly-highlight",
# htmltools::tags$label(class = "control-label", `for` = id, label),
# htmltools::tags$div(
# htmltools::tags$select(multiple = if (multiple) NA else NULL)
# )
# )
# }
#
# # set argument relates to the "crosstalk group"
# colour_widget <- function(colors, set = new_id(), ...) {
#
# w <- colourpicker::colourWidget(
# value = colors[1],
# palette = "limited",
# allowedCols = colors,
# ...
# )
#
# # inform crosstalk when the value of colour widget changes
# htmlwidgets::onRender(w, sprintf("
# function(el, x) {
# var $el = $('#' + el.id);
# var grp = crosstalk.group('%s').var('plotlySelectionColour')
# grp.set($el.colourpicker('value'));
# $el.on('change', function() {
# crosstalk.group('%s').var('plotlySelectionColour').set($el.colourpicker('value'));
# })
# }", set, set))
#
# }