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

Question

按照R Shiny group buttons with individual hover dropdown selection，需要根据某些条件动态更新radiogroupbuttons。按钮的数量可能会发生变化。
我至少有以下与以下代码相关的查询。 1）标签是否属于服务器？ 2）如何在服务器代码中动态乘以selectInput？ 3）如何动态乘以输出？我已更改您的实现以更适合我的应用程序。如果按钮要显示为下拉列表，则所有下拉列表都具有相同的选择，这是在 dropdownTRUE 中动态计算的。如果 dropdownTRUE==F，我不需要下拉菜单。

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

这是方法。单选按钮的值必须与 selectInput 的 id 的后缀相对应。这里A、B、C、D是值，然后selectInput的id是selectA、selectB、selectC、selectD。如果您想为单选按钮使用其他名称，请使用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)

---

编辑

以下方式允许为选定的单选按钮列表设置下拉菜单。

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)