feat(targets): nav input includes new targets argument

* Nav inputs may trigger nav panes with the `targets` argument (#166)

R/nav.R

@@ -141,11 +141,13 @@ navInput <- function(id, choices = NULL, values = choices,
                      selected = values[[1]], ..., appearance = "links",
                      fill = FALSE, targets = NULL) {
   assert_id()
+  assert_choices()
   assert_selected(length = 1)
   assert_possible(appearance, c("links", "pills", "tabs"))
+  assert_targets()
 
   dep_attach({
-    items <- map_navitems(choices, values, selected)
+    items <- map_navitems(choices, values, selected, targets)
 
     tags$ul(
       class = str_collate(
@@ -165,13 +167,15 @@ navInput <- function(id, choices = NULL, values = choices,
 #' @export
 updateNavInput <- function(id, choices = NULL, values = choices,
                            selected = NULL, enable = NULL, disable = NULL,
+                           targets = NULL,
                            session = getDefaultReactiveDomain()) {
   assert_id()
   assert_choices()
   assert_selected(length = 1)
+  assert_targets()
   assert_session()
 
-  items <- map_navitems(choices, values, selected)
+  items <- map_navitems(choices, values, selected, targets)
 
   content <- coerce_content(items)
   selected <- coerce_selected(selected)
@@ -186,8 +190,9 @@ updateNavInput <- function(id, choices = NULL, values = choices,
   ))
 }
 
-map_navitems <- function(choices, values, selected) {
+map_navitems <- function(choices, values, selected, targets) {
   selected <- values %in% selected
+  targets <- format_targets(targets, values)
 
   Map(
     choice = choices,
@@ -210,6 +215,8 @@ map_navitems <- function(choices, values, selected) {
           choice$children[[1]] <- tag_class_add(choice$children[[1]], "active")
         }
 
+        choice <- tag_attributes_add(choice, `data-target` = get_target(targets, value))
+
         choice$name <- "li"
         choice <- tag_class_add(choice, "nav-item")
 
@@ -225,6 +232,7 @@ map_navitems <- function(choices, values, selected) {
             "btn-link",
             if (select) "active"
           ),
+          `data-target` = get_target(targets, value),
           value = value,
           choice
         )

R/utils-arguments.R

@@ -56,3 +56,35 @@ coerce_invalid <- function(x) {
     HTML(as.character(x))
   }
 }
+
+format_targets <- function(targets, values) {
+  if (is.null(targets)) {
+    return(targets)
+  }
+
+  if (length(targets) > 1) {
+    targets <- lapply(targets, function(target) {
+      if (is.character(target)) {
+        paste0("#", target, collapse = " ")
+      }
+    })
+
+    if (all(names2(targets) == "")) {
+      names(targets) <- values
+    }
+
+    targets
+  } else if (is.character(targets)) {
+    targets
+  }
+}
+
+get_target <- function(targets, value) {
+  if (is.null(targets)) {
+    NULL
+  } else if (is.character(targets)) {
+    paste0("#", value)
+  } else {
+    targets[[value]]
+  }
+}

R/utils-assertions.R

@@ -120,6 +120,63 @@ assert_selected <- function(length) {
   }
 }
 
+assert_targets <- function() {
+  targets <- get_variable("targets")
+  values <- get_variable("values")
+  fun <- get_caller()
+
+  if (!is.null(targets) && !is.character(targets) &&
+      !is_strictly_list(targets)) {
+    stop(
+      "invalid argument in `", fun, "`, `targets` must be NULL, a character ",
+      "string or vector, or list",
+      call. = FALSE
+    )
+  }
+
+  if (is.character(targets) && length(targets) == 1 && length(values) > 1) {
+    pass <- vapply(values, is.character, logical(1))
+
+    if (!all(pass)) {
+      stop(
+        "invalid arguments in `", fun, "`, `values` must be a character ",
+        "string or vector if `targets` is a character string",
+        call. = FALSE
+      )
+    }
+  }
+
+  if (!is.null(targets) && !(is.character(targets) && length(targets) == 1) &&
+      length(targets) != length(values)) {
+    stop(
+      "invalid arguments in `", fun, "`, `targets` and `values` must be the ",
+      "same length",
+      call. = FALSE
+    )
+  }
+
+  if (any(names2(targets) == "") && !all(names2(targets) == "")) {
+    stop(
+      "invalid argument in `", fun, "`, `targets` values must all be ",
+      "named, if using names",
+      call. = FALSE
+    )
+  }
+
+  if (is_strictly_list(targets)) {
+    classes <- vapply(targets, function(x) class(x)[1], character(1))
+
+    if (!all(classes == "character" | classes == "NULL")) {
+      stop(
+        "invalid argument in `", fun, "`, `targets` list items must be NULL ",
+        "or character strings or vectors",
+        call. = FALSE
+      )
+    }
+  }
+
+}
+
 assert_possible <- function(x, possible) {
   if (!is.null(x) && !all(x %in% possible)) {
     arg <- as.character(match.call()[[2]])

js/src/js/input-binding-nav.js

@@ -23,6 +23,13 @@ $.extend(navInputBinding, {
       e.currentTarget.parentNode.parentNode.children[0].classList.add("active");
       e.currentTarget.classList.add("active");
     });
+
+    // Show active on initialize w/out requiring click
+    $(el.querySelector(".active[data-target]")).removeClass("active").tab("show");
+
+    $(`#${ el.id } button[data-target]`).on("click", (e) => {
+      $(e.currentTarget).tab("show");
+    });
   },
   getValue: (el) => {
     let active = el.querySelector(".nav-link.active:not(.disabled)");