在 R shiny 中,单击操作按钮后如何触发主面板 table 渲染的变化?

In R shiny, how to trigger change in main panel table rendering after clicking an action button?

在下面的 MWE 代码中,当 运行 时,如果用户 (1) 当前在主面板中查看费率值 table(在单击“费率值”操作按钮后在主面板顶部),然后 (2) 单击侧边栏面板中的“修改负债结构”操作按钮,并在随后出现的模态对话框中更改负债结构输入网格,然后 (3) 关闭模态对话,然后 (4) 用户保留在主面板中的费率值 table。

同样,如果用户 (1) 当前正在查看主面板中的负债结构 table,则 (2) 单击侧边栏面板中的“修改利率和优惠券”操作按钮,然后在随后的模态对话中更改矩阵输入网格的 A 行(唯一可操作的行),然后 (3) 取消模态对话,然后 (4) 用户保留在负债结构 table 中主面板。

我希望在单击“修改负债结构”后对输入网格进行任何更改,以使负债 table(“table3”)在主面板中呈现,无论以前在主面板中的内容。同样,我希望在单击“修改费率和优惠券”后对输入网格进行任何更改,以使费率 table(“table4”)在主面板中呈现,而不管是什么之前在主面板中。

本质上,在模式对话框中对输入网格进行更改后,我需要为主面板 table 渲染触发某种“转到”功能。我不知道该怎么做。在下面的 MWE 中,我尝试执行此类“转到”的失败尝试被标记为“# ATTEMPT >”

MWE 代码:

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

colnames(matrix3Default) <- paste0("Series ",1:ncol(matrix3Default))

matrix3Default <- matrix(c(1,24,0,100),4,1,dimnames=list(matrix3Headers(), NULL))

matrix3Headers <- function(){c('A','B','C','D')}

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 show modal and modal dialog
    # ATTEMPT >  {showResults$showme <- tagList(tableOutput("table3"))}
  ) # close observe event
  
  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 taglist, modalDialog, showModal, and showModal function
               # ATTEMPT > {showResults$showme <- tagList(tableOutput("table4"))}
  ) # close observeEvent
  
}) # close server

shinyApp(ui, server)

也许您正在寻找这个。

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")
        actionButton("close1","Close")
      ), # close tag list
    ))} # close show modal and modal dialog
    # ATTEMPT >  {showResults$showme <- tagList(tableOutput("table3"))}
  ) # close observe event
  
  observeEvent(input$close1,{
    removeModal()
    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")
                   actionButton("close2","Close")
                 )))} # close taglist, modalDialog, showModal, and showModal function
               # ATTEMPT > {showResults$showme <- tagList(tableOutput("table4"))}
  ) # close observeEvent
  
  observeEvent(input$close2,{
    removeModal()
    showResults$showme <- tagList(tableOutput("table4"))
  })
  
}) # close server

shinyApp(ui, server)

你的尝试不错。 只需将 'goto' 移到花括号内:

{showModal(modalDialog(
      matrix4Input("matrix4",if(is.null(input$matrix4)) matrix4Default else input$matrix4),
      useShinyjs(),
      footer = tagList(
        actionButton("resetRatesStruct","Reset"), 
        modalButton("Close")
      )))
      showResults$showme <- tagList(tableOutput("table4")) ### this line 
    } ## above this curly brace