diff --git a/DESCRIPTION b/DESCRIPTION index 82d16191c8..708763e0b3 100644 --- a/DESCRIPTION +++ b/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) diff --git a/NEWS.md b/NEWS.md index ac86dabcdc..6ad24f5daa 100644 --- a/NEWS.md +++ b/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 diff --git a/R/highlight.R b/R/highlight.R index 559f9c2580..810bd49d55 100644 --- a/R/highlight.R +++ b/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) { diff --git a/R/utils.R b/R/utils.R index 8e294e51b4..29f3c5ec5e 100644 --- a/R/utils.R +++ b/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 diff --git a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.png b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.png index fbfee45cd5..755f0cb579 100644 Binary files a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.png and b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.png differ diff --git a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.png b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.png index e66496ee6f..4c6e328694 100644 Binary files a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.png and b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.png differ diff --git a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.png b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.png index 2f2efc015b..838f3bc87c 100644 Binary files a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.png and b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.png differ diff --git a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.png b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.png index fbfee45cd5..755f0cb579 100644 Binary files a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.png and b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.png differ diff --git a/inst/htmlwidgets/plotly.js b/inst/htmlwidgets/plotly.js index 1155269d37..7a2a143b6d 100644 --- a/inst/htmlwidgets/plotly.js +++ b/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 diff --git a/man/highlight.Rd b/man/highlight.Rd index b7c6aa4b40..5aefb10a0a 100644 --- a/man/highlight.Rd +++ b/man/highlight.Rd @@ -55,8 +55,10 @@ highlighting selections. See \code{\link[=toRGB]{toRGB()}} for valid color specifications. If \code{NULL} (the default), the color of selected marks are not altered.} -\item{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.} +\item{selectize}{whether or not to render a selectize.js widget for selecting +\code{\link[=highlight_key]{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 +\code{groupName} argument of \code{\link[=highlight_key]{highlight_key()}}.} \item{defaultValues}{a vector of values for setting a "default selection". These values should match the key attribute.} diff --git a/tests/testthat/test-animate-highlight.R b/tests/testthat/test-animate-highlight.R index 4f55614603..3ede5209de 100644 --- a/tests/testthat/test-animate-highlight.R +++ b/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