如何从依赖于按钮单击的 shiny 模块中返回反应式 dataframe？

Question

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

Answer 1

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