如何 return 从一个依赖于按钮点击的闪亮模块中的反应式数据框？

Question

目标：Return 来自名为“modApplyAssumpServer”的模块中的反应式数据框对象问题：我遇到了无限循环。即使我将所有内容都包装在 isolate()

中的 observeevent 逻辑中

我在下面的应用程序代码中包含了另一个 table 以指示在模块框架之外工作但我似乎无法在模块内工作的逻辑的简化版本。

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

试试这个

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

如何 return 从一个依赖于按钮点击的闪亮模块中的反应式数据框？

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

module

r

shiny

dt

reactive