Is it possible to capture the label of an actionButton once it is clicked?
Imagine I have 3 buttons on my ui.R and depending on which one I click I want to perform a different action on the server.R.
One caveat is that the buttons are created dynamically on the server.R with dynamic labels (thus the necessity of capturing the label on click)
Thanks
Something like that ?
library(shiny)
server <- function(input, session, output) {
output$printLabel <- renderPrint({input$btnLabel})
}
ui <- fluidPage(
actionButton("btn1", "Label1",
onclick = "Shiny.setInputValue('btnLabel', this.innerText);"),
actionButton("btn2", "Label2",
onclick = "Shiny.setInputValue('btnLabel', this.innerText);"),
verbatimTextOutput("printLabel")
)
shinyApp(ui = ui, server = server)
1) What button was clicked last by the user?
To answer this you can user observeEvent function and by setting up a a variable using reactiveValues function. Make sure you update your libraries and work in the latest version of R (version 3.1.3) as shiny is dependant on this version. Working on windows you can follow example on how to update here
rm(list = ls())
library(shiny)
ui =fluidPage(
sidebarPanel(
textInput("sample1", "Name1", value = "A"),
textInput("sample2", "Name2", value = "B"),
textInput("sample3", "Name3", value = "C"),
div(style="display:inline-block",uiOutput("my_button1")),
div(style="display:inline-block",uiOutput("my_button2")),
div(style="display:inline-block",uiOutput("my_button3"))),
mainPanel(textOutput("text1"))
)
server = function(input, output, session){
output$my_button1 <- renderUI({actionButton("action1", label = input$sample1)})
output$my_button2 <- renderUI({actionButton("action2", label = input$sample2)})
output$my_button3 <- renderUI({actionButton("action3", label = input$sample3)})
my_clicks <- reactiveValues(data = NULL)
observeEvent(input$action1, {
my_clicks$data <- input$sample1
})
observeEvent(input$action2, {
my_clicks$data <- input$sample2
})
observeEvent(input$action3, {
my_clicks$data <- input$sample3
})
output$text1 <- renderText({
if (is.null(my_clicks$data)) return()
my_clicks$data
})
}
runApp(list(ui = ui, server = server))
2) Save the clicks for further manipulation is below
Here's small example based on the work of jdharrison from Shiny UI: Save the Changes in the Inputs and the shinyStorage package.
rm(list = ls())
#devtools::install_github("johndharrison/shinyStorage")
library(shinyStorage)
library(shiny)
my_clicks <- NULL
ui =fluidPage(
#
addSS(),
sidebarPanel(
textInput("sample_text", "test", value = "0"),
uiOutput("my_button")),
mainPanel(uiOutput("text1"))
)
server = function(input, output, session){
ss <- shinyStore(session = session)
output$my_button <- renderUI({
actionButton("action", label = input$sample_text)
})
observe({
if(!is.null(input$sample_text)){
if(input$sample_text != ""){
ss$set("myVar", input$sample_text)
}
}
})
output$text1 <- renderUI({
input$action
myVar <- ss$get("myVar")
if(is.null(myVar)){
textInput("text1", "You button Name")
}else{
textInput("text1", "You button Name", myVar)
}
})
}
runApp(list(ui = ui, server = server))
Related
I'm trying to save and load state of a shiny app using bookmarks. However, it doesn't work and I wonder whether it is because of inserting dynamic UI. If there are other ways to save and load dynamically rendered ui and resulting output, that would be great too. I don't know where to start and this is as far as I could come.
Simple example
library(shiny)
ui <- function(request){fluidPage(
actionButton("add", "Add UI"),
bookmarkButton()
)}
# Server logic
server <- function(input, output, session) {
observeEvent(input$add, {
insertUI(
selector = "#add",
where = "afterEnd",
ui = textInput(paste0("txt", input$add),
"Insert some text")
)
})
}
# Complete app with UI and server components
shinyApp(ui, server, enableBookmarking = "server")
Complex example
library(shiny)
one_plotUI <- function(id) {
ns <- NS(id)
plotOutput(ns("plot"))
}
one_plot <- function(id, x, y, type, breaks, break_counts) {
moduleServer(
id,
function(input, output, session) {
output$plot <- renderPlot({
if (type == "scatter") {
plot(x, y)
} else {
if (breaks == "custom") {
breaks <- break_counts
}
hist(x, breaks = breaks)
}
})
}
)
}
ui <- fluidPage(
sidebarPanel(
bookmarkButton(),
selectInput("plotType", "Plot Type",
c(Scatter = "scatter", Histogram = "hist")
),
# Only show this panel if the plot type is a histogram
conditionalPanel(
condition = "input.plotType == 'hist'",
selectInput(
"breaks", "Breaks",
c("Sturges", "Scott", "Freedman-Diaconis", "[Custom]" = "custom")
),
# Only show this panel if Custom is selected
conditionalPanel(
condition = "input.breaks == 'custom'",
sliderInput("breakCount", "Break Count", min = 1, max = 50, value = 10)
)
),
actionButton("make_plot", "Insert new plot")
),
mainPanel(
div(id = "add_here")
)
)
server <- function(input, output) {
x <- rnorm(100)
y <- rnorm(100)
counter_plots <- 1
observeEvent(input$make_plot, {
current_id <- paste0("plot_", counter_plots)
# call the logic for one plot
one_plot(id = current_id,
x = x,
y = y,
type = input$plotType,
breaks = input$breaks,
break_counts = input$breakCount)
# show the plot
insertUI(selector = "#add_here",
ui = one_plotUI(current_id))
# update the counter
counter_plots <<- counter_plots + 1
})
}
shinyApp(ui, server, enableBookmarking = "server")
edit: Found another solution emulating what insertUI does but with renderUI:
library(shiny)
library(purrr)
ui <- function(request){fluidPage(
actionButton("add", "Add UI"),
uiOutput('dynamic_ui'),
bookmarkButton()
)}
# Server logic
server <- function(input, output, session) {
input_contents <- reactive({reactiveValuesToList(input)})
observeEvent(input$add, {
# a new ui will be rendered with one extra input each time add button is pressed
output$dynamic_ui <- renderUI({
map(1:input$add, ~textInput(inputId = paste0("txt", .x), label = paste0("txt", .x) ))
})
#add the old values, otherwise all the inputs will be empty agin.
input_contents() %>%
names() %>%
map(~ updateTextInput(session = session, inputId = .x, label = .x, value = input_contents()[[.x]]))
})
}
# Complete app with UI and server components
shinyApp(ui, server, enableBookmarking = "server")
insertUI might be broken. The only way i could "fix" it was to drop function(request) of the ui, that caused that all the values in the inputs have to be saved between stances (in state$values$input_restore). Also a warning is showed in the console, but it doesn't affect the functionality.
library(shiny)
library(tidyverse)
library(stringr)
ui <- fluidPage(
actionButton("add", "Add UI"),
uiOutput('restored_ui'), #this is very important
bookmarkButton())
# Server logic
server <- function(input, output, session) {
counter <- reactiveValues()
counter$n <- c(0) #This value is only used to initialize the object.
total_ui_count <- reactiveValues()
total_ui_count$info <- 0 #because input$add will reset to zero this will count the number of uis to remember.
#When bookmark button is pressed
onBookmark(function(state) {
state$values$currentCounter <- counter$n
state$values$input_restore <- reactiveValuesToList(input)
print(names(input) %>% str_subset('^txt'))
state$values$total_uis_to_restore <- counter$n[[length(counter$n)]]
})
#rerender the previous outputs and their values
onRestore(function(state) {
#restore values from previous state
counter$n <- state$values$currentCounter
vals <- state$values$input_restore
print(str_subset(names(vals), '^txt.*$')) #for debugging
total_ui_count$info <- state$values$total_uis_to_restore
print(total_ui_count$info)
#render back a ui with the previous values.
output$restored_ui <- renderUI({
str_subset(names(vals), '^txt.*$') %>%
sort(decreasing = TRUE) %>% #to avoid order reversal of the inputs
map(~ textInput(.x, label = .x, value = vals[[.x]])) #render the last inputs
})
})
observeEvent(input$add, {
#input$add starts as 1 in the next state (because ui is not wrapped in function(request)) that's why total_ui_count is present
counter$n <- c(counter$n, input$add + total_ui_count$info)
print(counter$n) #for debugging
insertUI(
selector = "#add",
where = "afterEnd",
ui = textInput(inputId = paste0("txt", counter$n[[length(counter$n)]]),
label = "Insert some text")
)})
}
# Complete app with UI and server components
shinyApp(ui, server, enableBookmarking = "server")
Consider this sample shiny application. You can type in a car name like "Valiant" and it will print out the MPG value from the mtcars built-in data set. I also wanted to allow the user to click on a car rather than type it. I did this by generating a list of links with car names and writing a bit of javascript to call Shiny.setInputValue when the link is clicked.
I noticed that when a link is clicked, the server state updates (ie the textOutput("MPG") value changes) but the text box doesn't update to show the current value. Is there a different way to get the value such that the textInput is updated AND the reactive textOutput is updated?
library(shiny)
script <- "$(document).on('click', '.name-opt a', function (evt) {
evt.preventDefault(); Shiny.setInputValue('name',this.dataset.name);
});"
ui <- fluidPage(
tags$head(tags$script(HTML(script))),
textInput("name", "Name:"),
textOutput("MPG"),
uiOutput("carlist")
)
server <- function(input, output, session) {
output$carlist <- renderUI({
tags$ul(
Map(function(v) tags$li(tags$a(v, href="#", "data-name"=v)), rownames(head(mtcars, 20))),
class="name-opt")
})
output$MPG <- renderText({
req(input$name)
paste(input$name, "mpg:", mtcars[input$name,]$mpg)
})
}
shinyApp(ui, server)
Tested with shiny_1.5.0
Serverside: You have to make a reactive value, here: myinput, and then call its value with myinput(). Then you need observer that fires the updateTextInput whenever myinput() changes
myinput = reactive({
paste(input$name)
})
observeEvent(myinput(),{
updateTextInput(session, "name", value = myinput())
})
The whole code:
library(shiny)
script <- "$(document).on('click', '.name-opt a', function (evt) {
evt.preventDefault(); Shiny.setInputValue('name',this.dataset.name);
});"
ui <- fluidPage(
tags$head(tags$script(HTML(script))),
textInput("name", "Name:"),
textOutput("MPG"),
uiOutput("carlist")
)
server <- function(input, output, session) {
output$carlist <- renderUI({
tags$ul(
Map(function(v) tags$li(tags$a(v, href="#", "data-name"=v)), rownames(head(mtcars, 20))),
class="name-opt")
})
output$MPG <- renderText({
req(input$name)
paste(input$name, "mpg:", mtcars[input$name,]$mpg)
})
myinput = reactive({
paste(input$name)
})
observeEvent(myinput(),{
updateTextInput(session, "name", value = myinput())
})
}
shinyApp(ui, server)
In the following app, I would like to add a global button, to save the tables in the 2 panels at the same time.
Ideally, they should be saved to an xlsx file, in tabs named after the corresponding tabs.
Please note that the tabs were created using a module.
Many thanks!!
library(shiny)
library(DT)
modDtUi <- function(id){ # UI module
ns = NS(id)
DT::dataTableOutput(ns('x1'))
}
modDt <- function(input, output, session, data, globalSession){ # Server module
x <- data
output$x1 <- DT::renderDataTable(x, selection = 'none', editable = TRUE)
proxy <- dataTableProxy('x1', session = globalSession)
}
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Table1", modDtUi("editable")),
tabPanel("Table2", modDtUi("editable2"))
)
)
)
server <- function(input, output, session) {
callModule(modDt,"editable", data = head(iris,10), globalSession = session)
callModule(modDt,"editable2", data = tail(iris,5), globalSession = session)
}
shinyApp(ui = ui, server = server)
I believe this demo works.
I used reactiveValues v$data to store the data inside the module. The module will return v$data so it can be retrieved when you want to save the data in the shiny server.
I also added an observeEvent to detect changes in the data, and update the data table with replaceData.
The excel file is created using the writexl library, but you could substitute with others of course.
Let me know if this works for you. I imagine there are some elements of this answer that can be improved upon - and if we can identify them, would like to edit further.
library(shiny)
library(DT)
library(writexl)
modDtUi <- function(id){ # UI module
ns = NS(id)
DT::dataTableOutput(ns(id))
}
modDt <- function(input, output, session, data, id, globalSession){ # Server module
v <- reactiveValues(data = data)
output[[id]] <- DT::renderDataTable(v$data, selection = 'none', editable = TRUE)
proxy <- dataTableProxy(id, session = globalSession)
id_input = paste(id, "cell_edit", sep = "_")
# Could add observeEvent here to detect edit event
observeEvent(input[[id_input]], {
info = input[[id_input]]
if (!is.null(info)) {
v$data[info$row, info$col] <<- DT::coerceValue(info$value, v$data[info$row, info$col])
}
replaceData(proxy, v$data, resetPaging = FALSE)
})
return(data = reactive({v$data}))
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
width = 2,
actionButton("btn", "Save Both")
),
mainPanel(
tabsetPanel(
tabPanel("Table1", modDtUi("editable1")),
tabPanel("Table2", modDtUi("editable2"))
)
)
)
)
server <- function(input, output, session) {
e1 <- callModule(modDt, "editable1", data = head(iris,10), id = "editable1", globalSession = session)
e2 <- callModule(modDt, "editable2", data = tail(iris,5), id = "editable2", globalSession = session)
observeEvent(input$btn, {
print("Saving...")
sheets <- list("e1" = e1(), "e2" = e2())
write_xlsx(sheets, "test.xlsx")
})
}
shinyApp(ui = ui, server = server)
I have the following Shiny Application:
library(shiny)
library(shinyjs)
library(shinydashboard)
UI <- fluidPage(
actionButton("get_tweets", "Fetch tweets"),
numericInput("tweet_amount", "Set the amount of Tweets", 10, min = 10, max = 1000),
selectInput("tweet_name", "Select the tweeter", selected = NULL, choices = c("#RealDonaldTrump")),
#Set hidden buttons
hidden(
div(id="status_update",
verbatimTextOutput("status")
)
),
hidden(
div(id="tweet_fetcher",
verbatimTextOutput("status2")
)
)
)
Server <- function(input, output){
list = c(1,2,3)
get_connected <- reactive({
for(i in 1:length(list)){
Sys.sleep(2)
}
})
observeEvent(input$get_tweets, {
get_connected()
toggle("status_update")
output$status <- renderText({"You're now connected to the API"})
toggle("tweet_fetcher")
output$status2 <- renderText("Test")
})
}
shinyApp(ui = UI, server = Server)
Thing is that now I works. However, ideally I would like to make sure a button appears. Therefore I want to change:
output$status2 <- renderText("Test")
and this
verbatimTextOutput("status2") #actionButton("status2", "a_button")
This does not work. Any tips on what I should use if I want JS to let a button appear?
If i understand the question correctly you want to interchange
verbatimTextOutput("status2") with actionButton("status2", "a_button").
Then you should use renderUI():
Server side: output$status2 <- renderUI(actionButton("status2",
"a_button"))
UI side: uiOutput("status2")
Full app would read:
library(shiny)
library(shinyjs)
library(shinydashboard)
UI <- fluidPage(
actionButton("get_tweets", "Fetch tweets"),
numericInput("tweet_amount", "Set the amount of Tweets", 10, min = 10, max = 1000),
selectInput("tweet_name", "Select the tweeter", selected = NULL, choices = c("#RealDonaldTrump")),
#Set hidden buttons
hidden(
div(id="status_update",
verbatimTextOutput("status")
)
),
hidden(
div(id="tweet_fetcher",
uiOutput("status2")
)
)
)
Server <- function(input, output){
list = c(1,2,3)
get_connected <- reactive({
for(i in 1:length(list)){
Sys.sleep(2)
}
})
observeEvent(input$get_tweets, {
get_connected()
toggle("status_update")
output$status <- renderText({"You're now connected to the API"})
toggle("tweet_fetcher")
output$status2 <- renderUI(actionButton("status2", "a_button"))
})
}
shinyApp(ui = UI, server = Server)
I have a R Shiny app that contains checkboxGroupInput, and I'm trying to create a "select all" button, using updateCheckboxGroupInput function.
You can see the full code below, but basically I defined the cb groups like this:
checkboxGroupInput("campaigns","Choose campaign(s):",campaigns_list)
and then, on a button click, call the function:
updateCheckboxGroupInput(session,"campaigns","Choose campaign(s):",choices=campaigns_list,selected=campaigns_list)
I have an indication that the function ran, but what it does is actually UNselecting the checkboxes.
BTW, when I put the selected upon defining the cbGroupInput it did worked, but not on the function.
Thanks!
this is my server.R:
library(shiny)
source('usefulFunctions.R')
shinyServer(function(input, output, session) {
output$cascading <- renderUI({
provider_id <- input$provider
if (provider_id == "") return(NULL)
campaigns_list <<- t(getCampaigns(provider_id))
tagList(
checkboxGroupInput("campaigns","Choose campaign(s):",
choices = campaigns_list, selected = campaigns_list),
actionLink("selectall","Select All")
)
})
observe({
if(is.null(input$selectall)) return(NULL)
if (input$selectall > 0)
{
print(campaigns_list)
updateCheckboxGroupInput(session,"campaigns","Choose campaign(s):",choices=campaigns_list,selected=campaigns_list)
}
})
})
I also added the select and unselect options here by checking if the button or link are divisible by 2
#rm(list = ls())
library(shiny)
campaigns_list <- letters[1:10]
ui =fluidPage(
checkboxGroupInput("campaigns","Choose campaign(s):",campaigns_list),
actionLink("selectall","Select All")
)
server = function(input, output, session) {
observe({
if(input$selectall == 0) return(NULL)
else if (input$selectall%%2 == 0)
{
updateCheckboxGroupInput(session,"campaigns","Choose campaign(s):",choices=campaigns_list)
}
else
{
updateCheckboxGroupInput(session,"campaigns","Choose campaign(s):",choices=campaigns_list,selected=campaigns_list)
}
})
}
runApp(list(ui = ui, server = server))
If campaigns_list is a list, might be because you are specifying the list of all your choices instead of the value of the boxes that should be selected in the selected argument of your updateCheckboxGroupInput.
Try replacing selected=campaigns_list by selected=unlist(campaigns_list).
Here is an example with dummy names:
library(shiny)
server<-function(input, output,session) {
observe({
if(input$selectall == 0) return(NULL)
else if (input$selectall > 0)
{
variables<-list("Cylinders" = "cyl","Transmission" = "am","Gears" = "gear")
updateCheckboxGroupInput(session,"variable","Variable:",choices=variables,selected=unlist(variables))
}
})
}
ui <- shinyUI(fluidPage(
checkboxGroupInput("variable", "Variable:",list("Cylinders" = "cyl","Transmission" = "am","Gears" = "gear")),
actionButton("selectall", "Select All")
))
shinyApp(ui = ui, server = server)