How to Instantiate a ShinyReForms in a Shiny Module - r

Its quite quick and easy to instantiate a ShinyReForms for a Shiny app by following the example at https://piotrbajger.github.io/shinyreforms/articles/tutorial.html. I cannot though see how to get it working in a Shiny module.
The app below is a smaller version of the example app, presented in a module, and with an extra output which shows the result of the namespaced checkbox.
The ‘submit’ button doesn’t return the expected output though. I’m opining that this is a name space issue, though I can’t see where to wrap an id with something like... ns(“myformid”).
Any suggestions please. Thanks
library(shiny)
library(shinyreforms)
modUI <- function(id) {
ns <- NS(id)
tagList(
uiOutput(ns('form_ui')),
)
}
modServer <- function(id) {
moduleServer(
id,
function(input, output, session) {
ns <- session$ns
myForm <- shinyreforms::ShinyForm$new(
"myForm",
submit = "Submit",
onSuccess = function(self, input, output) {
yourName <- self$getValue(input, "name_input")
output$result <- shiny::renderText({
paste0("Your name is ", yourName, "!")
})
},
onError = function(self, input, output) {
output$result <- shiny::renderText({
"Form is invalid!"
})
},
shinyreforms::validatedInput(
shiny::checkboxInput(ns("checkbox"), label = "I accept!"),
validators = c(
shinyreforms::ValidatorRequired()
)
)
)
myForm$server(input, output)
output$ot_checkox <- renderUI({
h4(input$checkbox, style = 'color: blue;')
})
output$form_ui <- renderUI({
tagList(
shiny::tags$h1("Example ShinyForm!"),
myForm$ui(), # <- ShinyForm will be included here!
uiOutput(ns('ot_checkox')),
shiny::tags$h4("Result:"),
shiny::textOutput(ns("result"))
)
})
}
)
}
ui <- shiny::bootstrapPage(
shinyreforms::shinyReformsPage(
shiny::fluidPage(
modUI('mod_id')
)
)
)
server <- function(input, output, session) {
modServer('mod_id')
}
shinyApp(ui, server)

Related

How to replace callModule() with moduleServer function in the example below? Goal to pass data.frame from module to parent server

How do I replace the callModule() in this example with the recommended use where the moduleServer is wrapped in another function as the syntax is easier to read than the callModule.
This is the advise on the help page:
Starting in Shiny 1.5.0, we recommend using moduleServer instead of
callModule(), because the syntax is a little easier to understand, and
modules created with moduleServer can be tested with testServer().
The goal is to pass the data.frame created in the module to the parent shiny server function is that it can be used there and in other modules. Any suggestions on how to improve the code below?
# Module UI
moduleUI <- function(id) {
ns <- NS(id)
fluidRow(
actionButton(ns("generate_data"), "Generate data"),
dataTableOutput(ns("data_table"))
)
}
# Module server
moduleServer <- function(input, output, session) {
data_reactive <- reactive({
if(input$generate_data == 0) return(NULL)
data.frame(x = rnorm(10), y = rnorm(10))
})
output$data_table <- renderDataTable({
data_reactive()
})
return(data_reactive)
}
# Parent UI
ui <- fluidPage(
moduleUI("data_module"),
tableOutput("data_table")
)
# Parent server
server <- function(input, output, session) {
data_module <- callModule(moduleServer, "data_module")
output$data_table <- renderTable({
data_module()
})
}
shinyApp(ui, server)
moduleServer is the name of a function in Shiny, do not use it as a personal function. Here is how to use it:
myModuleServer <- function(id) {
moduleServer(
id,
function(input, output, session) {
data_reactive <- reactive({
if(input$generate_data == 0) return(NULL)
data.frame(x = rnorm(10), y = rnorm(10))
})
output$data_table <- renderDataTable({
data_reactive()
})
return(data_reactive)
}
)
}
Then call myModuleServer("data_module") in the main server function.

R shiny modules, reactive expression returned from server is unknown

In my "master app" i want to handle the reactives that are returned by included shiny modules. My problem is that I don't find a way to "catch" the returned reactive.
There is an error message when i try to resolve the reactive: Warning: Error in returned_data: could not find function "returned_data"
Is there any way to do this?
require(shiny)
example_UI <- function(p_id) {
actionButton(NS(p_id,"mergelist"), "mergelist")
}
example_Server <- function(p_id, p_list) {
moduleServer(p_id, function(input, output, session) {
observeEvent(input$mergelist, {
return(reactive({
rbind(data.frame("ID" = c(3, 5), "NAME" = c("lorem", "ipsum")), p_list())
}))
})
})
}
example_App <- function() {
global_list <- reactiveVal({ data.frame(ID = integer(), NAME = character()) })
ui <- fluidPage(
example_UI(p_id = "example"),
verbatimTextOutput("rows")
)
server <- function(input, output, session) {
returned_data <- example_Server(p_id = "example", p_list = global_list)
output$rows <- renderText({
nrow(returned_data())
})
}
shinyApp(ui, server)
}
runApp(example_App())
Thanks to #Limey I found my mistake and was able to solve the problem.
moduleServer(p_id, function(input, output, session) {
retval <- reactiveVal()
observeEvent(input$mergelist, {
retval(...)
})
retval
})

How to return a reactive dataframe from within a shiny module that depends on a button click?

Aim: Return a reactive dataframe object from within the module named "modApplyAssumpServer"
Problem: I am getting an endless loop. Even if I wrap everything within the observeevent logic within isolate()
I have included another table in the app code below to indicate a simplified version of the logic that works outside of the module framework but that I can't seem to get to work within the module.
library(shiny)
library(dplyr)
df_agg_orig <- data.frame(proj_1 = c(2,3))
modGrowthInput <- function(id) {
ns <- NS(id)
tagList(
numericInput(ns("first"),label = "Assumption",value = 100),
)
}
modGrowthServer <- function(id, btnGrowth) {
moduleServer(id, function(input, output, session) {
list(
first = reactive({input$first})
)
})
}
modButtonUI <- function(id,lbl = "Recalculate"){
ns <- NS(id)
actionButton(inputId = ns("btn"),label = lbl)#,style = "pill",color = "primary",no_outline = T,size = "xs"
}
modButtonServer <- function(id){
moduleServer(id, function(input, output, session) {
reactive({input$btn})
})
}
modApplyAssumpServer <- function(id,btnGrowth, df_agg,case_vals){
moduleServer(id, function(input, output, session) {
stopifnot(is.reactive(btnGrowth))
stopifnot(is.reactive(df_agg))
mod_vals <- reactiveVal(df_agg())
observeEvent(btnGrowth(),{
isolate({mod_vals(df_agg() %>% mutate(proj_1 = proj_1*input$first))})
print("Looping problem...")
})
mod_vals()
})
}
#### Test App
GrowthInputApp <- function() {
ui <- fluidPage(
sidebarPanel(modGrowthInput("tst"),modButtonUI("tstGrowth")),
mainPanel(fluidRow( splitLayout( DT::DTOutput("no_module"),DT::DTOutput("module_tbl")))))
server <- function(input, output, session) {
btnGrowth <- modButtonServer("tstGrowth")
case_vals <- modGrowthServer("tst")
df_agg <- reactiveValues(df_wide = df_agg_orig)
#Outside of module test exhibiting expected/desired behavior (at least if the looping issue would let it do so :)
observeEvent(btnGrowth(),{
df_agg$df_wide$proj_1 <- round(df_agg$df_wide*case_vals$first(),2)
})
output$no_module <- DT::renderDT({DT::datatable(rownames = F,df_agg$df_wide,caption = "Not Updated Within Module")})
output$module_tbl <- DT::renderDT({DT::datatable(rownames = F,modApplyAssumpServer("tst",btnGrowth = btnGrowth,df_agg = reactive({df_agg_orig})),caption = "Table Returned From Module")}
)
}
shinyApp(ui, server)
}
runApp(GrowthInputApp())
Try this
library(shiny)
library(dplyr)
df_agg_orig <- data.frame(proj_1 = c(2,3))
modGrowthInput <- function(id) {
ns <- NS(id)
tagList(
numericInput(ns("first"),label = "Assumption",value = 10),
)
}
modGrowthServer <- function(id) {
moduleServer(id, function(input, output, session) {
list(
first = reactive({input$first})
)
})
}
modButtonUI <- function(id,lbl = "Recalculate"){
ns <- NS(id)
actionButton(inputId = ns("btn"),label = lbl)#,style = "pill",color = "primary",no_outline = T,size = "xs"
}
modButtonServer <- function(id){
moduleServer(id, function(input, output, session) {
reactive({input$btn})
})
}
modApplyAssumpServer <- function(id,btnGrowth, df_agg, val){
moduleServer(id, function(input, output, session) {
stopifnot(is.reactive(btnGrowth))
stopifnot(is.reactive(df_agg))
modvals <- eventReactive(btnGrowth(), {
print("Looping problem...")
#print(btnGrowth())
df_agg() %>% mutate(proj_1 = proj_1*val )
})
return(modvals())
})
}
#### Test App
GrowthInputApp <- function() {
ui <- fluidPage(
sidebarPanel(modGrowthInput("tst"),modButtonUI("tstGrowth")),
mainPanel(fluidRow( splitLayout( DT::DTOutput("no_module"),DT::DTOutput("module_tbl")))))
server <- function(input, output, session) {
btnGrowth <- modButtonServer("tstGrowth")
case_vals <- modGrowthServer("tst")
observe({ print(case_vals$first())})
df_agg <- reactiveValues(df_wide = df_agg_orig)
#Outside of module test exhibiting expected/desired behavior (at least if the looping issue would let it do so :)
observeEvent(btnGrowth(),{
df_agg$df_wide$proj_1 <- round(df_agg$df_wide*case_vals$first(),2)
})
mydf <- eventReactive(c(btnGrowth(),case_vals$first()), {
modApplyAssumpServer("tst", btnGrowth, reactive({df_agg$df_wide}), case_vals$first() )
})
#observe({print(btnGrowth())})
output$no_module <- renderDT({DT::datatable(rownames = F,df_agg$df_wide,caption = "Not Updated Within Module")})
output$module_tbl <- renderDT({DT::datatable(rownames = F, mydf() ,caption = "Table Returned From Module")} )
### using original data so no change after first click
#output$module_tbl <- renderDT({DT::datatable(rownames = F, modApplyAssumpServer("tst", btnGrowth, reactive({df_agg_orig}), case_vals$first() ),caption = "Table Returned From Module")}
#)
}
shinyApp(ui, server)
}
runApp(GrowthInputApp())

testing shiny modules with additional variables

I've been playing with shiny modules and finally got some bits and pieces working. However, I've been totally thrown by an issue testing individual modules.
What I usually do is turn each module into a small app to test how it works. This particular module takes additional variables, but I don't seem to be able to insert some test vars into the test app as I would usually. Unfortunately, this fails.
Is there a standard way of dealing with this?
Many thanks
histogram_ui <- function(id) {
tagList(
plotOutput(NS(id, "hist"))
)
}
histogram_server <- function(id, var, bin) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[var()]])
#debug
observeEvent(var(), {
print(var())
})
output$hist <- renderPlot({
hist(data(), breaks = bin(), main = var())
})
})
}
#testing----
ui_t <- fluidPage(
histogram_ui("test")
)
server_t <- function(input, output, session) {
histogram_server("test", var = "mpg", bin = 10)
}
options(shiny.reactlog=TRUE) #ctrl+F3 to bring up
shinyApp(ui_t, server_t)
Try this
histogram_ui <- function(id) {
tagList(
plotOutput(NS(id, "hist"))
)
}
histogram_server <- function(id, var, bin) {
moduleServer(id, function(input, output, session) {
observeEvent(c(var(), bin()), {
print(var())
})
output$hist <- renderPlot({
hist(mtcars[[var()]], breaks = bin(), main = var())
})
})
}
#testing----
ui_t <- fluidPage(
selectInput("myvar","Choose",choices = colnames(mtcars)),
sliderInput("bins","Number of Bins", min=1, max=10, value=5),
histogram_ui("test")
)
server_t <- function(input, output, session) {
histogram_server("test", var = reactive(input$myvar), bin = reactive(input$bins))
}
options(shiny.reactlog=TRUE) #ctrl+F3 to bring up
shinyApp(ui_t, server_t)

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()})
}

Resources