fix(targetting): converted to actions

* The targetting feature is now better named `actions`. (#166)

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(print,targeter)
 export("%>%")
 export(active)
 export(affix)
@@ -43,6 +44,7 @@ export(groupTextInput)
 export(height)
 export(hideCollapsePane)
 export(hideNavPane)
+export(hideTarget)
 export(img)
 export(jumbotron)
 export(linkInput)
@@ -70,6 +72,7 @@ export(showCollapsePane)
 export(showModal)
 export(showNavPane)
 export(showPopover)
+export(showTarget)
 export(showToast)
 export(switchInput)
 export(textInput)

R/actions.R

@@ -0,0 +1,88 @@
+#' Input actions
+#'
+#' These functions are used in conjunction with the `targets` argument found
+#' in all of yonder's reactive input functions.
+#'
+#' @param id A character string specifying the id of a [navPane()] or
+#'   [collapsePane()].
+#'
+#' @param ... Additional arguments, currently ignored.
+#'
+#' @name actions
+NULL
+
+#' @rdname actions
+#' @export
+showTarget <- function(id, ...) {
+  create_targeter("show", id)
+}
+
+#' @rdname actions
+#' @export
+hideTarget <- function(id, ...) {
+  create_targeter("hide", id)
+}
+
+create_targeter <- function(action, id) {
+  structure(
+    class = c("targeter", "list"),
+    list(
+      action = action,
+      target = id
+    )
+  )
+}
+
+is_targeter <- function(x) {
+  inherits(x, "targeter")
+}
+
+#' Explain a targetting action
+#'
+#' Printing a targetting action displays a message about the action performed.
+#'
+#' @param x An object with class `"targeter"`.
+#'
+#' @param ... Additional arguments passed on to other methods.
+#'
+#' @keywords internal
+#' @export
+print.targeter <- function(x, ...) {
+  msg <- "Selecting the input choice with the corresponding value _%s_ the element with id `%s`"
+  cat(sprintf(msg, x$action, x$id), "\n")
+  invisible(x)
+}
+
+construct_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 = " ")
+      } else if (is_targeter(target)) {
+        stop("Not implemented")
+      }
+    })
+
+    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/nav.R

@@ -139,15 +139,15 @@
 #'
 navInput <- function(id, choices = NULL, values = choices,
                      selected = values[[1]], ..., appearance = "links",
-                     fill = FALSE, targets = NULL) {
+                     fill = FALSE, actions = NULL) {
   assert_id()
   assert_choices()
   assert_selected(length = 1)
   assert_possible(appearance, c("links", "pills", "tabs"))
-  assert_targets()
+  # assert_targets()
 
   dep_attach({
-    items <- map_navitems(choices, values, selected, targets)
+    items <- map_navitems(choices, values, selected, actions)
 
     tags$ul(
       class = str_collate(
@@ -167,12 +167,12 @@ navInput <- function(id, choices = NULL, values = choices,
 #' @export
 updateNavInput <- function(id, choices = NULL, values = choices,
                            selected = NULL, enable = NULL, disable = NULL,
-                           targets = NULL,
+                           actions = NULL,
                            session = getDefaultReactiveDomain()) {
   assert_id()
   assert_choices()
   assert_selected(length = 1)
-  assert_targets()
+  # assert_targets()
   assert_session()
 
   items <- map_navitems(choices, values, selected, targets)
@@ -196,7 +196,7 @@ map_navitems <- function(choices, values, selected, targets) {
   }
 
   selected <- values %in% selected
-  targets <- format_targets(targets, values)
+  targets <- construct_targets(targets, values)
 
   Map(
     choice = choices,

R/utils-arguments.R

@@ -67,35 +67,3 @@ 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]]
-  }
-}