问题描述
在R Shiny group buttons with individual hover dropdown selection之后，需要根据某些条件动态更新单选按钮。按钮的数量可能会改变。
我至少有以下与以下代码相关的查询。 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,2))
dropchoices = c("Peach","Pear")
radioGroupButtons(
inputId = "THE_INPUT_ID",choices = bttnchoices
)
div(
style = "display: none;","select",choices = dropchoices,selectize = FALSE
))
})
}
output$selection1<-input$select1 # struggling with dynamic multiplication of outputs,lapply?
})
}
shinyApp(ui,server)
解决方法
这是方法。单选按钮的值必须与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")
),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",choices = c("Lemon","Orange"),selectInput(
"selectC",choices = c("Strawberry","Pineapple"),selectInput(
"selectD",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);},uiOutput("selections"),uiOutput("dropdowns")
)
server <- function(input,session) {
dropdowns <- reactiveVal(list( # initial dropdowns
A = c("Apple",B = c("Lemon",C = c("Strawberry","Pineapple")
))
flag <- reactiveVal(FALSE)
prefix <- reactiveVal("")
observeEvent(dropdowns(),{
if(flag()) prefix(paste0("x",prefix()))
flag(TRUE)
},priority = 2)
observeEvent(input[["selectA"]],"A","B"))
dropdowns( # new dropdowns,only for D and B
list(
D = c("Pear",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(),value)]])
})
})
output[["dropdowns"]] <- renderUI({
req(dropdowns())
selectInputs <- lapply(names(dropdowns()),function(value){
div(style = "display: none;",selectInput(
paste0(prefix(),value),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)
