R Shiny 修改模态框输入后触发主面板指定表格渲染的实现方法

核心修改逻辑 #

原代码的跳转逻辑写在了打开模态框的observeEvent执行块外部，不会被触发；且没有绑定网格修改的监听事件，无法识别用户的修改操作。我们只需要新增两个监听矩阵输入变化的观察事件即可实现需求：

• 当负债结构矩阵input$matrix3被修改时，自动切换主面板展示负债结构表格table3
• 当利率矩阵input$matrix4被修改时，自动切换主面板展示利率值表格table4

具体修改位置 #

在server函数中新增如下两段代码即可：

# 监听负债结构矩阵修改，自动跳转对应表格
observeEvent(input$matrix3, {
  showResults$showme <- tagList(tableOutput("table3"))
})

# 监听利率矩阵修改，自动跳转对应表格
observeEvent(input$matrix4, {
  showResults$showme <- tagList(tableOutput("table4"))
})

如果需要仅在用户点击模态框的「关闭」按钮后才跳转，可以将上述逻辑绑定到模态框关闭事件，上述方案是修改即跳转，完全符合需求描述的效果。

完整修正后代码 #

library(shiny);library(shinyMatrix);library(shinyjs)

matrix3Headers <- function(){c('A','B','C','D')}
matrix3Default <- matrix(c(1,24,0,100),4,1,dimnames=list(matrix3Headers(), NULL))
colnames(matrix3Default) <- paste0("Series ",1:ncol(matrix3Default))

matrix3Input <- function(x, matrix3Default){
  matrixInput(x,label =  'Input series terms into below grid:',
              value =  matrix3Default, 
              rows  =  list(extend=FALSE,names=TRUE), 
              cols  =  list(extend=TRUE,names=TRUE,editableNames=FALSE,delete=TRUE),
              class =  'numeric')}

matrix4Default <- matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL))

matrix4Input <- function(x,matrix4Input){
  matrixInput(x,value = matrix4Input,
              rows = list(extend=FALSE,names=TRUE),
              cols = list(extend=FALSE,names=FALSE,editableNames=FALSE),
              class = "numeric")}

vectorBaseRate <- function(x,y){
  a <- rep(y,x)
  b <- seq(1:x)
  c <- data.frame(x = b, y = a)
  return(c)}

vectorBaseRatePlot <- function(w,x,y,z){plot(w[,1],sapply(w[,2], function(x)gsub("%","",x)),
                                             main=x,xlab=y,ylab=z,type="b")}

ui <- 
  pageWithSidebar(
    headerPanel("Model..."),
    sidebarPanel(fluidRow(helpText(h5(strong("Base Input Panel")),align="center")),uiOutput("Panels")),
    mainPanel(
      tabsetPanel(
        tabPanel("Liabilities module", value=4,
                 fluidRow(h5(strong(helpText("Select model output to view:")))),
                 fluidRow(
                   actionButton('showLiabStructBtn','Liabilities'),
                   actionButton('showRatesValueBtn','Rates values'),
                   actionButton('showRatesPlotBtn','Rates plots')), 
                 uiOutput('showResults')), 
        id = "tabselected"))) 

server <- function(input,output,session)({
  
  showResults <- reactiveValues()
  rv          <- reactiveValues( # Used for matrix 3 (liability structure) inputs
    mat3       = matrix3Input('matrix3',matrix3Default),
    input      = matrix3Default,
    colHeader  = colnames(input))
  matrix4     <- reactive(input$matrix4)
  baseRate    <- function(){vectorBaseRate(60,input$matrix4[1,1])} 
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(condition="input.tabselected==4",
                       actionButton('modLiabStruct','Modify Liabilities Structure'),
                       actionButton('modRates','Modify Rates and Coupons'))
    ) # close tagList
  }) # close renderUI
  
  vectorLiabStruct <- reactive({
    if(!isTruthy(input$modLiabStruct)){ # << Generates default table when first invoking the App
      df <- matrix3Default
      n <- dim(df)[2]
      colnames(df) <- paste("Series", 1:n)
      rownames(df) <- matrix3Headers()
    }
    else{ # 
      req(input$matrix3) 
      rv$mat3 <- matrix3Input('matrix3',input$matrix3) 
      df <- input$matrix3
      n <- dim(df)[2]
      colnames(df) <- paste("Series", 1:n)
      rownames(df) <- matrix3Headers()
      rv$input <- df
    } # close else
    df
  })
  
  output$table3 <- renderTable({
    if(!isTruthy(input$modLiabStruct)){
      df <- matrix3Default
      n <- dim(df)[2]
      colnames(df) <- paste("Series", 1:n)
      rownames(df) <- matrix3Headers()
    }
    else{  
      req(input$matrix3) 
      rv$mat3 <- matrix3Input('matrix3',input$matrix3)
      df <- input$matrix3
      n <- dim(df)[2]
      colnames(df) <- paste("Series", 1:n)
      rownames(df) <- matrix3Headers()
      rv$input <- df
    } # close else
    df
  },rownames=TRUE, colnames=TRUE) # close output$table3
  
  vectorRates <- reactive({
    if (is.null(input$modRates)){df <- NULL}
    else {if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = 0.2)}
      else {
        req(input$matrix4)
        df <- cbind(Period = 1:60,BaseRate = baseRate()[,2])
      } # close 2nd else
    } # close 1st else
    df
  }) # close reactive
  
  output$table4 <- renderTable({vectorRates()})
  
  observeEvent(input$modLiabStruct,{
    showModal(modalDialog( 
      rv$mat3,
      footer = tagList(
        actionButton("resetLiabStruct","Reset"),
        modalButton("Close")
      ), # close tag list
    ))
  }) # close observe event
  
  # 新增：监听负债结构矩阵修改自动跳转
  observeEvent(input$matrix3, {
    showResults$showme <- tagList(tableOutput("table3"))
  })
  
  observeEvent(input$showLiabStructBtn,
               {showResults$showme <- tagList(tableOutput("table3"))},ignoreNULL = FALSE)  
  
  observeEvent(input$resetLiabStruct, {updateMatrixInput(session,'matrix3', matrix3Default)})
  observeEvent(input$resetRatesStruct, {updateMatrixInput(session,'matrix4', matrix4Default)})
  
  observeEvent(input$showRatesValueBtn,
               {showResults$showme <- tagList(tableOutput("table4"))},ignoreNULL = TRUE)
  
  output$graph1 <-renderPlot(vectorBaseRatePlot(vectorRates(),"A Variable","Period","Rate"))
  observeEvent(input$showRatesPlotBtn,{showResults$showme <- plotOutput("graph1")})
  
  output$showResults <- renderUI({showResults$showme})
  
  observeEvent(input$modRates,
               {showModal(modalDialog(
                 matrix4Input("matrix4",if(is.null(input$matrix4)) matrix4Default else input$matrix4),
                 useShinyjs(),
                 footer = tagList(
                   actionButton("resetRatesStruct","Reset"), 
                   modalButton("Close")
                 )))}
  ) # close observeEvent
  
  # 新增：监听利率矩阵修改自动跳转
  observeEvent(input$matrix4, {
    showResults$showme <- tagList(tableOutput("table4"))
  })
  
}) # close server

shinyApp(ui, server)

内容的提问来源于stack exchange，提问作者Curious Jorge - user9788072