Issue
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())
Solution
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())
Answered By - YBS Answer Checked By - Timothy Miller (PHPFixing Admin)
0 Comments:
Post a Comment
Note: Only a member of this blog may post a comment.