Implement default selections

DESCRIPTION

@@ -45,5 +45,5 @@ Suggests:
     testthat (>= 2.1.0)
 URL: https://rstudio.github.io/crosstalk/
 BugReports: https://github.com/rstudio/crosstalk/issues
-RoxygenNote: 7.1.1
 Encoding: UTF-8
+RoxygenNote: 7.1.1

NEWS.md

@@ -1,6 +1,6 @@
 ## crosstalk 1.1.1.9000
 
-
+* Add `selected` parameter for to specifying default selections in `filter_select()`, `filter_checkbox()`, and `filter_slider()`.
 
 ## crosstalk 1.1.1
 

R/controls.R

@@ -59,7 +59,7 @@ ionrangesliderLibs <- function() {
   )
 }
 
-makeGroupOptions <- function(sharedData, group, allLevels) {
+makeGroupOptions <- function(sharedData, group, allLevels, selected = NULL) {
   df <- sharedData$data(
     withSelection = FALSE,
     withFilter = FALSE,
@@ -89,10 +89,23 @@ makeGroupOptions <- function(sharedData, group, allLevels) {
 
   lvls_str <- as.character(lvls)
 
+  if (!is.null(selected)) {
+    selected <- unique(as.character(selected))
+    present <- selected %in% lvls_str
+    if (any(!present)) {
+      warning(call. = FALSE,
+        "Default selection was specified that was not present in the data [",
+        paste0("'", selected[!present], "'", collapse = ","),
+        "]"
+      )
+      selected <- selected[present]
+    }
+  }
   options <- list(
     items = data.frame(value = lvls_str, label = lvls_str, stringsAsFactors = FALSE),
     map = setNames(vals, lvls_str),
-    group = sharedData$groupName()
+    group = sharedData$groupName(),
+    selected = selected
   )
 
   options
@@ -114,6 +127,8 @@ makeGroupOptions <- function(sharedData, group, allLevels) {
 #'   present in the data?
 #' @param multiple Can multiple values be selected?
 #' @param columns Number of columns the options should be arranged into.
+#' @param selected Default value(s) to be selected. Should be character, or
+#'   coercible to character.
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -126,9 +141,16 @@ makeGroupOptions <- function(sharedData, group, allLevels) {
 #'
 #' @export
 filter_select <- function(id, label, sharedData, group, allLevels = FALSE,
-  multiple = TRUE) {
+  multiple = TRUE, selected = NULL) {
 
-  options <- makeGroupOptions(sharedData, group, allLevels)
+  if (!multiple && length(selected) > 1) {
+    warning(call. = FALSE, "filter_select called with multiple=FALSE ",
+      "but more than one selected value; only the first element will ",
+      "be used")
+    selected <- selected[[1]]
+  }
+
+  options <- makeGroupOptions(sharedData, group, allLevels, selected)
 
   htmltools::browsable(attachDependencies(
     tags$div(id = id, class = "form-group crosstalk-input-select crosstalk-input",
@@ -168,7 +190,7 @@ columnize <- function(columnCount, elements) {
 #'
 #' @rdname filter_select
 #' @export
-filter_checkbox <- function(id, label, sharedData, group, allLevels = FALSE, inline = FALSE, columns = 1) {
+filter_checkbox <- function(id, label, sharedData, group, allLevels = FALSE, inline = FALSE, columns = 1, selected = NULL) {
   options <- makeGroupOptions(sharedData, group, allLevels)
 
   labels <- options$items$label
@@ -183,7 +205,7 @@ filter_checkbox <- function(id, label, sharedData, group, allLevels = FALSE, inl
       tags$div(class = "crosstalk-options-group",
         columnize(columns,
           mapply(labels, values, FUN = function(label, value) {
-            makeCheckbox(id, value, label)
+            makeCheckbox(id, value, label, value %in% selected)
           }, SIMPLIFY = FALSE, USE.NAMES = FALSE)
         )
       ),
@@ -196,18 +218,24 @@ filter_checkbox <- function(id, label, sharedData, group, allLevels = FALSE, inl
   ))
 }
 
-blockCheckbox <- function(id, value, label) {
+blockCheckbox <- function(id, value, label, checked) {
   tags$div(class = "checkbox",
     tags$label(
-      tags$input(type = "checkbox", name = id, value = value),
+      tags$input(
+        type = "checkbox", name = id, value = value,
+        checked = if (isTRUE(checked)) NA
+      ),
       tags$span(label)
     )
   )
 }
 
-inlineCheckbox <- function(id, value, label) {
+inlineCheckbox <- function(id, value, label, checked) {
   tags$label(class = "checkbox-inline",
-    tags$input(type = "checkbox", name = id, value = value),
+    tags$input(
+      type = "checkbox", name = id, value = value,
+      checked = if (isTRUE(checked)) NA
+    ),
     tags$span(label)
   )
 }
@@ -274,7 +302,7 @@ inlineCheckbox <- function(id, value, label) {
 filter_slider <- function(id, label, sharedData, column, step = NULL,
   round = FALSE, ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
   pre = NULL, post = NULL, timeFormat = NULL,
-  timezone = NULL, dragRange = TRUE, min = NULL, max = NULL)
+  timezone = NULL, dragRange = TRUE, min = NULL, max = NULL, selected = NULL)
 {
   # TODO: Check that this works well with factors
   # TODO: Handle empty data frame, NA/NaN/Inf/-Inf values
@@ -292,6 +320,16 @@ filter_slider <- function(id, label, sharedData, column, step = NULL,
     max <- max(values)
   value <- range(values)
 
+  if (!is.null(selected)) {
+    if (!is.numeric(selected) || length(selected) != 2) {
+      stop("selected must be a numeric vector of length 2")
+    }
+    selected <- sort(selected)
+    if (min(selected) < min || max < max(selected)) {
+      stop("selected range must be within min/max range")
+    }
+  }
+
   ord <- order(col)
   options <- list(
     values = col[ord],
@@ -375,8 +413,8 @@ filter_slider <- function(id, label, sharedData, column, step = NULL,
     `data-type` = if (length(value) > 1) "double",
     `data-min` = formatNoSci(min),
     `data-max` = formatNoSci(max),
-    `data-from` = formatNoSci(value[1]),
-    `data-to` = if (length(value) > 1) formatNoSci(value[2]),
+    `data-from` = selected[1] %||% formatNoSci(value[1]),
+    `data-to` = selected[2] %||% if (length(value) > 1) formatNoSci(value[2]),
     `data-step` = formatNoSci(step),
     `data-grid` = ticks,
     `data-grid-num` = n_ticks,

R/utils.R

@@ -0,0 +1,3 @@
+"%||%" <- function(x, y) {
+  if (is.null(x)) y else x
+}

javascript/src/input_checkboxgroup.js

@@ -15,7 +15,7 @@ input.register({
 
     let lastKnownKeys;
     let $el = $(el);
-    $el.on("change", "input[type='checkbox']", function() {
+    function updateFilter() {
       let checked = $el.find("input[type='checkbox']:checked");
       if (checked.length === 0) {
         lastKnownKeys = null;
@@ -32,7 +32,20 @@ input.register({
         lastKnownKeys = keyArray;
         ctHandle.set(keyArray);
       }
-    });
+    }
+    $el.on("change", "input[type='checkbox']", updateFilter);
+
+    // Update filter now in case this code happens to execute
+    // after widget(s) are done rendering
+    updateFilter();
+
+    // Schedule another update when all widgets are done rendering
+    // This is especially relevant for `runtime: shiny` where widgets
+    // likely haven't rendered at this point and may only register
+    // FilterHandle.on("change", ...) callbacks in their renderValue
+    if (window.HTMLWidgets) {
+      window.HTMLWidgets.addPostRenderHandler(updateFilter);
+    }
 
     return {
       suspend: function() {

javascript/src/input_selectize.js

@@ -18,6 +18,7 @@ input.register({
     let items = util.dataframeToD3(data.items);
     let opts = {
       options: first.concat(items),
+      items: data.selected,
       valueField: "value",
       labelField: "label",
       searchField: "label"
@@ -30,7 +31,7 @@ input.register({
     let ctHandle = new FilterHandle(data.group);
 
     let lastKnownKeys;
-    selectize.on("change", function() {
+    function updateFilter() {
       if (selectize.items.length === 0) {
         lastKnownKeys = null;
         ctHandle.clear();
@@ -46,7 +47,20 @@ input.register({
         lastKnownKeys = keyArray;
         ctHandle.set(keyArray);
       }
-    });
+    }
+    selectize.on("change", updateFilter);
+
+    // Update filter now in case this code happens to execute
+    // after widget(s) are done rendering
+    updateFilter();
+
+    // Schedule another update when all widgets are done rendering
+    // This is especially relevant for `runtime: shiny` where widgets
+    // likely haven't rendered at this point and may only register
+    // FilterHandle.on("change", ...) callbacks in their renderValue
+    if (window.HTMLWidgets) {
+      window.HTMLWidgets.addPostRenderHandler(updateFilter);
+    }
 
     return {
       suspend: function() {