Shiny - Can dynamically generated buttons act as trigger for an event - r

I have a shiny code that generates actions buttons from a numericInput and each of those actions buttons generate a plot when clicked using a observeEvent. The problem is that I don't know how to trigger an event with dynamically generated buttons. The workaround I used was to make a observeEvent for each button but if I generate more buttons than the obserEvents I created it won't work.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic selectInput"),
dashboardSidebar(
sidebarMenu(
menuItemOutput("menuitem")
)
),
dashboardBody(
numericInput("go_btns_quant","Number of GO buttons",value = 1,min = 1,max = 10),
uiOutput("go_buttons"),
plotOutput("plot")
)
)
server <- function(input, output, session) {
output$menuitem <- renderMenu({
menuItem("Menu item", icon = icon("calendar"))
})
output$go_buttons <- renderUI({
buttons <- as.list(1:input$go_btns_quant)
buttons <- lapply(buttons, function(i)
fluidRow(
actionButton(paste0("go_btn",i),paste("Go",i))
)
)
})
#Can this observeEvents be triggerd dynamicly?
observeEvent(input[[paste0("go_btn",1)]],{output$plot <-renderPlot({hist(rnorm(100,4,1),breaks = 10)})})
observeEvent(input[[paste0("go_btn",2)]],{output$plot <- renderPlot({hist(rnorm(100,4,1),breaks = 50)})})
observeEvent(input[[paste0("go_btn",3)]],{output$plot <- renderPlot({hist(rnorm(100,4,1),breaks = 100)})})
observeEvent(input[[paste0("go_btn",4)]],{output$plot <- renderPlot({hist(rnorm(100,4,1),breaks = 200)})})
observeEvent(input[[paste0("go_btn",5)]],{output$plot <- renderPlot({hist(rnorm(100,4,1),breaks = 500)})})
}
shinyApp(ui, server)

You can also create observers dynamically. Just make sure that they are created only once, otherwise they will execute several times.
Below is your code modified to create as many observers as buttons. Please note that if an observer for the button already exist, it should not be created. You can customize your observers too, so each observer could have its own behavior.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic selectInput"),
dashboardSidebar(
sidebarMenu(
menuItemOutput("menuitem")
)
),
dashboardBody(
numericInput("go_btns_quant","Number of GO buttons",value = 1,min = 1,max = 10),
uiOutput("go_buttons"),
plotOutput("plot")
)
)
server <- function(input, output, session) {
output$menuitem <- renderMenu({
menuItem("Menu item", icon = icon("calendar"))
})
# to store observers and make sure only once is created per button
obsList <- list()
output$go_buttons <- renderUI({
buttons <- as.list(1:input$go_btns_quant)
buttons <- lapply(buttons, function(i)
{
btName <- paste0("go_btn",i)
# creates an observer only if it doesn't already exists
if (is.null(obsList[[btName]])) {
# make sure to use <<- to update global variable obsList
obsList[[btName]] <<- observeEvent(input[[btName]], {
cat("Button ", i, "\n")
output$plot <-renderPlot({hist(rnorm(100, 4, 1),breaks = 50*i)})
})
}
fluidRow(
actionButton(btName,paste("Go",i))
)
}
)
})
}

Related

Call updateTabItems from inside Shiny module

In my shiny app I have lots of valueBoxes, each representing a tabItem in the sidebar of the shinydashboard. When clicking on the valueBox the page should move to the correct tab.
Instead of copypasting the code lots of times I wrote a reusable module which renders the valueBox and changes the class of the valueBox into an actionButton. In the server part I have included an observeEvent which calls updateTabItems when the valueBox is clicked. But when clicked nothing happens. It seems that the module cannot manipulate the dashboard sidebar.
library(shiny)
library(shinydashboard)
value_box_output <- function(.id) {
ns <- NS(.id)
valueBoxOutput(ns("overview.box"))
}
value_box <- function(input, output, session, .value, .subtitle, .tab.name) {
ns <- session$ns
output$overview.box <- renderValueBox({
box1 <- valueBox(
.value,
.subtitle,
href = "#",
width = NULL
)
box1$children[[1]]$attribs$class <- "action-button"
box1$children[[1]]$attribs$id <- ns("button")
box1
})
observeEvent(input$button, {
print("clicked")
updateTabItems(session, inputId = "tabs", selected = .tab.name)
})
}
ui <- dashboardPage(
dashboardHeader(title = "Title"),
dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("Overview", tabName = "Overview"),
menuItem("Tab 1", tabName = "Tab_1")
)
),
dashboardBody(
tabItems(
tabItem("Overview", value_box_output("tab")),
tabItem("Tab_1")
)
)
)
server <- function(input, output, session) {
callModule(value_box,
"tab",
.value = 33,
.subtitle = "Tab 1",
.tab.name = "Tab_1")
}
shinyApp(ui, server)
You can find the answer in this post: Accessing parent namespace inside a shiny module
Basically, in updateTabItems() inside a moulde, you need to call the parent's session, not the session of the modul.
Thus, add a variable for your session to callModule() and call it in updateTabItems().

Shiny module access output outside namespace

I need my Shiny module to hide/show a div outside of the namespace. I tried passing the div id to the module server function and using shinyjs to show/hide it but that is not working. I'm not getting an error, it just doesn't show/hide the div.
I know the Shiny module documentation says modules cannot access outputs outside the namespace. The docs do, though, give a way for the module to access inputs outside the namespace using reactives.
Does anyone know if there is a way for a Shiny module to access an output outside the namespace?
Here is what I'm trying to do:
### ui.R ###
header <- dashboardHeader(
title = a(href = 'http://google.com')
)
dashboardPage(
skin = 'black',
header,
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
)
### server.R ###
shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
callModule(selectClientModule, 'clientinfons', 'editclientinfo')
shinyjs::hide(id='editclientstuff')
})
### in global.R ###
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow = ''){
observeEvent(input$selectclient, {
if (!is.null(input$selectclient) && input$selectclient > 0){
print(paste0("showing ", divtoshow))
shinyjs::show(divtoshow)
}
})
}
That is possible by giving the value as a reactive (not as the value of the reactive) to the module. You can change the reactive Value in the module and return the reactive from the Module to the app (note, return the reactive itself, not its value). The following app switches the 'divtoshow' in the main app from inside the module. If nothing is selected, it's hidden, otherwise it's shown (note, I adjusted you code a little so it's working as a stand-alone app):
library(shinydashboard)
library(shinyjs)
# Module
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow){
observeEvent(input$selectclient, {
if (input$selectclient > 0){
print(paste0("showing editclientinfo"))
divtoshow("editclientinfo") # set the div to show to "editclientinfo", this will be visible outside the module
}else{
divtoshow("") # set the div to show to "", if nothing was chosen
}
})
# return the div to show as reactive to the main app
return(divtoshow)
}
# Main App
ui <- shinyUI(
dashboardPage(
skin = 'black',
dashboardHeader(
title = a(href = 'http://google.com')
),
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
))
server <- shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
# store the div to show in a reactive
divtoshow <- reactiveVal('')
# divtoshow can be changed in side this module, so it's a return value
divtoshow <- callModule(selectClientModule, 'clientinfons', divtoshow)
# observe the value of divtoshow and toggle the corresponding div
observeEvent(divtoshow(), {
if(divtoshow() == "editclientinfo"){
shinyjs::show("editclientinfo")
}else{
shinyjs::hide("editclientinfo")
}
})
})
shinyApp(ui, server)

Wrap a reactive UI in an action button RShiny

I have a tabbed UI that shows up whenever the user selects rows in a datatable (in the following code, the outputs are random, in real life the calculation is quite involved).
I would like to condition the tabbed UI showing up to the click of a button. Currently every time you select an additional row, it does the calculation all over again for the already selected rows. I would like to limit that to a one-time calculation when the user is done selecting all the rows he wants to see.
library(shiny)
library(DT)
The UI : the table, the action button and the tabbed section.
ui <- fluidPage(
mainPanel(
fluidRow(
column(12,DT::dataTableOutput(outputId = 'tableCurrencies'))
),
actionButton(inputId = 'showSelectedButton',label = 'Show Selec'),
fluidRow(
uiOutput("myTabUI")
)
)
)
The server function : If I remove the output$myTabUI <- eventReactive(input$launchCalcButton, { part and instead do output$myTabUI <- renderUI ({ ... directly it works as intended (minus the calculation following click on the button of course).
server <- function(input,output){
output$tableCurrencies <- DT::renderDataTable({datatable(data.frame(a=rnorm(10),b=rnorm(10),c=rnorm(10)))})
origTable_selected <- reactive({
ids <- input$tableCurrencies_rows_selected
return(ids)
})
output$myTabUI <- eventReactive(input$launchCalcButton, {
selectedTabs <- renderUI({
myTabs <- lapply(origTable_selected(),function(i) {
tabName <- paste0("test",i)
a <- renderPlot({
hist(rnorm(50))
})
output[[paste0(tabName,"rates")]] <- a
return(tabPanel(
tabName,
fluidRow(
column(6,plotOutput(paste0(tabName,"rates")))
)
))
})
return(do.call(tabsetPanel,myTabs))
})
selectedTabs
})
}
app = shinyApp(ui,server)
runApp(app,port=3250,host='0.0.0.0')
Not sure how to go about fixing this. Any help welcome.
You can use isolate() to limit reactive dependencies
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
fluidRow(
column(12,DT::dataTableOutput(outputId = 'tableCurrencies'))
),
actionButton(inputId = 'showSelectedButton',label = 'Show Selec'),
fluidRow(uiOutput("myTabUI"))
)
)
server <- function(input,output){
output$tableCurrencies <- DT::renderDataTable({
data.frame(a=rnorm(10),b=rnorm(10),c=rnorm(10))})
origTable_selected <- reactive({
input$tableCurrencies_rows_selected
})
output$myTabUI <- renderUI({
input$showSelectedButton
myTabs <- lapply(isolate(origTable_selected()),function(i) {
tabName <- paste0("test",i)
a <- renderPlot({hist(rnorm(50))})
output[[paste0(tabName,"rates")]] <- a
return(tabPanel(
tabName,
fluidRow(column(6,plotOutput(paste0(tabName,"rates"))))
))
})
do.call(tabsetPanel,myTabs)
})
}
shinyApp(ui,server)

Shiny checkbox input tracking

I am currently working on an application form using Shiny. My main page will consist of a table that will have a click button which will open a new modal window that will display the application form details. Once the save button is clicked the data will get stored in my DB in the backend. I have given a sample example of my app using mtcars.
My question is a two parter.
I have added checkbox to the main page rows and wish to track the click of these check boxes so that I can check the required ones and using their click event save some other value in the DB. How can I track this checkbox click event?
I need a single checkbox click to select about 150 or more check boxes simultaneously. Is there a way to capture all these click events together in an array or something and make use of them later?
Here is my code:
rm(list = ls())
library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)
library(shinydashboard)
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
ui <- dashboardPage(
dashboardHeader(title = "Simple App"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Menu Item 1", tabName = "one", icon = icon("dashboard"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "one",h2("Datatable Modal Popup"),
DT::dataTableOutput('my_table'),uiOutput("popup")
)
)
)
)
server <- function(input, output, session) {
my_data <- reactive({
testdata <- mtcars
as.data.frame(cbind(View = shinyInput(actionButton, nrow(testdata),'button_', label = "View", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
Check = shinyInput(checkboxInput,label = "Check", nrow(testdata), 'box_', value = FALSE),testdata))
})
output$my_table <- DT::renderDataTable(my_data(),selection = 'single',options = list(searching = FALSE,pageLength = 10),server = FALSE, escape = FALSE,rownames= FALSE)
SelectedRow <- eventReactive(input$select_button,{
as.numeric(strsplit(input$select_button, "_")[[1]][2])
})
observeEvent(input$select_button, {
toggleModal(session, "modalExample", "open")
})
DataRow <- eventReactive(input$select_button,{
my_data()[SelectedRow(),2:ncol(my_data())]
})
output$popup <- renderUI({
bsModal("modalExample", paste0("Data for Row Number: ",SelectedRow()), "", size = "large",
column(12,
DT::renderDataTable(DataRow())
)
)
})
}
shinyApp(ui, server)

R Shinydashboard dynamic menuItem

I'm trying to generate multiple menuItems dynamically, may be simple, but I'm not getting the right idea.
library(shiny)
library(shinydashboard)
port_tables<-c("tab1","tab2","tab3","tab4") # These are from a DB connection in the original code
function(input, output) {
output$smenu1 <- renderMenu({
sidebarMenu( id = "tabs",
h4("Tables",style="color:yellow;margin-left:20px;"),
paste("menuItem(\"",port_tables,"\",tabName=\"",port_tables,"\",icon=icon('th'))",collapse=",")
)
})
)
The menuItems from the paste function doesn't resolve( I get the result of paste function on the sidebar). I tried eval, eval(parse(paste(...))), both didn't work - what am I missing?
I couldn't quite make out what you're asking for, but here's an example of something with a dynamic menu.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic Menu"),
dashboardSidebar(
sidebarMenuOutput(outputId = "dy_menu")
),
dashboardBody(
tabItems(
tabItem(tabName = "main",
textInput(inputId = "new_menu_name",
label = "New Menu Name"),
actionButton(inputId = "add",
label = "Add Menu")
)
)
)
)
server <- function(input, output, session){
output$dy_menu <- renderMenu({
menu_list <- list(
menuItem("Add Menu Items", tabName = "main", selected = TRUE),
menu_vals$menu_list)
sidebarMenu(.list = menu_list)
})
menu_vals = reactiveValues(menu_list = NULL)
observeEvent(eventExpr = input$add,
handlerExpr = {
menu_vals$menu_list[[length(menu_vals$menu_list) + 1]] <- menuItem(input$new_menu_name,
tabName = input$new_menu_name)
})
}
shinyApp(ui, server)
I changed the code as follows and it worked :
library(shiny)
library(shinydashboard)
port_tables<-c("tab1","tab2","tab3","tab4") # These are from a DB connection in the original code
text1<-paste("menuItem(\"",port_tables,"\",tabName=\"",port_tables,"\",icon=icon('th'))")
text2<-paste("sidebarMenu(id = 'tabs',textInput('port', 'Enter port:'),h4('Tables',style='color:yellow;margin-left:20px;'),",paste(text1,collapse=","),paste(")"))
function(input, output) {
output$smenu1 <- renderMenu({
eval(parse(text=text2))
})
)
So, the key is put the whole content of sidebarMenu in a text field and evaluate it

Resources