Multiple action buttons with one event handler in Shiny? - r

I'd like to have a variable number of identical actionButton()s on a page all handled by one observeEvent() function.
For example, in a variable-length table of tables, I'd like each interior table to have a button that links to more information on that table.
In standard HTML, you do this with a simple form, where you use a hidden input to designate the interior table number, like this:
<form ...>
<input id="table_number" type="hidden" value="1"/>
<input type="submit" value="Examine"/>
</form>
When a button is pressed, you can examine the hidden input to see which one it was.
Is there a way to do this in Shiny? The only solution I've come up with is to give each actionButton() it's own inputId. This requires a separate observeEvent() for each button. Those have to be created ahead of time, imposing a maximum number of buttons.

It only took me a couple of years, but I now have a much better answer to this question. You can use a JavaScript/jQuery function to put an on-click event handler on every button in a document, then use the Shiny.onInputChange() function to pass the ID of a button (<button id="xxx"...) that has been clicked to a single observer in your Shiny code.
There's a full description with code examples at One observer for all buttons in Shiny using JavaScript/jQuery

You could use shiny modules for this: you can have variable number of actionButton that are identical. These are defined in the ab_moduleUI part. They are handled by their own observeEvent but it has to be defined only once in the ab_module part.
With lapply any number of actionButton can be created.
Edit: You don't have to specify the number of buttons beforehand: use renderUI to generate UI elements at server side.
For demonstration purposes I added a numericInput to increase/decrease the number of modules to render.
# UI part of the module
ab_moduleUI <- function(id){
ns <- NS(id)
tagList(
fluidRow(
actionButton(ns("btn"), paste("ActionButton", id, sep="-")),
textOutput(ns("txt"))
)
)
}
# Server part of the module
ab_module <- function(input, output, session){
observeEvent(input$btn,{
output$txt <- renderText("More information shown")
})
}
# UI
ui <- fluidPage(
# lapply(paste0("mod", 1:no_btn), ab_moduleUI)
numericInput("num", "Number of buttons to show" ,value = 5, min = 3, max = 10),
uiOutput("ui")
)
# Server side
server <- function(input, output, session){
observeEvent(input$num, {
output$ui <- renderUI({
lapply(paste0("mod", 1:input$num), ab_moduleUI)
})
lapply(paste0("mod", 1:input$num), function(x) callModule(ab_module, x))
})
}
shinyApp(ui, server)
Read more about shiny modules here

Regarding the use of Shiny modules to answer my original question...
What I'd like to have is a way to have multiple buttons on a page that can be handled by a single observeEvent(), which is easy to do with traditional HTML forms, as shown in the original question.
GyD's demonstration code using Shiny modules almost solves the problem, but it doesn't actually return which button was pressed to the main server. It took me a long time, but I finally figured out how to write a module that does let the main server know which button was pressed:
actionInput <- function(id) {
ns <- NS(id)
tagList(
textInput(ns("text"), label=NULL, value=id),
actionButton(ns("button"), "OK")
)
}
action <- function(input, output, session) {
eventReactive(input$button, {
return(input$text)
})
}
ui <- fluidPage(fluidRow(column(4, actionInput("b1")),
column(4, actionInput("b2")),
column(4, uiOutput("result"))))
server <-function(input, output, session) {
b1 <- callModule(action, "b1")
observeEvent(b1(), {
output$result = renderText(b1())
})
b2 <- callModule(action, "b2")
observeEvent(b2(), {
output$result = renderText(b2())
})
}
shinyApp(ui = ui, server = server)
(In a real application, I would make the textInputs invisible, as they're only there to provide an id for which button was pressed.)
This solution still requires an observeEvent() in the main server for each button. It may be possible to use modules in some other way to solve the problem, but I haven't been able to figure it out.
My original alternative, using a separate observeEvent() in the main server for each button, is actually quite a bit simpler than an expansion of this demo code would be for a hundred or more buttons.

Related

Force input widget creation in Shiny even if widget has not yet been displayed in browser

In Shiny, one can use the following line to force displaying/refreshing an output even if not displayed within the ui:
outputOptions(output, "my_output", suspendWhenHidden = FALSE)
Is there a similar way to "force" input widget creation?
My context: I do have a button that pre-populate a textinput on another tab. Potentially, this textinput may not been generated yet if user didn't go to this specific tab. In such a case, the pre-population legitimely fails.
Good practice would probably be to use a reactiveValues, to feed it with the "pre-populate value" when clicking the button, and then to use this rv within the input widget creation. But I was wondering if a similar option as the above was available in Shiny.
Here’s a simple, working example of the situation I think you are describing.
That is, you don’t need to do anything special.
library(shiny)
ui <- fluidPage(
tabsetPanel(
tabPanel("A", actionButton("populate", "Populate B things")),
tabPanel("B", textInput("b_text", "Add some B text"))
)
)
server <- function(input, output, session) {
observeEvent(input$populate, {
updateTextInput(session, "b_text", value = "Updated from tab A")
})
}
shinyApp(ui, server)
If the input you want to update is generated with uiOutput() then you can
use outputOptions() to force evaluation, like you already mentioned:
library(shiny)
ui <- fluidPage(
tabsetPanel(
tabPanel("A", actionButton("populate", "Populate B things")),
tabPanel("B", uiOutput("b_panel"))
)
)
server <- function(input, output, session) {
observeEvent(input$populate, {
updateTextInput(session, "b_text", value = "Updated from tab A")
})
output$b_panel <- renderUI({
textInput("b_text", "Add some B text")
})
outputOptions(output, "b_panel", suspendWhenHidden = FALSE)
}
shinyApp(ui, server)

Set an Output Component to Empty in R/Shiny

I have uiOutput and plotOutput components in my main Shiny panel.
plotOutput("plot_data"),
uiOutput("summary_data")
I have the typical code in the server function to react and populate each component, for example:
output$plot_data <- renderPlot({
hist(data_vars())
})
output$summary_data <- renderPrint({
summary(data_vars())
})
I'd like to add functionality to each that sets the output component of the other to NULL or an empty string, etc. so that these two outputs share the same space. When one has data, the other is empty. I don't think it would work this way, but it could look like this:
output$plot_data <- renderPlot({
# Code to "flatten" uiOutput
# Then populate the component
hist(data_vars())
})
output$summary_data <- renderPrint({
# Code to "flatten" plotOutput
# Then populate the component
summary(data_vars())
})
I think this might be done using observeEvent, but I haven't found a way to completely remove content from one so that the other could take up the same space on the page. Please help. Thank you.
Rather than having a separate plotOutput and printOutput, you can have just one uiOutput and then you can add code in the server to show which output you would like in that slot. Here's a working example where I added a button to swap between views.
library(shiny)
ui <- fluidPage(
actionButton("swap","Swap"),
uiOutput("showPart")
)
server <- function(input, output, session) {
showState <- reactiveVal(TRUE)
observeEvent(input$swap, {showState(!showState())})
output$plot_data <- renderPlot({
hist(mtcars$mpg)
})
output$summary_data <- renderPrint({
summary(mtcars)
})
output$showPart <- renderUI({
if (showState()) {
plotOutput("plot_data")
} else {
verbatimTextOutput("summary_data")
}
})
}
shinyApp(ui, server)
Using this method only one of the two output will be rendered in the uiOutput slot.

Using insertUI and actionButton Combination in R Shiny Modules

I am trying to use the combination of Action Button and InsertUI to help the user input excel Files. Once the user clicks on the button, the FileInput box should appear (I will then handle the fileinput$datapath later to create a dataframe.)
In the code below, I try to:
generate a button using actionButton in the UI code
Use the actionButton via ObserveEvent to trigger the InsertUI code which should ideally insert the fileInput part of the code once the button in 1. is clicked. I want the file input to be in the server part of the code rather than UI part of the code.
I tried the below code where i can generate a button, but unable to
trigger the observeEvent. Any help here is highly appreciated please.
library(shiny)
Import.Excel.Data.UI <- function(id){
ns <- NS(id)
tagList(
actionButton(ns("AddExcelDataButton"), label = "Click Here to Add Excel Data"),
)
}
Import.Excel.Data.Server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
observeEvent(eventExpr = input$AddExcelDataButton,
insertUI(selector="#AddExcelDataButton",
where = "afterEnd",
ui = fileInput(inputId = paste0("File",input$AddExcelDataButton),
label = paste0("Path for File",input$AddExcelDataButton),
multiple = FALSE)))
})
}
Import.Excel.Data.App <- function(){
ui <- fluidPage(
Import.Excel.Data.UI("File1")
)
server <- function(input, output, session){
Import.Excel.Data.Server("File1")
}
shinyApp(ui, server)
}
Import.Excel.Data.App()
You need to use the namespace:
insertUI(selector=paste0("#", ns("AddExcelDataButton")), ......

Shiny: How to change the page/window title in Shiny?

There are numerous posts regarding changing titles of other pieces of Shiny apps, e.g.:
Change the title by pressing a shiny button Shiny R
Shiny page title and image
Shiny App: How to dynamically change box title in server.R?
My question is related, but not answered by any of these. I would like to make the <head><title>...</title></head> tag reactive, or at least controllable from within an observeEvent in server.R.
The following does not work, since ui can't find theTitle, but is the kind of approach I'd hope is possible:
library(shiny)
ui <- fluidPage(
title = theTitle(),
textInput("pageTitle", "Enter text:")
)
server <- function(input, output, session) {
theTitle <- reactiveVal()
observeEvent( input$pageTitle, {
if(is.null(input$pageTitle)) {
theTitle("No title yet.")
} else {
theTitle(input$pageTitle)
}
})
}
I've tried making output$theTitle <- renderText({...}) with the if..else logic in that observeEvent, and then setting title = textOutput("theTitle") in ui's fluidPage, but that generates <div ...> as the title text, or <span ...> if we pass inline=True to renderText.
In case this clarifies what I'm looking for, the answer would make something equivalent to the literal (replacing string variables with that string) ui generated by
ui <- fluidPage(
title = "No title yet.",
....
)
before the user has entered any text in the box; if they have entered "Shiny is great!" into input$pageTitle's box, then we would get the literal
ui <- fluidPage(
title = "Shiny is great!",
....
)
One way would be to write some javascript to take care of that. For example
ui <- fluidPage(
title = "No title yet.",
textInput("pageTitle", "Enter text:"),
tags$script(HTML('Shiny.addCustomMessageHandler("changetitle", function(x) {document.title=x});'))
)
server <- function(input, output, session) {
observeEvent( input$pageTitle, {
title <- if(!is.null(input$pageTitle) && nchar(input$pageTitle)>0) {
input$pageTitle
} else {
"No title yet."
}
session$sendCustomMessage("changetitle", title)
})
}
shinyApp(ui, server)
This was created following the How to send messages from the browser to the server and back using Shiny guide
As of June 2021, there is an R package called shinytitle that can update the window title from within Shiny's reactive context: https://cran.r-project.org/package=shinytitle

Disabling buttons in Shiny

I am writing some Shiny code where the user will enter some inputs to the app and then click a an action button. The action button triggers a bunch of simulations to run that take a long time so I want once the action button is clicked for it to be disabled so that the user can't keep clicking it until the simulations are run. I came across the shinyjs::enable and shinyjs::disable functions but have been having a hard time utilizing them. Here is my server code:
output$button1= renderUI({
if(input$Button1 > 0) {
shinyjs::disable("Button1")
tableOutput("table")
shinyjs::enable("Button1")}
})
However, when I use this code, and click the action button nothing happens. I.e., teh action button doesn't grey out nor does the table get generated. However, when I take away the shinyjs::enable() command, i.e.,
output$button1= renderUI({
if(input$Button1 > 0) {
shinyjs::disable("Button1")
tableOutput("table")
}
})
The table gets generated first, and then the button goes grey, however I would have expected the button to go grey and then the table to generate itself.
What am I doing wrong here?
Here is my updated code based on Geovany's suggestion yet it still doesn't work for me
Button1Ready <- reactiveValues(ok = FALSE)
observeEvent(input$Button1, {
shinyjs::disable("Button1")
RunButton1Ready$ok <- FALSE
RunButton1Ready$ok <- TRUE
})
output$SumUI1= renderUI({
if(Button1Ready$ok){
tableOutput("table")
shinyjs::enable("Button1")
}
})
where for clarification I have also:
output$table <- renderTable({
#My code....
)}
I think that you are using shinyjs::disable and shinyjs::enable in the same reactive function. You will only see the last effect. I will recommend you to split in different reactive functions the disable/enable and use an extra reactive variable to control the reactivation of the button.
I don't know how exactly your code is, but in the code below the main idea is illustrated.
library(shiny)
library(shinyjs)
ui <- fluidPage(
shinyjs::useShinyjs(),
sidebarLayout(
sidebarPanel(
actionButton("Button1", "Run"),
shinyjs::hidden(p(id = "text1", "Processing..."))
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output) {
plotReady <- reactiveValues(ok = FALSE)
observeEvent(input$Button1, {
shinyjs::disable("Button1")
shinyjs::show("text1")
plotReady$ok <- FALSE
# do some cool and complex stuff
Sys.sleep(2)
plotReady$ok <- TRUE
})
output$plot <-renderPlot({
if (plotReady$ok) {
shinyjs::enable("Button1")
shinyjs::hide("text1")
hist(rnorm(100, 4, 1),breaks = 50)
}
})
}
shinyApp(ui, server)

Resources