r语言 - 如何从一个闪亮的模块内返回一个反应性数据框架，取决于一个按钮点击?

Question

目标:从名为" modapply假设服务器"的模块中返回一个响应性数据框架对象。问题:我得到了一个无限循环。即使我在isolate()

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

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