revdep/library.noindex/baker/new/bslib/examples/build-a-box/R/mod-selextra.R

In zhenkewu/baker: "Nested Partially Latent Class Models"

label_with_extras <- function(label, ...) {
  div(
    class = "d-inline-block w-100",
    span(label),
    span(class = "float-right", ...),
    singleton(tags$style(HTML(".shiny-input-container .control-label { width: 100%; }")))
  )
}

ui_selextra <- function(id, label) {
  ns <- shiny::NS(id)

  selectizeInput(
    inputId = ns("selected"),
    choices = NULL,
    label_with_extras(
      label,
      actionLink(
        ns("shuffle"),
        bsicons::bs_icon("shuffle", title = paste("Random", label))
      ),
      actionLink(
        ns("prev"),
        bsicons::bs_icon("caret-left-fill", title = paste("Previous", label))
      ),
      actionLink(
        ns("next"),
        bsicons::bs_icon("caret-right-fill", title = paste("Next", label))
      )
    )
  )
}

server_selextra <- function(input, output, session, choices) {
  ns <- session$ns

  # These are server-side selectize inputs, so we update them on initialization
  updateSelectizeInput(session, "selected", choices = choices, server = TRUE)

  trigger_shuffle <- reactiveVal(0)
  trigger_next <- reactiveVal(0)
  trigger_prev <- reactiveVal(0)

  observeEvent(
    input$shuffle,
    ignoreInit = TRUE,
    trigger_shuffle(trigger_shuffle() + 1)
  )

  observeEvent(trigger_shuffle(), {
    req(trigger_shuffle() > 0)

    updateSelectizeInput(
      session,
      "selected",
      selected = sample(unlist(choices), 1),
      choices = choices,
      server = TRUE
    )
  })

  observeEvent(input[["next"]], move(1))
  observeEvent(trigger_next(), move(1), ignoreInit = TRUE)

  observeEvent(input[["prev"]], move(-1))
  observeEvent(trigger_prev(), move(-1), ignoreInit = TRUE)

  move <- reactiveVal(0)

  observeEvent(move(), {
    req(move() != 0)

    current <- input$selected
    choices_flat <- unlist(choices)

    idx <- which(choices_flat == current) + move()
    move(0)
    req(idx)

    if (idx > length(choices_flat)) idx <- 1
    if (idx <= 0) idx <- length(choices_flat)

    updateSelectizeInput(
      session,
      "selected",
      selected =  choices_flat[[idx]],
      choices = choices,
      server = TRUE
    )
  })

  list(
    "value" = reactive(input$selected %||% ""),
    "shuffle" = function() trigger_shuffle(as.integer(Sys.time())),
    "next" = function() trigger_next(as.integer(Sys.time())),
    "prev" = function() trigger_prev(as.integer(Sys.time())),
    "choices" = choices,
    "set" = function(value) {
      updateSelectizeInput(
        session,
        "selected",
        selected = value,
        choices = choices,
        server = TRUE
      )
    }
  )
}

module_selextra <- function(id, choices) {
  callModule(server_selextra, id, choices = choices)
}