Re-use reactive elements defined in modules - r

I'm making an app in which the user can create as many tables as he/she wants and display the code necessary to remake each individual table using shinymeta. I can generate the code for each of these tables but I have a problem when I want to create a complete modal that shows every code for each table.
To be clearer, here's a reproducible example:
library(shiny)
library(dplyr)
library(shinymeta)
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
}))
})
data2 <- metaReactive({
..(data()) %>%
select(mpg)
})
output$table <- renderTable({
data2()
})
observeEvent(input$show_code, {
showModal(modalDialog(
renderPrint({
expandChain(data(), data2())
})
))
})
return(data())
}
ui <- fluidPage(
actionButton("launch", "Launch"),
actionButton("show_full_code", "Show the full code (at least 2 'launch' before)")
)
server <- function(input, output, session) {
count <- reactiveValues(value = 0)
observeEvent(input$launch, {
count$value <- count$value + 1
insertUI(selector = "#show_full_code",
where = "afterEnd",
ui = module_ui(paste0("x", count$value)))
callModule(module_server, paste0("x", count$value))
})
#### "Merge" the single code modals in one big
observeEvent(input$show_full_code, {
showModal(modalDialog(
renderPrint({
expandChain(x1_data)
})
))
})
}
shinyApp(ui, server)
When you click on "Launch", two buttons are generated and you can display a table ("Show table") and the code to remake this table ("Show code"). You can click on "Launch" indefinitely and the table will be named x1_data, x2_data, etc.
However, when I try to generate the code that unites every individual code (by clicking on "Show the full code"), x1_data is not found. Using x1_data() does not work either. I'm not a fan of asking two questions in one post but I will do this now:
How can I access the reactive elements created inside modules?
How can I "merge" every individual code in a big one?
Also asked on RStudio Community
Edit: following a comment, I add a second reactive expression in my example, so that I can't use return on both of them.

Ok, I came up with an answer that has the module return the expandChain() results rather than trying to render them again in the server:
library(shiny)
library(dplyr)
library(shinymeta)
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
}))
})
data2 <- metaReactive({
..(data()) %>%
select(mpg)
})
output$table <- renderTable({
data2()
})
observeEvent(input$show_code, {
showModal(modalDialog(
renderPrint({
expandChain(data(), data2())
})
))
})
########################################
### create list of reactive objects ####
########################################
return(list(
expandChain(data(), data2())
)
)
}
ui <- fluidPage(
actionButton("launch", "Launch"),
actionButton("show_full_code", "Show the full code (at least 2 'launch' before)")
)
server <- function(input, output, session) {
count <- reactiveValues(value = 0)
observeEvent(input$launch, {
count$value <- count$value + 1
insertUI(selector = "#show_full_code",
where = "afterEnd",
ui = module_ui(paste0("x", count$value)))
callModule(module_server, paste0("x", count$value))
})
#### "Merge" the single code modals in one big list object
my_data <- reactive({
req(count$value)
my_set <- 1:count$value
### lapply through the different name spaces so all are captured ###
final <- lapply(my_set, function(x){
temp <- callModule(module_server, paste0("x", x))
return(temp)
})
return(final)
})
#### "Merge" the single code modals in one big
observeEvent(input$show_full_code, {
showModal(modalDialog(
renderPrint({
temp <- sapply(unlist(my_data()), function(x){
print(x)
})
})
))
})
}
shinyApp(ui, server)

Related

Shiny namespace issue with nested callModules

I’m looking for some help with a simple Shiny app with a modularised design please. I think the problem is a name space issue so the example below is set out as a simplified version of my actual project. My feeling is that I have not set output$uis to the correct name space but I am lost on how to map to it.
The app generates 3 instances of select_formUI and should be namespace related to 3 instances of the server returned values from the callModules of select_form. The values from select_form are passed out in a tibble. The inner module binds all 3 tibbles into one reactive tibble all_gen_forms_rctv.
The process works fine until I uncomment the input_slt_type_db column in pass_back_test, which returns the input$slt_type_db. I’m looking for some help please to include this column in the output and see all_gen_forms_rctv change on user selections via output$outpt_test.
library(shiny)
library(shinyjs)
library(glue)
library(tibble)
select_formUI <- function(id){
ns <- NS(id)
tagList(selectInput(ns('slt_type_db'), 'select letter', choices = letters[1:5]))
}
select_form <- function(input, output, session){
#pass_back_test <- reactive({
tibble(
placehold = "FILL VALUE"
# , input_slt_type_db = input$slt_type_db
)
})
return(list(pass_back_test = reactive({pass_back_test()})))
}
inner_moduleUI <- function(id){
ns <- NS(id)
tagList(uiOutput(ns("outpt_forms_ui")))
}
inner_module <- function(input, output, session){
rctval_ui <- reactiveValues(all_ui=NULL)
gen_forms <- reactiveValues()
all_gen_forms_rctv <- reactive({
dplyr::bind_rows(lapply(reactiveValuesToList(gen_forms), function(current_module_output) {
current_module_output$pass_back_test()
}))
})
observeEvent(input$btn_start ,{
for(i in 1:3){
x_id = glue("mod_{i}")
rctval_ui$all_ui[[x_id]] <- select_formUI(x_id)
gen_forms[[x_id]] <- callModule(select_form, x_id)
}
})
output$outpt_forms_ui <- renderUI({
ns <- session$ns
tagList(
actionButton(ns('btn_start'), label = 'start'),
verbatimTextOutput(ns('outpt_test')),
hr(),
uiOutput(ns('uis'))
)
})
output$uis <- renderUI({
ns <- session$ns
tags$div(id = environment(ns)[['namespace']],
tagList(rctval_ui$all_ui))
})
output$outpt_test <- renderPrint({all_gen_forms_rctv()})
}
ui <- fluidPage(
useShinyjs(),
uiOutput('main_ui')
)
server <- function(input, output, session) {
output$main_ui <- renderUI({inner_moduleUI('inner_ns')})
callModule(inner_module, 'inner_ns')
}
shinyApp(ui = ui, server = server)
the problem is that the UI function of the select_form modul doesn't know that it is being called within another module. So you need to tell it by wrapping the the id in session$ns. The callModule function can handle this by itself so here there is no need to change anything. The inner_module function would the look like this
inner_module <- function(input, output, session) {
rctval_ui <- reactiveValues(all_ui=NULL)
gen_forms <- reactiveValues()
all_gen_forms_rctv <- reactive({
browser()
dplyr::bind_rows(lapply(reactiveValuesToList(gen_forms), function(current_module_output) {
current_module_output$pass_back_test()
}))
})
observeEvent(input$btn_start ,{
for(i in 1:3){
x_id = glue("mod_{i}")
rctval_ui$all_ui[[x_id]] <- select_formUI(session$ns(x_id))
gen_forms[[x_id]] <- callModule(select_form, x_id)
}
})
output$outpt_forms_ui <- renderUI({
ns <- session$ns
tagList(
actionButton(ns('btn_start'), label = 'start'),
verbatimTextOutput(ns('outpt_test')),
hr(),
uiOutput(ns('uis'))
)
})
output$uis <- renderUI({
ns <- session$ns
tags$div(id = environment(ns)[['namespace']],
tagList(rctval_ui$all_ui))
})
output$outpt_test <- renderPrint({all_gen_forms_rctv()})
}

Looping Shiny callModule only exports last value

I am trying to build an app which; 1) calculates the number of boxes, based on a data.frame, 2) For each box, creates a UI and a corresponding module that will trigger events when the action buttons are clicked, using a subset of that data.frame.
If I am not being explicit enough; the app has n UI's and in each UI, x buttons. I want to loop callModule to create n server functions so when I click on action button in any given UI, I trigger an event specific to that UI.
The problem I am having is that the callModule function apparently does not duplicate itself in a for loop. Instead, I always get only the last id and dataframe (as if the callModule overwrites itself).
I hope I was explicit enough. Here is a MWE:
server.R
library(shinydashboardPlus)
library(shiny)
library(shinydashboard)
source('modules.R')
shinyServer(function(input, output, session) {
# dataframe filtered / updated
dtst <- reactive({
iris[1:input$filter_d, ]
})
# number of items rendered
output$ui <- renderUI({
r <- tagList()
for(k in 1:input$n){
r[[k]] <- u_SimpleTaskView(id = k, d = dtst()[k, ]) # <- grab a subset or column of df
}
r
})
for(y in 1:isolate({input$n})){
callModule(m_UpdateTask, id = y, d = dtst()[, y])
}
})
ui.R
dheader <- dashboardHeaderPlus(title = "s")
dsidebar <- dashboardSidebar(
sidebarMenu(
menuItem("tst", tabName = "tst", icon = icon("bolt"))
)
)
dbody <- dashboardBody(
tabItems(
tabItem(tabName = "tst",
numericInput("n", "number of ui and module pairs", value = 10),
numericInput("filter_d", "RANDOM FILTER", value = 100),
uiOutput("ui")
)
) )
dashboardPagePlus(
title = "s",
header = dheader,
sidebar = dsidebar,
body = dbody
)
modules.R
u_SimpleTaskView <- function(id, d){
ns <- NS(id)
if(length(d) < 5){
# nothing
}else{
renderUI({
tagList(
br(),
HTML(paste0("<strong>Rows: </strong>", "xxxx")),
numericInput("divider", label = "number of rows", value = 2),
br(),
actionButton("go", "go")
)
})
}
}
m_UpdateTask <- function(input, output, session, d){
observeEvent(input$go, {
showModal(
modalDialog(
HTML(paste0("unique: ", length(unique(d))/input$divider ) )
)
)
})
}
Besides not being really minimal (no need for libraries shinydashboardPlus or shinydashboard) there are a couple of issues with your code.
renderUI is a server function not a UI function
If you create controls in the module UI you have to use the namespace function, otherwise you cannot use them in your module server function.
As it is a bit too complicated for me to debug your code directly, let me give you an example from which you can see how to use modules in the way you wanted:
library(shiny)
library(glue)
mod_ui <- function(id, base_df) { ## 3
ns <- NS(id) ## 1
tagList(
helpText(glue("The input parameter 'base_df' has {NROW(base_df)} rows.")),
numericInput(ns("n"), "n:", 2),
textOutput(ns("out"))
)
}
mod <- function(input, output, session) {
get_nr <- reactive(input$n) ## 2
output$out <- renderText(glue("Number selected: {get_nr()}"))
return(list(get_nr = get_nr)) ## 4
}
ui <- fluidPage(
numericInput("n", "number of uis:", 2),
uiOutput("uis"),
textOutput("sum")
)
server <- function(input, output, session) {
handlers <- list()
output$uis <- renderUI({
ret <- lapply(seq.int(input$n),
function(i) mod_ui(glue("mod_{i}"),
data.frame(x = seq.int(i)))) ## 5
tagList(ret)
})
observe(
handlers <<- lapply(seq.int(input$n),
function(i) callModule(mod, glue("mod_{i}"))) ## 6
)
output$sum <- renderText({ ## 7
req(length(handlers) > 0)
m_sum <- sum(sapply(handlers, function(h) h$get_nr()))
glue("Sum of all n: {m_sum}")
})
}
shinyApp(ui, server)
Explanation
In mod_ui we define all the elements one module should have. note the use of ns() for the controls' ids to make use of the namespacing.
In mod (the module server function) we can access controls as we would in the main server function ( i.e. directly liek in input$n.
We can pass arguments to any of the module's functions (like base_df).
If we want to use some of the reactives in the main app, we shoudl return them from the modules server function.
In our main app we use a loop to create the desired number of modules.
We use an observer to store the handlers from the modules in a list
We can access the modules reactives via the handler which we defined earlier.
Update 2021
shiny 1.5.0 introduced an easier interface for modules. The code below uses this "new" interface:
library(shiny)
library(glue)
mod_ui <- function(id, base_df) {
ns <- NS(id)
tagList(
helpText(glue("The input parameter 'base_df' has {NROW(base_df)} rows.")),
numericInput(ns("n"), "n:", 2),
textOutput(ns("out"))
)
}
mod <- function(id) {
moduleServer(id,
function(input, output, session) {
get_nr <- reactive(input$n)
output$out <- renderText(glue("Number selected: {get_nr()}"))
return(list(get_nr = get_nr))
}
)
}
ui <- fluidPage(
numericInput("n", "number of uis:", 2),
uiOutput("uis"),
textOutput("sum")
)
server <- function(input, output, session) {
handlers <- list()
output$uis <- renderUI({
ret <- lapply(seq.int(input$n),
function(i) mod_ui(glue("mod_{i}"),
data.frame(x = seq.int(i))))
tagList(ret)
})
observe({
handlers <<- lapply(seq.int(input$n),
function(i) mod(glue("mod_{i}")))
})
output$sum <- renderText({
req(length(handlers) > 0)
m_sum <- sum(sapply(handlers, function(h) {
res <- h$get_nr()
if(is.null(res)) {
0
} else {
res
}
}))
glue("Sum of all n: {m_sum}")
})
}
shinyApp(ui, server)

R, Shiny Setting DataTable ID

I have created a large number of data tables using mapply, however, I need to access the data tables in a following step. R assigns random IDs to these tables if the user does not specify the IDs. Here is an example of what I would like to do:
library(shiny)
ui <- fluidPage(
h2("Last clicked:"),
verbatimTextOutput("last_clicked"),
actionButton("reset", "Reset clicked value"),
h2("Datatable:"),
DT::dataTableOutput("dt")
)
server <- function(input, output) {
# the last clicke value
output$last_clicked <- renderPrint({
str(last())
})
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2), elementId = "DT_Test")
})
observeEvent(input$dt_cell_clicked, {
validate(need(length(input$dt_cell_clicked) > 0, ''))
print("You clicked something!")
})
myProxy = DT::dataTableProxy('dt')
last = reactiveVal(NULL)
observe({
last(input$dt_cell_clicked)
})
observeEvent(input$reset, {
DT::selectRows(myProxy, NULL)
last(NULL)
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2))
})
})
}
shinyApp(ui, server)
If I look at the html, the elementID did not change to what I wanted, in fact, R gives the warning:
Warning in origRenderFunc() :
Ignoring explicitly provided widget ID "DT_Test"; Shiny doesn't use them
Even after the call, still not sure what you are trying to do.
But if you have a list of datatables and you want to access them, it works rather well like this:
library(shiny)
library(purrr)
ui <- fluidPage(
h2("Last clicked:"),
verbatimTextOutput("last_clicked"),
h2("elementId values"),
verbatimTextOutput("elementId_values"),
actionButton("reset", "Reset clicked value"),
h2("Datatable:"),
DT::dataTableOutput("dt")
)
server <- function(input, output) {
# the last clicke value
output$last_clicked <- renderPrint({
str(last())
})
table <- DT::datatable(head(mtcars, 2), elementId = "DT_Test")
table2 <- DT::datatable(tail(mtcars, 1), elementId = "DT_Test2")
list_of_data_tables <- list(table, table2)
element_ids <- purrr::map(list_of_data_tables, "elementId")
output$elementId_values <- renderPrint({
element_ids
})
output$dt <- DT::renderDataTable({
list_of_data_tables[[which(element_ids == "DT_Test2")]]
})
observeEvent(input$dt_cell_clicked, {
validate(need(length(input$dt_cell_clicked) > 0, ''))
print("You clicked something!")
})
myProxy = DT::dataTableProxy('dt')
last = reactiveVal(NULL)
observe({
last(input$dt_cell_clicked)
})
observeEvent(input$reset, {
DT::selectRows(myProxy, NULL)
last(NULL)
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2))
})
})
}
shinyApp(ui, server)

reactive programming multiple action buttons same value rendering issue

I have 4 action buttons...but want same return value name. Since it is used in other elements. I initialize the reactive element as
myReactiveDF <- reactiveValues(data=NULL)
myReactiveDF <- eventReactive(input$action1, {
call functions
return(dataframe)
})
myReactiveDF <- eventReactive(input$action2, {
call functions
return(dataframe)
})
.....
However only the last button 4 works. The first three do not.
All the other elements use the same reactive element (dataframe) to get populated.
I tried observeEvent but it doesn't return values.
The following code should address your requirement as I understand them:
library(shiny)
ui <- fluidPage(
fluidRow(column(2, selectInput('action1', label = "Action1:", choices = c('a','b') )),
column(4, selectInput('action2', label = "Action2:", choices = c('A','B') ))),
fluidRow( verbatimTextOutput("outputs"))
)
server = function(input, output, session){
v <- reactiveValues(data = NULL)
observeEvent(input$action1, {
v$data <- input$action1
})
observeEvent(input$action2, {
v$data <- input$action2
})
output$outputs <- renderText({
if (is.null(v$data)) return()
v$data
})
}
shinyApp(ui = ui, server = server)
If what you need is different, please let me know so that I can amend the answer.

Using results/output from one shiny module to updateSelectInput within another

In figuring out how to use the new shiny modules, I would like to emulate the following app. When the rows of the datatable are clicked and unclicked, it updates the entries in the selectInput box, using updateSelectInput.
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput('car_input', 'Select car:', df$model, multiple = TRUE)
),
mainPanel(
DT::dataTableOutput('table')
)
)
)
server <- function(input, output, session, ...) {
output$table <- DT::renderDataTable(df)
car_rows_selected <- reactive(car_names[input$table_rows_selected, ])
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
shinyApp(ui = ui, server = server)
I have got most of the way there, but am having difficulty with updating the input box. I wonder if it has something to do with the way the namespaces work, and perhaps requires a nested call to the DFTable module within the Car module, but I'm not sure. I am able to add a textOutput element that prints the expected information from the selected table rows. My code for a single file app is below:
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## select module ---------------------------------------------------------------
CarInput <- function(id){
ns <- NS(id)
selectInput(ns('car_input'), 'Select car:', df$model, multiple = TRUE)
}
Car <- function(input, output, session, ...) {
# I was thinking perhaps I needed to call the DFTable module as a nested module within this Car module
car_rows_selected <- callModule(DFTable, 'id_inner')
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
## datatable module ------------------------------------------------------------
DFTableOutput <- function(id){
ns <- NS(id)
DT::dataTableOutput(ns('table'))
}
DFTable <- function(input, output, session, ...){
output$table <- DT::renderDataTable(df)
return(reactive(car_names[input$table_rows_selected, ]))
}
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
CarInput('id_car'),
textOutput('selected') # NB. this outputs expected values
),
mainPanel(
DFTableOutput('id_table')
)
)
)
server <- function(input, output, session, ...) {
callModule(Car, 'id_car')
callModule(DFTable, 'id_table')
output$selected <- callModule(DFTable, 'id_table') # NB this works as expected (see textOutput in ui section above)
car_rows_selected <- callModule(DFTable, 'id_table')
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
shinyApp(ui = ui, server = server)
Any help would be greatly appreciated
OK, a little more trial and error got me to the right answer - the car_rows_selected item needed to be given the double arrow <<- operator in the app server function in order for it to be useable in the Car module: look for the car_rows_selected <<- callModule(DFTable, 'id_table') in the server function
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## select module ---------------------------------------------------------------
CarInput <- function(id){
ns <- NS(id)
selectInput(ns('car_input'), 'Select car:', df$model, multiple = TRUE)
}
Car <- function(input, output, session, ...) {
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
## datatable module ------------------------------------------------------------
DFTableOutput <- function(id){
ns <- NS(id)
DT::dataTableOutput(ns('table'))
}
DFTable <- function(input, output, session, ...){
output$table <- DT::renderDataTable(df)
reactive(car_names[input$table_rows_selected, ])
}
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
CarInput('id_car')
),
mainPanel(
DFTableOutput('id_table')
)
)
)
server <- function(input, output, session, ...) {
callModule(Car, 'id_car')
car_rows_selected <<- callModule(DFTable, 'id_table')
}
shinyApp(ui = ui, server = server)
I'm still getting my head around the way module namespaces work - perhaps this isn't the most "correct" approach but at least it works - happy to accept a more appropriate answer if someone posts one later

Resources