在 R Shiny 中，如何允许通过下一次单击允许修改的操作按钮来保留反应性用户输入的更改？

Question

在下面的第一个 MWE 代码中，它运行良好 - 用户单击“修改”操作按钮，在弹出的模态对话框中，用户对矩阵用户输入网格进行更改，用户关闭模态对话框，点击再次“修改”，这些用户输入将保留（或“保留”）在矩阵输入网格（和输出表）中，无需任何形式的重置为默认值。完美，按预期工作。

在下面的第二个 MWE 代码中，在“负债模块”选项卡内，用户输入不会从单击“修改...”操作按钮（在侧边栏面板中呈现）到下一次单击。每次单击“修改...”都会将用户输入网格重置为默认值。

我一直在尝试将反应链从第一个 MWE 复制到第二个 MWE，但没有成功。我对反应性的理解还不够深入。有人可以帮我解决这个问题，并解释需要做什么以及为什么可能的话？

用户输入正确保留的第一个 MWE 代码：

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

# Function assigns row headers to input matrix grid
  matrix3Headers <- function(){
    c('A','B','C','D')}

# Assigns default values to first column of input matrix grid
  matrix3Default <- matrix(c(1,24,0,100),4,1,dimnames=list(matrix3Headers(),NULL))

# Automatically assigns names to column headers
  colnames(matrix3Default) <- paste0("Series ",1:ncol(matrix3Default))

# Matrix input function
  matrix3Input <- function(x, matrix3Default){
  matrixInput(x, 
              label =  'Input series terms into below grid, formatted version shown at bottom:',
              value =  matrix3Default, 
              rows  =  list(extend=FALSE,names=TRUE), 
              cols  =  list(extend=TRUE,names=TRUE,editableNames=FALSE,delete=TRUE),
              class =  'numeric'
    ) # close matrix input
  } # close function

ui <- fluidPage(
  useShinyjs(),
  titlePanel('Liabilities Inputs'),
  fluidRow(actionButton('show','Show'),
           actionButton('modify','Modify'),
           actionButton('hide','Hide'),
           actionButton('reset','Reset'),
           tableOutput('table2')
  ) # close fluid row
) # close fluid page

server <- function(input, output, session){
  
  rv <- reactiveValues(
        mat3=matrix3Input('matrix3',matrix3Default),
        input=matrix3Default,
        colHeader = colnames(input)
        ) # close reactive values
  
  hide('table2')
  
  observeEvent(input$modify,{
    showModal(modalDialog(
      rv$mat3,
      tableOutput('table1')
    )) # close shown modal and modal dialog
    hide('table2')
  }) # close observe event
  
  output$table1 <- renderTable({
    rv$mat3 <- matrix3Input('matrix3',input$matrix3)
      
      # Indented section below assigns sequential column headers to output tables:
        df <- input$matrix3
        n <- dim(df)[2]
        
      # Below indented code adds numeric formats to table output  
        dfA <- format(df[1,],nsmall=0)
        dfB <- format(df[2,],nsmall=0)
        dfC <- paste(format(df[3,],nsmall=2),'%')
        dfD <- paste(format(df[4,],nsmall=2),'%')
        df <- rbind(df[0,],dfA,dfB,dfC,dfD)
        rownames(df) <- matrix3Headers()
    rv$input <- df
    colnames(df) <- paste("Series", 1:n)
    df
    },rownames=TRUE, colnames=TRUE)
  
  observeEvent(input$show,show('table2'))
  
  observeEvent(input$hide, hide('table2'))
  
  observeEvent(input$reset,{
    hide('table2')
    rv$input <- matrix3Default
    rv$mat3 <- matrix3Input('matrix3', matrix3Default)
    }) # close observe event
  
  output$table2 <- renderTable({
    df <- rv$input
    n <- dim(df)[2]
    colnames(df) <- paste("Series", 1:n)
    df
    },rownames=TRUE)
  
} # close server

shinyApp(ui, server)

需要用户输入“坚持”的第二个 MWE 代码：

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)

button2 <- function(x,y){actionButton(x,y,style="width:90px;margin-bottom:5px;font-size:80%")}

matrix1Input <- function(x){
  matrixInput(x, 
              value = matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL)),
              rows = list(extend=FALSE,names=TRUE),
              cols = list(extend=FALSE,names=FALSE,editableNames=FALSE),
              class = "numeric")}

pct <- function(x){paste(format(round(x*100,digits=1),nsmall=1),"%",sep="")} # convert to percentage

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

vectorPlot <- function(w,x,y,z){
  plot(w[,1],sapply(w[,2], function(x)gsub("%","",x)), # << per YBS solution Aug 27, 2021
       main=x,
       xlab=y,
       ylab=z,
       type="b",
       col="blue",
       pch=19,cex=1.25
       ) # close plot
  } # close function

ui <- 
  pageWithSidebar(
    headerPanel("Model..."),
    sidebarPanel(
      fluidRow(helpText(h5(strong("Base Input Panel")),align="center",
                        style="margin-top:-15px;margin-bottom:5px")),
      # Panels rendered with uiOuput & renderUI in server to stop flashing at invocation
      uiOutput("Panels") 
    ), # close sidebar panel
    mainPanel(
      tabsetPanel(
        tabPanel("By balances", value=2),
        tabPanel("By accounts", value=3), 
        tabPanel("Liabilities module", value=4,
                 fluidRow(h5(strong(helpText("Select model output to view:")))),
                 fluidRow(
                   button2('showRatesValueBtn','Rates values'),
                   button2('showRatesPlotBtn','Rates plots'),
                 ), # close fluid row
                 
                 div(style = "margin-top: 5px"),
                 
                 # Shows outputs on each page of main panel   
                 uiOutput('showResults')), 
        id = "tabselected"
      ) # close tabset panel
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)({
  
  base_input  <- reactive(input$base_input)
  showResults <- reactiveValues()
  
  yield   <- function(){vectorBase(60,input$base_input[1,1])} # Must remain in server section
  
  # --- Conditional panels rendered here rather than in UI to eliminate invocation flashing ------------>
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==4",
        actionButton('modRates','Modify Rates and Coupons',
                     style='width:100%;background-color:LightGrey'
                     ),
        setShadow(id='modRates'),
        div(style = "margin-bottom: 10px"),
      ), # close conditional panel
      conditionalPanel(condition="input.tabselected==3"),
      conditionalPanel(condition="input.tabselected==4")
    ) # close tagList
  }) # close renderUI
  
  # --- Below defines the vectorsAll object before user clicks on actionButton "Input Liabilities" ---->
  vectorsAll <- reactive({
    if (is.null(input$modRates)){df <- NULL}
    else {
      if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = pct(0.2))}  # define what you want to display by default
      else {
        req(input$base_input)
        df <- cbind(Period = 1:60,BaseRate = pct(yield()[,2]))
      } # close 2nd else
    } # close 1st else
    df
  }) # close reactive
  
  output$table1 <- renderTable({vectorsAll()})
  
  # --- Below produces vector values after clicking "Vector Values" button; see above for pre-click ---->
  observeEvent(input$showRatesValueBtn,
               {showResults$showme <-
                 tagList(tableOutput("table1"))
               },ignoreNULL = FALSE)
  
  # --- Below produces vector plots -------------------------------------------------------------------->   
  output$graph1 <-renderPlot(vectorPlot(vectorsAll(),"A Variable","Period","Rate"))
  observeEvent(input$showRatesPlotBtn,{showResults$showme <- plotOutput("graph1")})
  
  # --- Below sends both vector plots and vector values to UI section above ---------------------------->
  output$showResults <- renderUI({showResults$showme})
  
  # --- Below for modal dialog inputs ------------------------------------------------------------------>
  observeEvent(input$modRates,
               {showModal(modalDialog(
                 matrix1Input("base_input"),
                 div(style = "margin-top: 0px"),
                 useShinyjs(),
               ) # close modalDialog
               ) # close showModal
               } # close showModal function
  ) # close observeEvent
  
}) # close server

shinyApp(ui, server)

Answer 1

那是因为您的modalDialog 每次单击按钮时都会重置表格。而matrix1Input 始终使用默认值。您需要将其作为您的第一个示例。渲染表格时，您不再使用默认值重新渲染它，而是使用旧值。

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)

button2 <- function(x,y){actionButton(x,y,style="width:90px;margin-bottom:5px;font-size:80%")}

mDefaults <- matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL))
matrix1Input <- function(x, defaults){
    matrixInput(x, 
                value = defaults,
                rows = list(extend=FALSE,names=TRUE),
                cols = list(extend=FALSE,names=FALSE,editableNames=FALSE),
                class = "numeric")}

pct <- function(x){paste(format(round(x*100,digits=1),nsmall=1),"%",sep="")} # convert to percentage

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

vectorPlot <- function(w,x,y,z){
    plot(w[,1],sapply(w[,2], function(x)gsub("%","",x)), # << per YBS solution Aug 27, 2021
         main=x,
         xlab=y,
         ylab=z,
         type="b",
         col="blue",
         pch=19,cex=1.25
    ) # close plot
} # close function

ui <- 
    pageWithSidebar(
        headerPanel("Model..."),
        sidebarPanel(
            fluidRow(helpText(h5(strong("Base Input Panel")),align="center",
                              style="margin-top:-15px;margin-bottom:5px")),
            # Panels rendered with uiOuput & renderUI in server to stop flashing at invocation
            uiOutput("Panels") 
        ), # close sidebar panel
        mainPanel(
            tabsetPanel(
                tabPanel("By balances", value=2),
                tabPanel("By accounts", value=3), 
                tabPanel("Liabilities module", value=4,
                         fluidRow(h5(strong(helpText("Select model output to view:")))),
                         fluidRow(
                             button2('showRatesValueBtn','Rates values'),
                             button2('showRatesPlotBtn','Rates plots'),
                         ), # close fluid row
                         
                         div(style = "margin-top: 5px"),
                         
                         # Shows outputs on each page of main panel   
                         uiOutput('showResults')), 
                id = "tabselected"
            ) # close tabset panel
        ) # close main panel
    ) # close page with sidebar

server <- function(input,output,session)({
    
    base_input  <- reactive(input$base_input)
    showResults <- reactiveValues()
    
    yield   <- function(){vectorBase(60,input$base_input[1,1])} # Must remain in server section
    
    # --- Conditional panels rendered here rather than in UI to eliminate invocation flashing ------------>
    output$Panels <- renderUI({
        tagList( 
            conditionalPanel(
                condition="input.tabselected==4",
                actionButton('modRates','Modify Rates and Coupons',
                             style='width:100%;background-color:LightGrey'
                ),
                setShadow(id='modRates'),
                div(style = "margin-bottom: 10px"),
            ), # close conditional panel
            conditionalPanel(condition="input.tabselected==3"),
            conditionalPanel(condition="input.tabselected==4")
        ) # close tagList
    }) # close renderUI
    
    # --- Below defines the vectorsAll object before user clicks on actionButton "Input Liabilities" ---->
    vectorsAll <- reactive({
        if (is.null(input$modRates)){df <- NULL}
        else {
            if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = pct(0.2))}  # define what you want to display by default
            else {
                req(input$base_input)
                df <- cbind(Period = 1:60,BaseRate = pct(yield()[,2]))
            } # close 2nd else
        } # close 1st else
        df
    }) # close reactive
    output$table1 <- renderTable({vectorsAll()})
    
    # --- Below produces vector values after clicking "Vector Values" button; see above for pre-click ---->
    observeEvent(input$showRatesValueBtn,
                 {showResults$showme <-
                     tagList(tableOutput("table1"))
                 },ignoreNULL = FALSE)
    
    # --- Below produces vector plots -------------------------------------------------------------------->   
    output$graph1 <-renderPlot(vectorPlot(vectorsAll(),"A Variable","Period","Rate"))
    observeEvent(input$showRatesPlotBtn,{showResults$showme <- plotOutput("graph1")})
    
    # --- Below sends both vector plots and vector values to UI section above ---------------------------->
    output$showResults <- renderUI({showResults$showme})
    
    # --- Below for modal dialog inputs ------------------------------------------------------------------>
    observeEvent(input$modRates,
                 {showModal(modalDialog(
                     matrix1Input("base_input", if(is.null(input$base_input)) mDefaults else input$base_input),
                     div(style = "margin-top: 0px"),
                     useShinyjs(),
                 ) # close modalDialog
                 ) # close showModal
                 } # close showModal function
    ) # close observeEvent
    
}) # close server

shinyApp(ui, server)

我添加了默认参数。当您的表存在时，我使用现有值而不是默认值。