Here's an example:
library(shiny)
mod_ui <- function(id){
ns <- NS(id)
tabPanel(
"tab 2",
actionButton(ns("change_dataset"), "change dataset")
)
}
mod_server <- function(input, output, session){
data <- reactive({ mtcars })
observeEvent(input$change_dataset, {
data <- reactive({ iris })
# Comment the line above and uncomment the
# one below to check that this button works:
# print("button works")
})
return(
list(
data_1 = data
)
)
}
ui <- navbarPage(
title = "",
id = "a_navbar",
tabPanel(
"tab 1",
dataTableOutput("data_test")
),
mod_ui("tab_2")
)
server <- function(input, output, session) {
mod_return <- callModule(mod_server, "tab_2")
output$data_test <- renderDataTable({
mod_return$data_1()
})
}
shinyApp(ui, server)
Basically, this app displays the mtcars dataset in tab 1, and it should display the iris dataset if the user clicks on the button "change dataset" in tab 2. But clicking on this button does not update the table. Why is this the case? How can I fix it?
You should avoid nesting reactives in observers.
You can use eventReactive instead. Please check the following:
library(shiny)
library(DT)
mod_ui <- function(id) {
ns <- NS(id)
tabPanel("tab 2",
actionButton(ns("change_dataset"), "change dataset"))
}
mod_server <- function(input, output, session) {
data <- eventReactive(input$change_dataset, {
if (input$change_dataset %% 2) {
iris
} else {
mtcars
}
}, ignoreNULL = FALSE)
return(list(data_1 = data))
}
ui <- navbarPage(
title = "",
id = "a_navbar",
tabPanel("tab 1",
DT::dataTableOutput("data_test")),
mod_ui("tab_2")
)
server <- function(input, output, session) {
mod_return <- callModule(mod_server, "tab_2")
output$data_test <- DT::renderDataTable({
mod_return$data_1()
})
}
shinyApp(ui, server)
Another approach would be to set a reactiveVal in the observeEvent.
Related
I am trying to pass a value assigned in an observeEvent to another observeEvent in shiny. In addition to the codes below, I also attempted to use my_dynamic_table(), but unfortunately I couldn't achieve my goal.
My aim is to have "Something 1" on the screen if my_dynamic_table is not empty.
library(shiny)
library(DT)
my_dynamic_table = data.frame(NA)
shinyApp(
ui = fluidPage(
actionButton("call","Call"),
actionButton("save","Save"),
verbatimTextOutput('text'),
DT::dataTableOutput('table_out')
),
server = function(input, output, session) {
observeEvent (input$call ,{
my_dynamic_table <- mtcars
output$table_out <- DT::renderDataTable(
my_dynamic_table
) # renderDataTable : table_out
})
observeEvent (input$save,{
output$text <- renderText({
if(nrow(my_dynamic_table)>1) {
"Something 1"
}else {
"Something 2"
}
}) #renderText
}) #observeEvent
} #server
) #shinyApp
One option to achieve that would be to use a reactiveVal or reactiveValues:
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
actionButton("call", "Call"),
actionButton("save", "Save"),
verbatimTextOutput("text"),
DT::dataTableOutput("table_out")
),
server = function(input, output, session) {
my_dynamic_table <- reactiveVal(data.frame())
observeEvent(input$call, {
my_dynamic_table(mtcars)
output$table_out <- DT::renderDataTable(
my_dynamic_table()
)
})
observeEvent(input$save, {
output$text <- renderText({
if (nrow(my_dynamic_table()) > 0) {
"Something 1"
} else {
"Something 2"
}
}) # renderText
}) # observeEvent
} # server
) # shinyApp
While I do think that using reactiveValues is a good solution to this problem, I'd say its never a good idea to use an output inside an observeEvent(). I would rearrange the code as below. In the observeEvent we observe the action buttons, and when clicked, update the reactiveValues. Those are again intermediates for your output.
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
actionButton("call","Call"),
actionButton("save","Save"),
verbatimTextOutput('text'),
DT::dataTableOutput('table_out')
),
server = function(input, output, session) {
my <- reactiveValues(dynamic_table = data.frame(NA),
text = NA)
observeEvent(input$call, {
my$dynamic_table <- mtcars
})
observeEvent(input$save, {
if (nrow(my$dynamic_table) > 1) {
my$text <- "Something 1"
} else {
my$text <-"Something 2"
}
})
output$text <- renderText({
req(input$save)
my$text
})
output$table_out <- DT::renderDataTable({
req(input$call)
my$dynamic_table
})
} #server
) #shinyApp
I'm making an app with modules in which the user can create as many UI as he wants. Each UI contain one table and I would like to give the possibility to the user to see the code for each of this table separately, not in a unique chunk. Therefore, I included the part of the code with expandChain in my module (module_server).
However, expandChain won't detect the reactive stuff I'm calling because the name of this stuff changes since it is created in a module. Take a look at the app below:
library(dplyr)
library(shiny)
library(shinymeta)
library(WDI)
module_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
actionButton(ns("show_table"), "Show table"),
actionButton(ns("show_code"), "Show code"),
tableOutput(ns("table"))
)
)
}
module_server <- function(input, output, session){
data <- metaReactive2({
req(input$show_table)
isolate(metaExpr({
mtcars
}))
})
output$table <- renderTable({
data()
})
observeEvent(input$show_code, {
showModal(modalDialog(
renderPrint({
expandChain(data())
})
))
})
}
ui <- fluidPage(
actionButton("launch", "Launch")
)
server <- function(input, output, session) {
count <- reactiveValues(value = 0)
observeEvent(input$launch, {
count$value <- count$value + 1
insertUI(selector = "#launch",
where = "afterEnd",
ui = module_ui(count$value))
callModule(module_server, count$value)
})
}
shinyApp(ui, server)
When I try to show the code for the table generated, I have the error:
Warning: Error in : <text>:2:2: unexpected input
1: `1_data` <- mtcars
2: 1_
^
133: <Anonymous>
Since the module renames data() by adding a number, data() is not recognized by expandChain. I tried with:
expandChain(paste0(id, "_data()"))
without success (since expandChain does not support character).
Does anybody know how to do it?
Also asked on RStudio Community
Here's the solution given on RStudio Community (see the link for some additional details):
library(dplyr)
library(shiny)
library(shinymeta)
library(WDI)
module_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
actionButton(ns("show_table"), "Show table"),
actionButton(ns("show_code"), "Show code"),
tableOutput(ns("table"))
)
)
}
module_server <- function(input, output, session){
data <- metaReactive2({
req(input$show_table)
isolate(metaExpr({
mtcars
}))
})
output$table <- renderTable({
data()
})
observeEvent(input$show_code, {
showModal(modalDialog(
renderPrint({
expandChain(data())
})
))
})
}
ui <- fluidPage(
actionButton("launch", "Launch")
)
server <- function(input, output, session) {
count <- reactiveValues(value = 0)
observeEvent(input$launch, {
count$value <- count$value + 1
insertUI(selector = "#launch",
where = "afterEnd",
ui = module_ui(paste0("x", count$value)))
callModule(module_server, paste0("x", count$value))
})
}
shinyApp(ui, server)
I'm trying to write a shiny app where I produce a list and add and delete some elements.
I have a module to add somethind to my list.
find_inputUI <- function(id){
ns <- NS(id)
tagList(
sliderInput(ns("first"), "Choose a number:", min=0, max=100, 30),
radioButtons(ns("second"), "Choose a colour:", choices=c("red", "green", "black")),
actionButton(ns("press"), "Add to queue"))
}
find_input <- function(input, output, session){
queue <- list()
observeEvent(input$press, {
queue_append <- list(input$first, input$second)
queue <<- append(queue, queue_append )})
queue_ret <- eventReactive(input$press,{return(list(queue=queue, add=input$press))})
}
Then I call it twice and connect the 2 different inputs. Now I want to choose the elements to delete but this doesn't work.
source('/cloud/project/Queue/find_input.R')
library(shiny)
ui <- fluidPage(
tagList(tabsetPanel(
tabPanel("INPUT 1",
find_inputUI("input1"),
verbatimTextOutput("test")),
tabPanel("INPUT 2",
find_inputUI("input2")
)
),
actionButton("combine", "Show combined input"),
verbatimTextOutput("combination"),
uiOutput("del")
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
input_manual1 <- callModule(find_input,"input1")
input_manual2 <- callModule(find_input, "input2")
output$test <- renderPrint({input_manual1()$queue})
appended <- eventReactive(input$combine, {
return(append(input_manual1()$queue, input_manual2()$queue))
})
output$combination <- renderPrint({appended()})
output$del <- renderUI({
input$combine
tagList(checkboxGroupInput("delete", "Choose do delete", seq(1:length(appended()))),
actionButton("dodelete", "Delete selected"))
})
observeEvent(input$dodelete,{
appended <<- appended()[-input$delete]
})
}
# Run the application
shinyApp(ui = ui, server = server)
Maybe anybody can tell me what's wrong so far?
Thanks in advance!
Below is an app which seems to work but I'm not sure to understand what your app is intended to do.
In general, prefer reactive values (reactiveVal) instaed of using the non-local assignment <<-.
The code appended <<- appended()[-input$delete] is not correct. It does not replace the output of appended() by its originalvalue minus the input$delete index.
library(shiny)
find_inputUI <- function(id){
ns <- NS(id)
tagList(
sliderInput(ns("first"), "Choose a number:", min=0, max=100, 30),
radioButtons(ns("second"), "Choose a colour:", choices=c("red", "green", "black")),
actionButton(ns("press"), "Add to queue"))
}
find_input <- function(input, output, session){
queue <- reactiveVal(list())
observeEvent(input$press, {
queue_append <- list(input$first, input$second)
queue(append(queue(), queue_append))
})
queue_ret <- eventReactive(input$press, {
list(queue=queue(), add=input$press)
})
}
ui <- fluidPage(
tagList(tabsetPanel(
tabPanel("INPUT 1",
find_inputUI("input1"),
verbatimTextOutput("test")),
tabPanel("INPUT 2",
find_inputUI("input2")
)
),
actionButton("combine", "Show combined input"),
verbatimTextOutput("combination"),
uiOutput("del")
)
)
server <- function(input, output, session) {
input_manual1 <- callModule(find_input,"input1")
input_manual2 <- callModule(find_input, "input2")
output$test <- renderPrint({input_manual1()$queue})
appended <- reactiveVal(list())
observeEvent(input$combine, {
appended(append(input_manual1()$queue, input_manual2()$queue))
})
output$combination <- renderPrint({appended()})
output$del <- renderUI({
input$combine
tagList(checkboxGroupInput("delete", "Choose do delete", seq_along(appended())),
actionButton("dodelete", "Delete selected"))
})
observeEvent(input$dodelete,{
appended(appended()[-as.integer(input$delete)])
})
}
# Run the application
shinyApp(ui = ui, server = server)
The example app below has two shiny modules. The first module displays a table with randomly generated values as well as an action button, which, when clicked, generates new values. The second module displays the data set generated in the first one.
How do I make the second table change with the first one?
Thank you.
app.R
library(shiny)
source("modules.R")
ui <- fluidPage(
fluidRow(
column(6, table1_moduleUI("table1")),
column(6, table2_moduleUI("table2"))
)
)
server <- function(input, output, session) {
table1 <- callModule(table1_module, "table1")
callModule(table2_module, "table2", table_data = table1$values)
}
shinyApp(ui, server)
modules.R
# Module for table 1
table1_moduleUI <- function(id){
ns <- NS(id)
tagList(
tableOutput(ns("table")),
actionButton(ns("submit"), label = "Change values")
)
}
table1_module <- function(input, output, session) {
table <- reactiveValues()
observeEvent(input$submit, {
table$values <- replicate(3, rnorm(10))
}, ignoreNULL = FALSE)
output$table <- renderTable({
table$values
})
return(table)
}
# Module for table 2
table2_moduleUI <- function(id){
ns <- NS(id)
tableOutput(ns("table"))
}
table2_module <- function(input, output, session, table_data){
output$table <- renderTable({
table_data
})
}
The second module seems to be missing in the question but the logic seems to be straight forward. The issue here is that you are passing the value of the reactive expression to the second module when you use,
callModule(table2_module, "table2", table_data = table1$values)
instead, you want to pass the reactive value, which tells R to invalidate the outputs when the reactive values changes,
callModule(table2_module, "table2", table_data = table1)
here is the complete app,
library(shiny)
# Module for table 1
table1_moduleUI <- function(id){
ns <- NS(id)
tagList(
tableOutput(ns("table")),
actionButton(ns("submit"), label = "Change values")
)
}
table2_moduleUI <- function(id){
ns <- NS(id)
tableOutput(ns("table"))
}
table1_module <- function(input, output, session) {
table <- reactiveValues()
observeEvent(input$submit, {
table$values <- replicate(3, rnorm(10))
}, ignoreNULL = FALSE)
output$table <- renderTable({
table$values
})
return(table)
}
table2_module <- function(input, output, session,table_data) {
output$table <- renderTable({
table_data
})
}
ui <- fluidPage(
fluidRow(
column(6, table1_moduleUI("table1")),
column(6, table2_moduleUI("table2"))
)
)
server <- function(input, output, session) {
table1 <- callModule(table1_module, "table1")
callModule(table2_module, "table2", table_data = table1$values)
}
shinyApp(ui, server)
As a caveat, if you are wanting to display a dataframe, using reactive values seems to be overkill. When we want to return a reactive expression, intead of initializing a reactive variable and setting it in an observer we can simply use reactive() or eventReactive(), this is what they are there for! So let's use it. Reactive values have their space, and in my experience are used relatively sparingly.
library(shiny)
# Module for table 1
table1_moduleUI <- function(id){
ns <- NS(id)
tagList(
tableOutput(ns("table")),
actionButton(ns("submit"), label = "Change values")
)
}
table2_moduleUI <- function(id){
ns <- NS(id)
tableOutput(ns("table"))
}
table1_module <- function(input, output, session) {
table = eventReactive(input$submit, {
replicate(3, rnorm(10))
}, ignoreNULL = FALSE)
output$table <- renderTable({
table()
})
return(table)
}
table2_module <- function(input, output, session,table_data) {
output$table <- renderTable({
table_data()
})
}
ui <- fluidPage(
fluidRow(
column(6, table1_moduleUI("table1")),
column(6, table2_moduleUI("table2"))
)
)
server <- function(input, output, session) {
table1 <- callModule(table1_module, "table1")
callModule(table2_module, "table2", table_data = table1)
}
shinyApp(ui, server)
I have an app where the user needs to assign randomly generated elements (in this case, letters) to groups, but gets to decide how many groups to use. Because the selectInput where memberships are defined is generated dynamically in response to a number specified by the user, naming the menu is done automatically (e.g., usergroup1, usergroup2, etc.). I am having trouble accessing the input values and returning them from the module to use later because I won't know in advance how many inputs there will be, and hence how many usergroups to call. Here is an example app:
UI module:
library(shiny)
library(stringr)
mod1UI <- function(id) {
ns <- NS(id)
tagList(
numericInput(ns("n"), "N",value = NULL),
actionButton(ns("draw"),"Generate Letters"),
hr(),
numericInput(ns("groups"), "Enter number of groups (1-3)", value=NULL),
uiOutput(ns("groupings"))
)
}
What I tried to do here is make a list of usergroup names and return those, but the values aren't attached, and nothing comes through.
Server module:
mod1 <- function(input, output, session, data) {
ns <- session$ns
x <- reactiveValues(data=NULL)
observeEvent(input$draw, {
req(input$n)
x$data <- sample(letters,input$n)
})
output$groupings <- renderUI({
req(input$groups)
ltrs <- data()
lapply(1:input$groups, function(i) {
selectizeInput(paste0(session$ns("usergroup"),i),
paste0("Select letters for Group ", i),
choices=ltrs,
options = list(placeholder = "Select letters for this group",
onInitialize = I('function() { this.setValue(""); }')), multiple=T)
})
})
gps <- reactiveValues(gps=NULL)
reactive({
gps$gps <- lapply(1:input$groups, function(i) { paste0(session$ns("usergroup"),i) })
})
return(list(dat = reactive({x$data}),
groups = reactive({gps$gps})
))
}
UI:
ui <- navbarPage("Fancy Title",id = "tabs",
tabPanel("Panel1",
sidebarPanel(
mod1UI("input1")
),
mainPanel(verbatimTextOutput("lettersy")
)
)
)
Server:
server <- function(input, output, session) {
y <- callModule(mod1, "input1", data=y$dat)
output$lettersy <- renderText({
as.character(c(y$dat(), y$groups(), "end"))
})
}
shinyApp(ui, server)
Any help is greatly appreciated!
This solution mimics a couple others found on SO, namely this one.
The key is to create a reactiveValues object and then assign the values using [[i]]. In my case it helped to use a submit button to trigger that.
Complete, working code is as follows:
UI module:
library(shiny)
mod1UI <- function(id) {
ns <- NS(id)
tagList(
numericInput(ns("n"), "N",value = NULL),
actionButton(ns("draw"),"Generate Letters"),
hr(),
numericInput(ns("groups"), "Enter number of groups (1-3)", value=NULL),
uiOutput(ns("groupings")),
actionButton(ns("submit"), "Submit Groupings")
)
}
Server Module:
mod1 <- function(input, output, session, data) {
ns <- session$ns
x <- reactiveValues(data=NULL)
observeEvent(input$draw, {
req(input$n)
x$data <- sample(letters,input$n)
})
output$groupings <- renderUI({
req(input$groups)
ltrs <- data()
lapply(1:input$groups, function(i) {
selectizeInput(paste0(session$ns("usergroup"),i),
paste0("Select letters for Group ", i),
choices = ltrs,
options = list(placeholder = "Select letters for this group",
onInitialize = I('function() { this.setValue(""); }')), multiple=T)
})
})
gps <- reactiveValues(x=NULL)
observeEvent(input$submit, {
lapply(1:input$groups, function(i) {
gps$x[[i]] <- input[[paste0("usergroup", i)]]
})
})
test <- session$ns("test")
return(list(dat = reactive({x$data}),
groups = reactive({gps$x})
))
}
UI:
ui <- navbarPage("Fancy Title",id = "tabs",
tabPanel("Panel1",
sidebarPanel(
mod1UI("input1")
),
mainPanel(verbatimTextOutput("lettersy")
)
)
)
Server:
server <- function(input, output, session) {
y <- callModule(mod1, "input1", data=y$dat)
output$lettersy <- renderText({
as.character(c(y$groups()))
})
}
shinyApp(ui, server)