I'm trying to create dropdown input in shiny which has hierarchical drop-down list in R shiny like below:
hierarchical drop-down list in R shiny
For now I'm able to create an shinytree where we can display the entire list, but I want display the list in dropdown instead of shinytree.
Below is my code:
library(shiny)
library(shinyTree)
# Define UI for application:
ui <- {fluidPage(
sidebarLayout(
sidebarPanel(width = 3,
div(shinyTree("Tree",checkbox = TRUE)),
verbatimTextOutput("selected")
),
mainPanel(width = 9)
)
)}
# Define server logic:
server <- function(input, output, session){
observe({
df <- data.frame(
child= c('a','b','c','d','e','f','g','h'),
parent = c('f','f','f','g','h','i','i','i'))
tree <- FromDataFrameNetwork(df)
filtered_value <- as.list(tree)
filtered_value <- filtered_value[-1]
output$Tree <- renderTree({
filtered_value
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm looking for input in this manner: Custom-Dropdown
I did a Shiny binding for the ComboTree library yesterday. It works but this is not fantastic.
File comboTreeBinding.js to put in the www subfolder:
var comboTreeBinding = new Shiny.InputBinding();
$.extend(comboTreeBinding, {
find: function (scope) {
return $(scope).find(".comboTree");
},
getValue: function (el) {
var value = el.value.split(", ");
var empty = value.length === 1 && value[0] === "";
return empty ? null : value;
},
setValue: function(el, value) {
$(el).setSelection(value);
},
subscribe: function (el, callback) {
$(el).on("change.comboTreeBinding", function (e) {
callback();
});
},
unsubscribe: function (el) {
$(el).off(".comboTreeBinding");
},
initialize: function(el) {
var $el = $(el);
$el.comboTree({
source: $el.data("choices"),
isMultiple: $el.data("multiple"),
cascadeSelect: $el.data("cascaded"),
collapse: true
});
}
});
Shiny.inputBindings.register(comboTreeBinding);
Shiny app (put the files style.css and comboTreePlugin.js in the www subfolder):
library(shiny)
library(jsonlite)
comboTreeInput <- function(inputId, width = "30%", height = "100px",
choices, multiple = TRUE, cascaded = TRUE){
tags$div(style = sprintf("width: %s; height: %s;", width, height),
tags$input(id = inputId, class = "comboTree", type = "text",
placeholder = "Select",
`data-choices` = as.character(toJSON(choices, auto_unbox = TRUE)),
`data-multiple` = ifelse(multiple, "true", "false"),
`data-cascaded` = ifelse(cascaded, "true", "false")
)
)
}
choices <- list(
list(id = 1, title = "item1"),
list(id = 2, title = "item2",
subs = list(
list(id = 21, title = "item2-1"),
list(id = 22, title = "item2-2")
)
),
list(id = 3, title = "item3",
subs = list(
list(id = 31, title = "item3-1", isSelectable = FALSE,
subs = list(
list(id = 311, title = "item3-1-1"),
list(id = 312, title = "item3-1-2")
)
),
list(id = 32, title = "item3-2")
)
)
)
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "style.css"),
tags$script(src = "comboTreePlugin.js"),
tags$script(src = "comboTreeBinding.js")
),
br(),
h3("You selected:"),
verbatimTextOutput("selections"),
br(),
comboTreeInput("mycombotree", choices = choices)
)
server <- function(input, output, session){
output[["selections"]] <- renderPrint({
input[["mycombotree"]]
})
}
shinyApp(ui, server)
Related
This is my code.
My question is: Is it possible to make shiny update/refresh the chart displayed in item 3 panel (Menu Item 3) once I click on it? I know that I could use a button, for example. But I need to click on Item 3 and force the page to refresh once I click.
I was wondering if observeEvent would do this for me.
library("shiny")
library("shinyWidgets")
library("gapminder")
hc_data_1 <- gapminder %>% filter(country == 'Chile')
ui <- dashboardPage(dark = FALSE,fullscreen = TRUE,
dashboardHeader(title = h4("Title")),
dashboardSidebar(skin = 'light',
sidebarMenu( id = "sidebarMenu",
menuItem(text = "Item 1",
tabName = "panel_1"),
menuItem(text = "Item 2",
tabName = "panel_2"),
menuItem(text = "Item 3",
tabName = "panel_3") )
),
dashboardBody(
tabItems(
tabItem(tabName = 'panel_1',
tabPanel("Panel 1")),
tabItem(tabName = 'panel_2',
tabPanel("Panel 2")),
tabItem(tabName = 'panel_3',
tabPanel("Panel 3",
htmlOutput('chart_1',width = '100px')
))
)
))
server <- function(input, output, session) {
output$chart_1<- renderUI({
hc_data_1 %>%
hchart(
"line",
hcaes(x = year, y = pop),
showInLegend = TRUE,
color = "#63696b",
name = "chile-argentina"
)
})
}
shinyApp(ui = ui, server = server)
I am not sure if I understand the "force the page to refresh"-part correctly. If this is referring to the same function as a browser reloading its page please check the following:
library("shiny")
library("shinyWidgets")
library("gapminder")
library("dplyr")
library("bs4Dash")
library("highcharter")
hc_data_1 <- gapminder %>% filter(country == 'Chile')
ui <- bs4Dash::dashboardPage(
dark = FALSE,
fullscreen = TRUE,
dashboardHeader(title = h4("Title")),
dashboardSidebar(
skin = 'light',
sidebarMenu(
id = "sidebarMenu",
menuItem(text = "Item 1",
tabName = "panel_1"),
menuItem(text = "Item 2",
tabName = "panel_2"),
menuItem(text = "Item 3",
tabName = "panel_3")
)
),
dashboardBody(tabItems(
tabItem(tabName = 'panel_1',
tabPanel("Panel 1")),
tabItem(tabName = 'panel_2',
tabPanel("Panel 2")),
tabItem(tabName = 'panel_3',
tabPanel(
"Panel 3",
htmlOutput('chart_1', width = '100px')
))
))
)
server <- function(input, output, session) {
# observeEvent(input$sidebarMenu, {
# if (input$sidebarMenu == "panel_3") {
# print("reloading shiny session")
# session$reload()
# }
# })
output$chart_1 <- renderUI({
input$sidebarMenu # take a reactive dependency on input$sidebarMenu
hc_data_1 %>%
hchart(
"line",
hcaes(x = year, y = pop),
showInLegend = TRUE,
color = "#63696b",
name = "chile-argentina"
)
})
}
shinyApp(ui = ui, server = server)
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)
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)
I am trying to call a JavaScript function from Shiny each time when a tab of the app is clicked. I need to send a tab name to custom js function. As the simplest option I call alert() function from R and transfer to it the name of a tab. For some reason my code doesn't work and a window with a message doesn't appear although I’ve replicated the example.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui = dashboardPage(
dashboardHeader(title = "Shiny"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Section_1", tabName = "section_1", icon = icon("align-justify"),
startExpanded = TRUE, selected = TRUE,
menuSubItem("Subsection 1", tabName = "report_1", selected = TRUE),
menuSubItem("Subsection 2", tabName = "report_2")),
menuItem("Section_2", tabName = "section_2", icon = icon("align-justify"))
)
),
dashboardBody(
useShinyjs(),
tags$head(tags$script("Shiny.addCustomMessageHandler('handler1', alert(tab_name))")),
tabItems(
tabItem("report_1", h1(id = "a", "a")),
tabItem("report_2", h1(id = "b", "b")),
tabItem("section_2", h1(id = "c", "c")))
)
)
server <- function(input, output, session) {
observe({
if(input$tabs == "report_1") {
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
} else if(input$tabs == "report_2"){
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
} else if (input$tabs == "section_2"){
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
}
})
}
shinyApp(ui=ui, server=server)
Write a function inside the addCustomMessageHandler like so:
library(shiny)
library(shinydashboard)
library(shinyjs)
ui = dashboardPage(
dashboardHeader(title = "Shiny"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Section_1", tabName = "section_1", icon = icon("align-justify"),
startExpanded = TRUE, selected = TRUE,
menuSubItem("Subsection 1", tabName = "report_1", selected = TRUE),
menuSubItem("Subsection 2", tabName = "report_2")),
menuItem("Section_2", tabName = "section_2", icon = icon("align-justify"))
)
),
dashboardBody(
useShinyjs(),
tags$head(tags$script('Shiny.addCustomMessageHandler("handler1", function(message) {
alert(JSON.stringify(message));
})')),
tabItems(
tabItem("report_1", h1(id = "a", "a")),
tabItem("report_2", h1(id = "b", "b")),
tabItem("section_2", h1(id = "c", "c")))
)
)
server <- function(input, output, session) {
observe({
if(input$tabs == "report_1") {
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
} else if(input$tabs == "report_2"){
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
} else if (input$tabs == "section_2"){
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
}
})
}
shinyApp(ui=ui, server=server)
I want my Shiny select input to:
Has no label
Has customized background colour: #2f2d57
Has placeholder
Enable users to type-in and select
However, I can't make the app follow the above 4 rules together. My codes are below:
Data:
table <- data.frame(col1 = c(3, 4, 8, 5, 2, 6, 7))
Attempt 1
Problem: Users are unable to type-in and select from the selectInput
ui <- fluidPage(
uiOutput("container")
)
server <- function(input, output) {
output$container <- renderUI({
fluidRow(
tags$style("#three_code_zip_selector {color: #ffffff; background-color: #2f2d57;}"),
selectInput('three_code_zip_selector', NULL, choices = c("Please Select Desired Number" = "", table$col1), selectize = F)
)
})
}
shinyApp(ui = ui, server = server)
Attempt 2
Problem: By deleting selectize = F, users can type-in to select, but the background colour is not changed.
ui <- fluidPage(
uiOutput("container")
)
server <- function(input, output) {
output$container <- renderUI({
fluidRow(
tags$style("#three_code_zip_selector {color: #ffffff; background-color: #2f2d57;}"),
selectInput('three_code_zip_selector', NULL, choices = c("Please Select Desired Number" = "", table$col1))
)
})
}
shinyApp(ui = ui, server = server)
I was also trying selectizeInput, but seems like it still has the same problem as above.
Attempt 3
Problem: Users can to type in, but the background colour is not changed, and there's a label at the top of selectizeInput which I don't want.
ui <- fluidPage(
uiOutput("container")
)
server <- function(input, output) {
output$container <- renderUI({
fluidRow(
tags$style(".selectize-dropdown-content .active {background: #2f2d57; !important;color: #ffffff; !important;}"),
selectizeInput('three_code_zip_selector', "s", choices = c("Please Select Desired Number" = "", table$col1))
)
})
}
shinyApp(ui = ui, server = server)
Does anyone have ideas on how could I be able to satisfy all the 4 rules? Thanks in advance!
Here is a pure shiny solution:
library(shiny)
table <- data.frame(col1 = c(3, 4, 8, 5, 2, 6, 7))
ui <- fluidPage(
tags$head(tags$style(HTML('
#three_code_zip_selector+ div>.selectize-dropdown{background: #2f2d57; color: #ffffff;}
#three_code_zip_selector+ div>.selectize-input{background: #2f2d57; color: #ffffff;}
'))),
selectizeInput(inputId = 'three_code_zip_selector', label = NULL, choices = table$col1, selected = NULL, multiple = TRUE, options = list('plugins' = list('remove_button'), placeholder = "Please Select Desired Number", 'create' = TRUE, 'persist' = TRUE)))
server <- function(input, output, session){}
shinyApp(ui = ui, server = server)
Here is an example using the shinyWidgets package:
library(shinyWidgets)
ui <- fluidPage(
uiOutput("container")
)
server <- function(input, output) {
table <- data.frame(col1 = c(3, 4, 8, 5, 2, 6, 7))
output$container <- renderUI({
fluidRow(
pickerInput(
inputId = "three_code_zip_selector",
label = NULL,
choices = table$col1,
options = list(
title = "Please Select Desired Number",
`live-search` = TRUE,
style = c("background: #2f2d57; color: #ffffff;"))
)
)
})
}
shinyApp(ui = ui, server = server)
EDIT: In the code above, I used the same code structure provided in the question, but, for this simple example, there is no reason to have code for the UI elements on the server side. Here is an alternative example:
library(shinyWidgets)
ui <- fluidPage(
fluidRow(
pickerInput(
inputId = "three_code_zip_selector",
label = NULL,
choices = c(3, 4, 8, 5, 2, 6, 7),
options = list(
title = "Please Select Desired Number",
`live-search` = TRUE,
style = c("background: #2f2d57; color: #ffffff;"))
)
)
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
my question relates to observing the event of toggling and untoggling of the header in bsCollapsePanel in shinyBS.
Lets consider following following app as an example:
library(shiny)
library(shinyBS)
server = function(input, output, session) {
observeEvent(input$p1Button, ({
updateCollapse(session, "collapseExample", open = "Panel 1")
}))
observeEvent(input$styleSelect, ({
updateCollapse(session, "collapseExample", style = list("Panel 1" = input$styleSelect))
}))
output$randomNumber <- reactive(paste0('some random number'))
}
ui = fluidPage(
sidebarLayout(
sidebarPanel(HTML("This button will open Panel 1 using <code>updateCollapse</code>."),
actionButton("p1Button", "Push Me!"),
selectInput("styleSelect", "Select style for Panel 1",
c("default", "primary", "danger", "warning", "info", "success"))
),
mainPanel(
bsCollapse(id = "collapseExample", open = "Panel 2",
bsCollapsePanel("Panel 1", "This is a panel with just text ",
"and has the default style. You can change the style in ",
"the sidebar.", style = "info")
),
verbatimTextOutput('randomNumber')
)
)
)
app = shinyApp(ui = ui, server = server)
I want the app to be able to print a random number (using R shiny reactivity) in the verbatimTextOutput('randomNumber') field every time I open bsCollapsePanel by clicking on Panel 1 header.
I was thinking that it may be possible using shinyjs package but have not found many examples of these two packages used together.
Okay, Mike Wise was faster than me :)
If for some reason my solution is also helpful let me know otherwise i delete it.
library(shiny)
library(shinyjs)
library(shinyBS)
ui = fluidPage(
useShinyjs(),
sidebarLayout(
sidebarPanel(HTML("This button will open Panel1 using <code>updateCollapse</code>."),
actionButton("p1Button", "Push Me!"),
selectInput("styleSelect", "Select style for Panel1",
c("default", "primary", "danger", "warning", "info", "success"))
),
mainPanel(
bsCollapse(id = "collapseExample", open = "Panel 2",
bsCollapsePanel("Panel1", "This is a panel with just text ",
"and has the default style. You can change the style in ",
"the sidebar.", style = "info", id = "me23")
),
verbatimTextOutput('randomNumber')
)
)
)
server = function(input, output, session) {
observeEvent(input$p1Button, ({
updateCollapse(session, "collapseExample", open = "Panel1")
}))
observeEvent(input$styleSelect, ({
updateCollapse(session, "collapseExample", style = list("Panel1" = input$styleSelect))
}))
observe({
runjs("function getAllElementsWithAttribute(attribute){
var matchingElements = [];
var allElements = document.getElementsByTagName('*');
for (var i = 0, n = allElements.length; i < n; i++)
{
if (allElements[i].getAttribute(attribute) !== null)
{
// Element exists with attribute. Add to array.
matchingElements.push(allElements[i]);
}
}
return matchingElements;
};
ahref = getAllElementsWithAttribute('data-toggle');
ahref[0].onclick = function() {
var nmbr = Math.random();
Shiny.onInputChange('randomNumber', nmbr);
};
")
})
output$randomNumber <- reactive(paste0(input$randomNumber))
}
shinyApp(ui = ui, server = server)
Javascript code you can find here:
Get elements by attribute when querySelectorAll is not available without using libraries?
I am not completely sure what you want, but this might be close. These are the additions:
Added an observeEvent to monitor your Panel 1 header.
Added a reactiveValues to hold the "random number"
Incremented that value in the above observeEvent handler when Panel 1 is pushed.
Here is the code:
library(shiny)
library(shinyBS)
server = function(input, output, session) {
rv <- reactiveValues(number=0)
observeEvent(input$p1Button, ({
updateCollapse(session, "collapseExample", open = "Panel 1")
}))
observeEvent(input$styleSelect, ({
updateCollapse(session, "collapseExample", style = list("Panel 1" = input$styleSelect))
}))
observeEvent(input$collapseExample, ({
rv$number <- rv$number+1
}))
output$randomNumber <- reactive(rv$number)
}
ui = fluidPage(
sidebarLayout(
sidebarPanel(HTML("This button will open Panel 1 using <code>updateCollapse</code>."),
actionButton("p1Button", "Push Me!"),
selectInput("styleSelect", "Select style for Panel 1",
c("default", "primary", "danger", "warning", "info", "success"))
),
mainPanel(
bsCollapse(id = "collapseExample", open = "Panel 2",
bsCollapsePanel("Panel 1", "This is a panel with just text ",
"and has the default style. You can change the style in ",
"the sidebar.", style = "info")
),
verbatimTextOutput('randomNumber')
)
)
)
shinyApp(ui = ui, server = server)
And a screen shot: