introjs-guess-id.Rmd

``` r

library(shiny)
library(magrittr) # for the pipe
library(shinydashboard)
#> 
#> Attaching package: 'shinydashboard'
#> The following object is masked from 'package:graphics':
#> 
#>     box

# Adds Class to an UI element
# 
# This allows accessing this element from introjs
#
# @param x a shiny UI element
# @param class_id A class id, which can be used from introjs, default is to guess the value using \code{guess_id()}
#
# @return
# @export
#
# @examples
# ui <- bootstrapPage(
#   numericInput('n', 'Number of obs', n) %>% add_class("n"), # manually set the class-id to "n"
#   plotOutput('plot') %>% add_class() # guess the id to be "plot"
# )
add_class <- function(x, class_id = guess_id(x)) {
  stopifnot(any(class(x) %in% c("shiny.tag", "shiny.tag.list")))
  x$attribs <- append(x$attribs, list(class = class_id))
  if (is.na(class)) stop("class_id is NA, maybe guess_id could not determine the ID of x")
  x
}


# Tries to extract the ID value of a HTML shiny.tag
#
# If no ID is found, an NA is returned
# @param x a shiny.tag
#
# @return the ID tag, or NA if nothing is found
# @export
#
# @examples
# library(magrittr)
# textOutput("ID-TEXT") %>% guess_id()
# verbatimTextOutput("ID-TEXT") %>% guess_id()
# menuItem("text", tabName = "ID-MENU-ITEM") %>% guess_id()
# plotOutput("ID-PLOT") %>% guess_id()
# dataTableOutput("ID-DT") %>% guess_id()
guess_id <- function(x) {
  stopifnot(any(class(x) %in% c("shiny.tag", "shiny.tag.list")))
  ll <- unlist(x)
  match <- grepl("\\.id$", names(ll))
  if (any(match)) {
    return(as.character(ll[match])[1])
  } else {
    match <- grepl("\\.data-value$", names(ll))
    if (any(match)) return(as.character(ll[match])[1])
  }
  return(NA)
}

# some tests...
actionButton("ID-BUTTON", "the label") %>% guess_id()
#> [1] "ID-BUTTON"
checkboxInput("ID-CB", "Label") %>% guess_id()
#> [1] "ID-CB"
checkboxGroupInput("ID-Box", "lab", 1:10) %>% guess_id()
#> [1] "ID-Box"
dateInput("ID-Date", "lab") %>% guess_id()
#> [1] "ID-Date"
dateRangeInput("ID-DR", "dr", "2020-01-01", "2020-12-31") %>% guess_id()
#> [1] "ID-DR"
fileInput("ID-FILE", "lab") %>% guess_id()
#> [1] "ID-FILE"
numericInput("ID-NUM", "num", 100) %>% guess_id()
#> [1] "ID-NUM"
radioButtons("ID-BTN", "num", 1:3) %>% guess_id()
#> [1] "ID-BTN"
selectInput("ID-SEL", "lab", 1:3) %>% guess_id()
#> [1] "ID-SEL"
sliderInput("ID-SLID", "lab", 0, 1, 1) %>% guess_id()
#> [1] "ID-SLID"
textInput("ID-TXT", "lab") %>% guess_id()
#> [1] "ID-TXT"

# Outputs
uiOutput("ID-UI") %>% guess_id()
#> [1] "ID-UI"
plotOutput("ID-PLOT") %>% guess_id()
#> [1] "ID-PLOT"
textOutput("ID-TXT") %>% guess_id()
#> [1] "ID-TXT"
verbatimTextOutput("ID-VERB") %>% guess_id()
#> [1] "ID-VERB"
leaflet::leafletOutput("ID-LF") %>% guess_id()
#> [1] "ID-LF"
DT::dataTableOutput("ID-DT") %>% guess_id()
#> [1] "ID-DT"

# shiny dashboard
sidebarMenu("asd", id = "ID-SIDEBAR") %>% guess_id()
#> [1] "ID-SIDEBAR"
menuItem("text", tabName = "ID-MENU-ITEM") %>% guess_id()
#> [1] "ID-MENU-ITEM"
dropdownMenuOutput("ID-MSG") %>% guess_id()
#> [1] "ID-MSG"
box(h1("LAB")) %>% guess_id() # no id set, expect NA!
#> [1] NA
box(h1("LAB"), id = "BOX-ID") %>% guess_id() # no id set, expect NA!
#> [1] "BOX-ID"
valueBox("123", "subtitle") %>% guess_id() # no id set, expect NA!
#> [1] NA
```

<sup>Created on 2020-07-03 by the [reprex package](https://reprex.tidyverse.org) (v0.3.0)</sup>