在 R Shiny 中，如何编写一个在单击操作按钮时生成额外用户输入的函数？

Question

我正在开发一个允许用户选择扩展基本起始输入的应用程序（以下 MWE 中的firstInput）。 SecondInput 允许用户垂直扩展他的假设（在此 MWE 中不起作用，但在完整的应用程序中它运行外推和插值，并且它垂直扩展适合侧边栏面板）。为简单起见，下面的ThirdInput 已绝育。 FourthInput，出现在modalDialog，允许用户水平扩展假设。输入按顺序链接 (firstInput -> secondInput -> fourthInput)，最后一个输入优先。链接工作正常。

在完整的应用程序中，我有垂直扩展工作。现在我需要水平假设扩展方面的帮助。

如下图所示，在modalDialog中，如何点击“添加场景”actionButton在右侧添加另一个输入矩阵，称为“fifthInput”？再点击一下就会在右边添加“sixthInput”，等等。这就是我所说的“水平扩展”。至于链接，这些新的输入矩阵将链接到secondInput，就像fourthInput 一样。单击“删除上方”actionButton 将删除其正上方的输入矩阵。我不确定modalDialog 框扩展了多大，但我可能需要某种允许垂直/水平滚动的框。如果这有点多，我想知道是否有某种包可以解决这个问题或有帮助。

MWE 代码：

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

f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions       <- c("show", "reset")
tbl           <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("2nd input", "3rd input")

firstInput <- function(inputId){
  matrixInput(inputId, 
              value = matrix(c(5), 1, 1, dimnames = list(c("1st input"),NULL)),
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

secondInput <- function(inputId,x){
  matrixInput(inputId, 
              value = matrix(c(x), 1, 1, dimnames = list(c("2nd input"),NULL)),
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

fourthInput <- function(inputId,x){
  matrixInput(inputId, 
              value = matrix(c(x), 1, 1, dimnames = list(c("4th input"),NULL)),
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      "td .checkbox {margin-top: 0; margin-bottom: 0;}
       td .form-group {margin-bottom: 0;}"
    ))
  ),
  br(),
  sidebarLayout(
    sidebarPanel(
      uiOutput("panel"),
      hidden(uiOutput("secondInput")),
      actionButton("showFourth","Show 4th input (in modal)",width = "100%") # ADDED
    ),
    mainPanel(plotOutput("plot1"))
  )
)

server <- function(input, output){
  
  input1      <- reactive(input$input1)
  input2      <- reactive(input$input2)
  input4      <- reactive(input$input4)
  
  output$panel <- renderUI({
    tagList(
      useShinyjs(),
      firstInput("input1"),
      strong(helpText("Generate curves (Y|X):")),
      tableOutput("checkboxes") 
    )
  })
  
  output[["checkboxes"]] <- 
    renderTable({tbl}, 
      rownames = TRUE, align = "c",
      sanitize.text.function = function(x) x
    )

  observeEvent(input[["show1"]], {
    if(input[["show1"]]){shinyjs::show("secondInput")} else 
      {shinyjs::hide("secondInput")}
  })
  
  observeEvent(input$showFourth,{
    showModal(
      modalDialog(
        column(4,
          actionButton("add","Add scenario"), div(style = "margin-bottom: 10px"),
          fourthInput("input4",if(isTruthy(input$input4)){input$input4} else {input$input2[1,1]}),
          actionButton("remove","Remove above")
          ),
        footer = modalButton("Close")
      )) # close showModal and modalDialog 
  })
  
  output$secondInput <- renderUI({
    req(input1())
    secondInput("input2",input$input1[1,1])
  })
  
  outputOptions(output,"secondInput",suspendWhenHidden = FALSE) 
  
  output$plot1 <-renderPlot({
    req(input2())
    plot(rep(if(isTruthy(input$input4)){input4()} else {input2()}, times=5))
  })
}

shinyApp(ui, server)

Answer 1

我总是低估了 ShinyMatrix 包，事实证明它具有我正在寻找的水平扩展功能，并且可以根据需要将扩展​​分为 2 个。请参阅修改后的 MWE 代码，该代码反映了 shinyMatrix 用于扩展的这种用法。基本上对于matrixInput 的列规范（在自定义函数fourthInput 中），我所做的只是添加extend = TRUE, delta = 2, delete = TRUE, .... 扩展意味着可以扩展矩阵（按列，因为这是在列参数部分），增量为 2 = 矩阵以 2 为一组展开，delete = 列可以被删除。

但是 shinyMatrix 输出并不是最漂亮的东西，我对其他解决方案或软件包持开放态度！

MWE 代码：

library(shiny)
library(shinyjs)

f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions       <- c("show", "reset")
tbl           <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("2nd input", "3rd input")

xDflt <- 10
yDflt <- 5

userInput <- function(inputId,x,y,z){
  matrixInput(inputId, 
              value = matrix(c(x,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")}

fourthInput <- function(inputId,x,y,z){
  matrixInput(inputId, 
              value = matrix(c(x,y), 1, 2, dimnames = list(c(z),c("X and Y",""))),
              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(
  tags$head(
    tags$style(HTML(
      "td .checkbox {margin-top: 0; margin-bottom: 0;}
       td .form-group {margin-bottom: 0;}"
    ))
  ),
  br(),
  sidebarLayout(
    sidebarPanel(
      uiOutput("panel"),
      hidden(uiOutput("secondInput")),
      actionButton("showFourth","Show 4th input (in modal)",width = "100%")
    ),
    mainPanel(plotOutput("plot1"))
  )
)

server <- function(input, output){
  
  input1      <- reactive(input$input1)
  input2      <- reactive(input$input2)
  input4      <- reactive(input$input4)
  
  output$panel <- renderUI({
    tagList(
      useShinyjs(),
      userInput("input1",xDflt,yDflt,"1st input"),
      strong(helpText("Generate curves (Y|X):")),
      tableOutput("checkboxes") 
    )
  })
  
  output[["checkboxes"]] <- 
    renderTable({tbl}, 
      rownames = TRUE, align = "c",
      sanitize.text.function = function(x) x
    )

  observeEvent(input[["show1"]], {
    if(input[["show1"]]){shinyjs::show("secondInput")} else 
      {shinyjs::hide("secondInput")}
  })
  
  observeEvent(input$showFourth,{
    showModal(
      modalDialog(
          fourthInput("input4",
                      xDflt,
                      if(isTruthy(input$input4)){input$input4[1,2]} else 
                        {input$input2[1,2]},
                      "4th input"),
          footer = modalButton("Close")
      ))
  })
  
  output$secondInput <- renderUI({
    req(input1())
    userInput("input2",xDflt,input$input1[1,2],"2nd Input")
  })
  
  outputOptions(output,"secondInput",suspendWhenHidden = FALSE) 
  
  output$plot1 <-renderPlot({
    req(input2())
    plot(rep(if(isTruthy(input$input4)){input4()[1,2]} else {input2()[1,2]}, times=10))
  })
}

shinyApp(ui, server)