Allow highlight() selectize to contain selectize.js options

DESCRIPTION

@@ -79,6 +79,6 @@ Suggests:
     reticulate,
     rsvg
 LazyData: true
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.3
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)

NEWS.md

@@ -1,8 +1,13 @@
 # 4.10.1.9000
 
+## New features
+
+* Closed #2216: Additional selectize.js options can now be passed along to `highlight()`'s `selectize` argument. (#2217)
+
 ## Bug fixes
 
-* `ggplotly()` no longer errors given a `geom_area()` with 1 or less data points (error introduced by new behavior in ggplot2 v3.4.0). (#2209)
+* Closed #2218: `highlight(selectize = TRUE)` no longer yields an incorrect selectize.js result when there is a combination of crosstalk and non-crosstalk traces. (#2217) 
+* Closed #2208: `ggplotly()` no longer errors given a `geom_area()` with 1 or less data points (error introduced by new behavior in ggplot2 v3.4.0). (#2209)
 
 
 # 4.10.1

R/highlight.R

@@ -36,8 +36,10 @@
 #' highlighting selections. See [toRGB()] for valid color
 #' specifications. If `NULL` (the default), the color of selected marks
 #' are not altered.
-#' @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 selectize whether or not to render a selectize.js widget for selecting
+#'   [highlight_key()] values. A list of additional selectize.js options may
+#'   also be provided. The label used for this widget should be set via the
+#'   `groupName` argument of [highlight_key()].
 #' @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
@@ -115,7 +117,7 @@ highlight <- function(p, on = "plotly_click", off,
 
   # attach HTML dependencies (these libraries are used in the HTMLwidgets.renderValue() method)
   # TODO: only attach these when keys are present!
-  if (selectize) {
+  if (!identical(selectize, FALSE)) {
     p$dependencies <- c(p$dependencies, list(selectizeLib()))
   }
   if (dynamic) {

R/utils.R

@@ -366,31 +366,32 @@ supply_highlight_attrs <- function(p) {
   # set "global" options via crosstalk variable
   p$x$highlight <- p$x$highlight %||% highlight_defaults()
 
-  # defaults are now populated, allowing us to populate some other 
-  # attributes such as the selectize widget definition
-  sets <- unlist(lapply(p$x$data, "[[", "set"))
-  keys <- setNames(lapply(p$x$data, "[[", "key"), sets)
-  p$x$highlight$ctGroups <- i(unique(sets))
+  # Grab the special "crosstalk set" (i.e., group) for each trace
+  sets <- lapply(p$x$data, "[[", "set")
+  noSet <- vapply(sets, is.null, logical(1))
+
+  # If no sets are present, there's nothing more to do
+  if (all(noSet)) {
+    return(p)
+  }
+
+  # Store the unique set of crosstalk sets (which gets looped over client-side) 
+  p$x$highlight$ctGroups <- i(unique(unlist(sets)))
+
+  # Build a set -> key mapping for each relevant trace, which we'll use
+  # to set default values and/or build the selectize.js payload (if relevant)
+  setDat <- p$x$data[!noSet]
+  keys <- setNames(lapply(setDat, "[[", "key"), sets[!noSet])
 
-  # TODO: throw warning if we don't detect valid keys?
-  hasKeys <- FALSE
   for (i in p$x$highlight$ctGroups) {
+
+    # Get all the keys for this crosstalk group
     k <- unique(unlist(keys[names(keys) %in% i], use.names = FALSE))
-    if (is.null(k)) next
     k <- k[!is.null(k)]
-    hasKeys <- TRUE
-
-    # include one selectize dropdown per "valid" SharedData layer
-    if (isTRUE(p$x$highlight$selectize)) {
-      # Hash i (the crosstalk group id) so that it can be used
-      # as an HTML id client-side (i.e., key shouldn't contain spaces)
-      p$x$selectize[[rlang::hash(i)]] <- list(
-        items = data.frame(value = k, label = k), group = i
-      )
-    }
+    if (length(k) == 0) next
 
     # set default values via crosstalk api
-    vals <- p$x$highlight$defaultValues[p$x$highlight$defaultValues %in% k]
+    vals <- intersect(p$x$highlight$defaultValues, k)
     if (length(vals)) {
       p <- htmlwidgets::onRender(
         p, sprintf(
@@ -399,20 +400,44 @@ supply_highlight_attrs <- function(p) {
         )
       )
     }
+
+    # include one selectize dropdown per "valid" SharedData layer
+    selectize <- p$x$highlight$selectize %||% FALSE
+    if (!identical(selectize, FALSE)) {
+      options <- list(items = data.frame(value = k, label = k), group = i)
+      if (!is.logical(selectize)) {
+        options <- modify_list(options, selectize)
+      }
+      # Hash i (the crosstalk group id) so that it can be used
+      # as an HTML id client-side (i.e., key shouldn't contain spaces)
+      groupId <- rlang::hash(i)
+
+      # If the selectize payload has already been built, use that already built payload
+      # (since it may have been modified at this point), unless there are new keys to consider
+      oldSelectize <- p$x$selectize[[groupId]]
+      if (length(oldSelectize) > 0) {
+        missingKeys <- setdiff(k, oldSelectize$items$value)
+        if (length(missingKeys) > 0) {
+          warning("Overwriting the existing selectize payload for group '", i, "'. If you've previously modified this payload in some way, consider modifying it again.")
+        } else {
+          options <- oldSelectize
+        }
+      } 
+
+      p$x$selectize[[groupId]] <- options
+    }
   }
 
-  # add HTML dependencies, set a sensible dragmode default, & throw messages
-  if (hasKeys) {
-    p$x$layout$dragmode <- p$x$layout$dragmode %|D|% 
-      default(switch(p$x$highlight$on %||% "", plotly_selected = "select", plotly_selecting = "select") %||% "zoom")
-    if (is.default(p$x$highlight$off)) {
-      message(
-        sprintf(
-          "Setting the `off` event (i.e., '%s') to match the `on` event (i.e., '%s'). You can change this default via the `highlight()` function.",
-          p$x$highlight$off, p$x$highlight$on
-        )
+  # set a sensible dragmode default, & throw messages
+  p$x$layout$dragmode <- p$x$layout$dragmode %|D|% 
+    default(switch(p$x$highlight$on %||% "", plotly_selected = "select", plotly_selecting = "select") %||% "zoom")
+  if (is.default(p$x$highlight$off)) {
+    message(
+      sprintf(
+        "Setting the `off` event (i.e., '%s') to match the `on` event (i.e., '%s'). You can change this default via the `highlight()` function.",
+        p$x$highlight$off, p$x$highlight$on
       )
-    }
+    )
   }
 
   p

inst/htmlwidgets/plotly.js

@@ -521,15 +521,17 @@ HTMLWidgets.widget({
       // communication between the widget and direct manipulation events
       if (x.selectize) {
         var selectizeID = Object.keys(x.selectize)[i];
-        var items = x.selectize[selectizeID].items;
+        var options = x.selectize[selectizeID];
         var first = [{value: "", label: "(All)"}];
-        var opts = {
-          options: first.concat(items),
-          searchField: "label",
-          valueField: "value",
-          labelField: "label",
-          maxItems: 50
-        };
+        var opts = $.extend({
+            options: first.concat(options.items),
+            searchField: "label",
+            valueField: "value",
+            labelField: "label",
+            maxItems: 50
+          }, 
+          options
+        );
         var select = $("#" + selectizeID).find("select")[0];
         var selectize = $(select).selectize(opts)[0].selectize;
         // NOTE: this callback is triggered when *directly* altering 

tests/testthat/test-animate-highlight.R

@@ -81,6 +81,50 @@ test_that("group_by.plotly() retains crosstalk set", {
   expect_true(all(b$x$data[[1]]$key == row.names(mtcars)))
 })
 
+test_that("highlight(selectize) produces a sensible payload", {
+  p <- plot_ly() %>%
+    add_lines(data = mtcars, x = ~wt, y = ~mpg) %>%
+    add_markers(
+      data = highlight_key(mtcars, ~cyl, "Choose cylinder"),
+      x = ~wt, y = ~mpg
+    )
+
+  # Builds basic payload when selectize=TRUE
+  b <- p %>%
+    highlight(selectize = TRUE) %>%
+    plotly_build()
+
+  selectize <- list(
+    items = data.frame(value = c(6, 4, 8), label = c(6, 4, 8)), 
+    group = "Choose cylinder"
+  )
+
+  expect_length(b$x$selectize, 1)
+  expect_equal(b$x$selectize[[1]], selectize)
+
+  # Copies over any list() options
+  b2 <- p %>%
+    highlight(selectize = list(plugins = list("remove_button"))) %>%
+    plotly_build()
+
+  selectize$plugins <- list("remove_button")
+
+  expect_length(b2$x$selectize, 1)
+  expect_equal(b2$x$selectize[[1]], selectize)
+
+  # Can also tack on options after building, and plotly_build() won't overwrite
+  b2$x$selectize[[1]] <- modifyList(
+    b2$x$selectize[[1]], list(foo = "bar")
+  )
+
+  b2 <- plotly_build(b2)
+
+  selectize$foo <- "bar"
+
+  expect_equal(b2$x$selectize[[1]], selectize)
+
+})
+
 
 
 # Ignore for now https://github.com/ggobi/ggally/issues/264