在 R Shiny 中，重新渲染矩阵时如何在扩展输入矩阵中保留值？

Question

下面的 MWE 代码有一个反应链，用户可以在其中更改第一个输入矩阵中的 Y 值（右列），并且该值通过第二个输入矩阵保留，当用户单击时通过模态对话框呈现“显示第二个输入...”操作按钮。所有这些都按预期工作。

我遇到的问题是保留输入到第二个矩阵的值。该矩阵允许水平扩展（和删除）。该矩阵在自动生成的按顺序编号的列标题方面正常工作，分组为 2。但是如果将值输入到附加列中（如底部的图像所示，列“2”和“3”已添加例如），并且该模式对话框已关闭并随后重新打开，则不会保留那些添加的列值。他们需要被保留。请注意，用户对“1”列的更改被正确保留。有什么建议吗？

MWE 代码：

library(shiny)
library(shinyMatrix)

yDflt <- 5

firstInput <- function(inputId,y,z){ # << y = y col default value, z = matrix row label
  matrixInput(inputId, 
              value = matrix(c(10,y), 1, 2, dimnames = list(c(z),c("X and Y",""))),
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(
                extend = FALSE, 
                names = TRUE, 
                editableNames = FALSE,
                multiheader=TRUE
              ),
              class = "numeric")}

secondInput <- function(inputId,y,z){ # << y = y col default value, z = matrix row label
  matrixInput(inputId, 
              value = matrix(c(10,y), 1, 2, dimnames = list(c(z),c(1,""))),
              label = "Add, delete, or modify matrix parameters:",
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(
                extend = TRUE,
                delta = 2,
                delete = TRUE,
                names = TRUE, 
                editableNames = FALSE,
                multiheader=TRUE
              ),
              class = "numeric")}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      uiOutput("panel"),
      actionButton("showSecond","Show 2nd input (modal)",width = "100%")
    ),
    mainPanel(plotOutput("plot1"))
  )
)

server <- function(input, output, session){
 
  output$panel <- renderUI({firstInput("input1",yDflt,"1st input")})
  
  observeEvent(input$showSecond,{
    showModal(
      modalDialog(
        secondInput(
          "input2",
          if(isTruthy(input$input2)){input$input2[1,2]} else {input$input1[1,2]},
          "2nd input"),
        footer = modalButton("Close")
      ))
  })
  
  observe({ # << Assign sequential col header to matrix based on groupings of two
    req(input$input2)
    mm <- input$input2
    colnames(mm) <- trunc(1:ncol(mm)/2)+1 
    isolate(updateMatrixInput(session, "input2", mm))
  })
  
  output$secondInput <- renderUI({
    req(input$input1)
    secondInput("input2",input$input1[1,2],"2nd Input")
  })
  
  outputOptions(output,"secondInput",suspendWhenHidden = FALSE) 
  
  output$plot1 <-renderPlot({
    req(input$input1)
    plot(rep(if(isTruthy(input$input2)){input$input2[1,2]} else {input$input1[1,2]}, times=10))
  })
  
}

shinyApp(ui, server)

图片：

Answer 1

发布的原始 MWE 代码的问题是在模态对话框的 isTruthy 测试中（查看用户是否在该模态对话框中进行了输入：if(isTruthy(input$input2)){input$input2[1,2]} else {input$input1[1,2]},...），其中的else 部分定义过于狭窄，到矩阵输入的“y”输入（else {input$input1[1,2]}...）。该解决方案将 else 合规性的结果扩展到所有 input$input2 （input2 是模态对话框输入）：else {myInput("input2",input$input2,TRUE,2,TRUE)}... 请注意，下面将各种 matrixInput 函数从原始 MWE 压缩为 myInput 自定义函数, 缩短代码。

修改后的 MWE 代码：

library(shiny)
library(shinyMatrix)

###################################################################################################
#  a = matrix to input into matrixInput            d = delta # of columns when extending columns  #
#  b = variable for y column of input matrix       e = user option to delete column               #
#  c = extend matrix columns (T/F)                                                                #
################################################################################################### 

# matValues... feed into matrixInput as initial matrix; b parameter is for initial "Y" value
  matValue1 <- function(b){matrix(c(10,b), 1, 2, dimnames = list(c("1st input"),c("X and Y","")))}
  matValue2 <- function(b){matrix(c(10,b), 1, 2, dimnames = list(c("2nd input"),c(1,"")))}

myInput <- function(inputId,a,c,d,e){ 
  matrixInput(inputId, 
              value = a,
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(extend = c, 
                           delta = d,
                           delete = e,
                           names = TRUE, 
                           editableNames = FALSE,
                           multiheader=TRUE),
              class = "numeric")}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      uiOutput("panel"),
      actionButton("showSecond","Show 2nd input (modal)",width = "100%")
    ),
    mainPanel(plotOutput("plot1"))
  )
)

server <- function(input, output, session){
 
  output$panel <- renderUI({myInput("input1",matValue1(256),FALSE,1,FALSE)})
  
  observeEvent(input$showSecond,{
    showModal(
      modalDialog(
        if(is.null(input$input2))
          {myInput("input2",matValue2(input$input1[1,2]),TRUE,2,TRUE)}
            else {myInput("input2",input$input2,TRUE,2,TRUE)}, 
        footer = modalButton("Close")
      ))
  })
  
  observe({ # << Assign sequential col header to matrix based on groupings of two
    req(input$input2)
    mm <- input$input2
    colnames(mm) <- trunc(1:ncol(mm)/2)+1 
    isolate(updateMatrixInput(session, "input2", mm))
  })
  
  output$secondInput <- renderUI({
    req(input$input1)
    myInput("input2",matValue2(input$input1[1,2]),TRUE,2,TRUE)
  })
  
  outputOptions(output,"secondInput",suspendWhenHidden = FALSE) 
  
  output$plot1 <-renderPlot({
    req(input$input1)
    plot(rep(if(isTruthy(input$input2)){input$input2[1,2]} else {input$input1[1,2]}, times=10))
  })
  
}

shinyApp(ui, server)