在 Shiny 中需要使用 updateRadioGroupButtons 动态更新下拉选项
In Shiny need to dynamically update dropdown choices with updateRadioGroupButtons
在 之后，需要根据某些条件动态更新单选按钮。按钮的数量可能会改变。
我至少有以下与以下代码相关的查询。 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)
这是方法。单选按钮的值必须对应于 selectInput 的 id 的后缀。这里 A、B、C、D 是值，然后 selectInput 的 ids 是 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)
在
我至少有以下与以下代码相关的查询。 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)
这是方法。单选按钮的值必须对应于 selectInput 的 id 的后缀。这里 A、B、C、D 是值，然后 selectInput 的 ids 是 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)