在 Shiny 中需要使用 updateRadioGroupButtons 动态更新下拉选项

Question

Following R Shiny group buttons with individual hover dropdown selection , need to update the radiogroupbuttons dynamically based on some condition. The number of buttons may change.
I have at least the following queries related to the code below. 1) Does the tag belong in server? 2) how to dynamically multiply selectInput in the server code? 3) How to dynamically multiply the output? I have changed your implementation to fit closer to my application. All dropdowns have the same choices if the button is to be shown a dropdown, this is computed dynamically in dropdownTRUE. If dropdownTRUE==F, I don't need a dropdown.

library(shiny)
library(shinyWidgets)

js <- "
function qTip() {
  $('#THE_INPUT_ID .radiobtn').each(function(i, $el){
    var value = $(this).find('input[type=radio]').val();
    var selector = '#select' + value;
    $(this).qtip({
      overwrite: true,
      content: {
        text: $(selector).parent().parent()
      },
      position: {
        my: 'top left',
        at: 'bottom right'
      },
      show: {
        ready: false
      },
      hide: {
        event: 'unfocus'
      },
      style: {
        classes: 'qtip-blue qtip-rounded'
      },
      events: {
        blur: function(event, api) {
          api.elements.tooltip.hide();
        }
      }
    });
  });
}
function qTip_delayed(x){
  setTimeout(function(){qTip();}, 500);
}
$(document).on('shiny:connected', function(){
  Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"

ui <- fluidPage(
  
  tags$head( # does this belong to server?
    tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
    tags$script(src = "jquery.qtip.min.js"),
    tags$script(HTML(js))
  ),
  
  br(),
  
 uiOutput('bttns'),
 verbatimTextOutput("selection1")
)

server <- function(input, output, session) {
  
  session$sendCustomMessage("qTip", "")
  
  output$bttns<-renderUI({
    bttnchoices=c("A", "B", "C")
    lenchoice=length(bttnchoices)
    dropdownTRUE=sample(c(T,F),lenchoice,T,rep(.5,2)) ##bttns for which dropdown is to be shown
    dropchoices = c("Apple", "Banana")# same choices to be shown for all buttons with dropdownTRUE
    radioGroupButtons(
      inputId = "THE_INPUT_ID",
      individual = TRUE,
      label = "Make a choice: ",
      choices = bttnchoices
    )
    
    div(
      style = "display: none;",
      shinyInput(lenchoice,selectInput, # struggling with dynamic multiplication of selectInput, lapply?
        "select",
        label = "Select a fruit",
        choices=dropchoices,
        selectize = FALSE
      ))
    
  })

  observeEvent(input[["select1"]], {
    if(input[["select1"]] == "Banana"){
      
      session$sendCustomMessage("qTip", "")
      output$bttns<-renderUI({
        bttnchoices=c("D", "A")
        lenchoice=length(bttnchoices)
        dropdownTRUE=sample(c(T,F),lenchoice,T,rep(.5,2)) 
        dropchoices = c("Peach", "Pear") 
        radioGroupButtons(
          inputId = "THE_INPUT_ID",
          individual = TRUE,
          label = "Make a choice: ",
          choices = bttnchoices
        )
        
        div(
          style = "display: none;",
          shinyInput(lenchoice,selectInput,
                     "select",
                     label = "Select a fruit",
                     choices = dropchoices,
                     selectize = FALSE
          ))
        
      })
    }
    output$selection1<-input$select1 # struggling with dynamic multiplication of outputs, lapply?
  })
}
  
  shinyApp(ui, server)

Answer 1

Here is the way. The values of the radio buttons must correspond to the suffixes of the selectInput 's ids. Here A , B , C , D are the values and then the ids of the selectInput are selectA , selectB , selectC , selectD . If you want to use other names for the radio buttons, do choices = list("name1" = "A", "name2" = "B", "name3" = "C", "name4" = "D") .

library(shiny)
library(shinyWidgets)

js <- "
function qTip() {
  $('#THE_INPUT_ID .radiobtn').each(function(i, $el){
    var value = $(this).find('input[type=radio]').val();
    var selector = '#select' + value;
    $(this).qtip({
      overwrite: true,
      content: {
        text: $(selector).parent().parent()
      },
      position: {
        my: 'top left',
        at: 'bottom right'
      },
      show: {
        ready: false
      },
      hide: {
        event: 'unfocus'
      },
      style: {
        classes: 'qtip-blue qtip-rounded'
      },
      events: {
        blur: function(event, api) {
          api.elements.tooltip.hide();
        }
      }
    });
  });
}
function qTip_delayed(x){
  setTimeout(function(){qTip();}, 500);
}
$(document).on('shiny:connected', function(){
  Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"

ui <- fluidPage(

  tags$head(
    tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
    tags$script(src = "jquery.qtip.min.js"),
    tags$script(HTML(js))
  ),

  br(),

  radioGroupButtons(
    inputId = "THE_INPUT_ID",
    individual = TRUE,
    label = "Make a choice: ",
    choices = c("A", "B", "C")
  ),

  br(), br(), br(),
  verbatimTextOutput("selectionA"),
  verbatimTextOutput("selectionB"),
  verbatimTextOutput("selectionC"),
  verbatimTextOutput("selectionD"),

  div(
    style = "display: none;",
    selectInput(
      "selectA",
      label = "Select a fruit",
      choices = c("Apple", "Banana"),
      selectize = FALSE
    ),
    selectInput(
      "selectB",
      label = "Select a fruit",
      choices = c("Lemon", "Orange"),
      selectize = FALSE
    ),
    selectInput(
      "selectC",
      label = "Select a fruit",
      choices = c("Strawberry", "Pineapple"),
      selectize = FALSE
    ),
    selectInput(
      "selectD",
      label = "Select a fruit",
      choices = c("Pear", "Peach"),
      selectize = FALSE
    )
  )

)

server <- function(input, output, session) {

  session$sendCustomMessage("qTip", "")

  output[["selectionA"]] <- renderPrint(input[["selectA"]])
  output[["selectionB"]] <- renderPrint(input[["selectB"]])
  output[["selectionC"]] <- renderPrint(input[["selectC"]])
  output[["selectionD"]] <- renderPrint(input[["selectD"]])

  observeEvent(input[["selectA"]], {
    if(input[["selectA"]] == "Banana"){
      updateRadioGroupButtons(session, inputId = "THE_INPUT_ID",
                              label = "Make NEW choice: ",
                              choices = c("D","A"))
      session$sendCustomMessage("qTip", "")
    }
  })

}

shinyApp(ui, server)

---

EDIT

The following way allows to set dropdowns for a chosen list of radio buttons.

library(shiny)
library(shinyWidgets)

js <- "
function qTip(values, ids) {
  $('#THE_INPUT_ID .radiobtn').each(function(i, $el){
    var value = $(this).find('input[type=radio]').val();
    if(values.indexOf(value) > -1){
      var selector = '#' + ids[value];
      $(this).qtip({
        overwrite: true,
        content: {
          text: $(selector).parent().parent()
        },
        position: {
          my: 'top left',
          at: 'bottom right'
        },
        show: {
          ready: false
        },
        hide: {
          event: 'unfocus'
        },
        style: {
          classes: 'qtip-blue qtip-rounded'
        },
        events: {
          blur: function(event, api) {
            api.elements.tooltip.hide();
          }
        }
      });
    }
  });
}
function qTip_delayed(mssg){
  $('[data-hasqtip]').qtip('destroy', true);
  setTimeout(function(){qTip(mssg.values, mssg.ids);}, 500);
}
$(document).on('shiny:connected', function(){
  Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"

ui <- fluidPage(

  tags$head(
    tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
    tags$script(src = "jquery.qtip.min.js"),
    tags$script(HTML(js))
  ),

  br(),

  radioGroupButtons(
    inputId = "THE_INPUT_ID",
    individual = TRUE,
    label = "Make a choice: ",
    choices = c("A", "B", "C")
  ),

  br(), br(), br(),
  uiOutput("selections"),

  uiOutput("dropdowns")

)

server <- function(input, output, session) {

  dropdowns <- reactiveVal(list( # initial dropdowns
    A = c("Apple", "Banana"),
    B = c("Lemon", "Orange"),
    C = c("Strawberry", "Pineapple")
  ))

  flag <- reactiveVal(FALSE)
  prefix <- reactiveVal("")

  observeEvent(dropdowns(), {
    if(flag()) prefix(paste0("x",prefix()))
    flag(TRUE)
  }, priority = 2)

  observeEvent(input[["selectA"]], {
    if(input[["selectA"]] == "Banana"){
      updateRadioGroupButtons(session, inputId = "THE_INPUT_ID",
                              label = "Make NEW choice: ",
                              choices = c("D","A","B"))
      dropdowns( # new dropdowns, only for D and B
        list(
          D = c("Pear", "Peach"),
          B = c("Watermelon", "Mango")
        )
      )
    }
  })

  observeEvent(dropdowns(), {
    req(dropdowns())
    session$sendCustomMessage(
      "qTip",
      list(
        values = as.list(names(dropdowns())),
        ids = setNames(
          as.list(paste0(prefix(), "select", names(dropdowns()))),
          names(dropdowns())
        )
      )
    )
  })

  observeEvent(dropdowns(), {
    req(dropdowns())
    lapply(names(dropdowns()), function(value){
      output[[paste0("selection",value)]] <-
        renderPrint(input[[paste0(prefix(), "select", value)]])
    })
  })

  output[["dropdowns"]] <- renderUI({
    req(dropdowns())
    selectInputs <- lapply(names(dropdowns()), function(value){
      div(style = "display: none;",
          selectInput(
            paste0(prefix(), "select", value),
            label = "Select a fruit",
            choices = dropdowns()[[value]],
            selectize = FALSE
          )
      )
    })
    do.call(tagList, selectInputs)
  })

  output[["selections"]] <- renderUI({
    req(dropdowns())
    verbOutputs <- lapply(names(dropdowns()), function(value){
      verbatimTextOutput(
        paste0("selection", value)
      )
    })
    do.call(tagList, verbOutputs)
  })

}

shinyApp(ui, server)