Make a Shiny module reactive when creating the module via a function - r

Question

I'm trying to generalise Shiny modules so different functions can be passed through, but the expected behaviour of reactivity is not working - could someone point me in the right direction? I have a reprex below that illustrates my problem.
I expect that the dynamic selection of view_id to change values in the renderShiny() function. It works on app load but changing selections do not flow through.
Is it something to do with the environment the module function is created within?
library(shiny)
create_shiny_module_funcs <- function(data_f,
model_f,
outputShiny,
renderShiny){
server_func <- function(input, output, session, view_id, ...){
gadata <- shiny::reactive({
# BUG: this view_id is not reactive but I want it to be
data_f(view_id(), ...)
})
model_output <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- renderShiny({
shiny::validate(shiny::need(model_output(),
message = "Waiting for model output"))
message("Rendering model output")
model_output()
}, ...)
return(model_output)
}
ui_func <- function(id, ...){
ns <- shiny::NS(id)
outputShiny(outputId = ns("ui_out"), ...)
}
list(
shiny_module = list(
server = server_func,
ui = ui_func
)
)
}
# create the shiny module
ff <- create_shiny_module_funcs(
data_f = function(view_id) mtcars[, view_id],
model_f = function(x) mean(x),
outputShiny = shiny::textOutput,
renderShiny = function(x) shiny::renderText(paste("Mean is: ", x))
)
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
ff$shiny_module$ui("demo1"),
br()
)
## server.R
server <- function(input, output, session){
view_id <- reactive({
req(input$select)
input$select
})
callModule(ff$shiny_module$server, "demo1", view_id = view_id)
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)

Answer 1

The problem was the renderShiny function needs to wrap another function that creates the actual output, so its actually two separate capabilities confused by me as one: renderShiny should take the output of another function that actually creates the thing to render. The below then works:
library(shiny)
module_factory <- function(data_f = function(x) mtcars[, x],
model_f = function(x) mean(x),
output_shiny = shiny::plotOutput,
render_shiny = shiny::renderPlot,
render_shiny_input = function(x) plot(x),
...){
ui <- function(id, ...){
ns <- NS(id)
output_shiny(ns("ui_out"), ...)
}
server <- function(input, output, session, view_id){
gadata <- shiny::reactive({
data_f(view_id(), ...)
})
model <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- render_shiny({
shiny::validate(shiny::need(model(),
message = "Waiting for model output"))
render_shiny_input(gadata())
})
return(model)
}
list(
module = list(
ui = ui,
server = server
)
)
}
made_module <- module_factory()
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
made_module$module$ui("factory1"),
br()
)
## server.R
server <- function(input, output, session){
callModule(made_module$module$server, "factory1", view_id = reactive(input$select))
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)

Answer 2

I think you want something like this.
library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(data.table)
ui <- pageWithSidebar(
headerPanel = headerPanel('data'),
sidebarPanel = sidebarPanel(fileInput(
'mtcars', h4('Uplaodmtcardata in csv format')
),
uiOutput('tabnamesui')),
mainPanel(uiOutput("tabsets"))
)
server <- function(input, output, session) {
mtcarsFile <- reactive({
input$mtcars
})
xxmtcars <-
reactive({
read.table(
file = mtcarsFile()$datapath,
sep = ',',
header = T,
stringsAsFactors = T
)
})
tabsnames <- reactive({
names(xxmtcars())
})
output$tabnamesui <- renderUI({
req(mtcarsFile())
selectInput(
'tabnamesui',
h5('Tab names'),
choices = as.list(tabsnames()),
multiple = T
# selected = SalesGlobalDataFilter1Val()
)
})
tabnamesinput <- reactive({
input$tabnamesui
})
output$tabsets <- renderUI({
req(mtcarsFile())
tabs <-
reactive({
lapply(tabnamesinput(), function(x)
tabPanel(title = basename(x)
,fluidRow(splitLayout(cellWidths = c("50%", "50%"),
plotOutput(paste0('plot1',x)),
plotOutput(paste0('plot2',x)
))),fluidRow(splitLayout(cellWidths =
c("50%", "50%"),
plotOutput(paste0('plot3',x)),
plotOutput(paste0('plot4',x)
))),
dataTableOutput(paste0('table',x))))
})
do.call(tabsetPanel, c(tabs()))
})
# Save your sub data here
subsetdata<-reactive({
list_of_subdata<-lapply(tabnamesinput(), function(x) {
as.data.table((select(xxmtcars(),x)))
})
names(list_of_subdata)<-tabnamesinput()
return(list_of_subdata)
})
observe(
lapply(tabnamesinput(), function(x) {
output[[paste0('table',x)]] <-
renderDataTable({
subsetdata()[[x]]
})}))
observe(
lapply(tabnamesinput(), function(x) {
for(i in paste0("plot",1:4)){
output[[paste0(i,x)]] <-
renderPlot({subsetdata()[[x]]%>%plot()#CODE REPEATED
})
}
})
)
}
runApp(list(ui = ui, server = server))
Data Source:
https://gist.githubusercontent.com/seankross/a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv