如何捕获这个 R Shiny 可扩展反应性用户输入矩阵作为另一个反应性对象以进行进一步操作？

Question

在下面的示例 R Shiny 代码中，有两种类型的输入矩阵。第一个（在侧边栏面板顶部呈现并由函数

matInputBase()

生成）捕获用户输入变量“Y”并将其应用到时间窗口“W”。然后，这个顶部矩阵被分成 2 个可扩展矩阵（由函数

matInputFlex()

生成），其中用户可以选择在“X”时间更改变量 Y。我删除了所有计算代码，只留下用户输入矩阵。用户输入矩阵由包

shinyMatrix

生成。

如何将

matInputFlex()

生成的这两个矩阵捕获为反应对象，并作为示例将它们呈现在主面板中作为表格？

我需要捕获该对象以实现下载/上传功能，并使后续计算更容易。数据应该从

matInputBase()

到

matInputFlex()

流向我想要使用的这个待构建的反应对象。流是下游的，输入到

matInputBase()

流向

matInputFlex()

，但它们永远不会从

matInputFlex()

流向

matInputBase()

。下图有助于解释。

代码：

library(shiny)
library(shinyMatrix)

matInputBase <- function(name){
  matrixInput(name, 
              value = matrix(c(0.2), 2, 1, dimnames = list(c("Var_1","Var_2"),NULL)),
              rows = list(extend = FALSE,  names = TRUE),
              cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")
}

matInputFlex <- function(name, x, y) {
  matrixInput(name,
              value = matrix(c(x, y), 1, 2, dimnames = list(NULL, c("X", "Y"))),
              rows = list(extend = TRUE, names = FALSE),
              cols = list(extend = TRUE, delta = 0, names = TRUE, editableNames = FALSE), 
              class = "numeric")
}

ui <- fluidPage(
  sidebarPanel(
    sliderInput('periods', 'Time window (W):', min = 1, max = 20, value = 20),
    h5(strong("Var (Y) over time window:")),
    matInputBase("base_input"),
    actionButton('resetVectorBtn', 'Reset'),
    uiOutput("Vectors")
  ), 
  mainPanel(h5("Show the 2 adjustable matrixes here as DF...")) # show new object that copies adjustable
) 

server <- function(input, output, session) {
  periods <- reactive(input$periods)
  base_input <- reactive(input$base_input)

  output$Vectors <- renderUI({
    input$resetVectorBtn
    tagList(
      h5(strong("Adjust Var_1 (Y) at time X:")),
      matInputFlex("var_1_vector_input", input$periods, input$base_input[1, 1]),
      h5(strong("Adjust Var_2 (Y) at time X:")),
      matInputFlex("var_2_vector_input", input$periods, input$base_input[2, 1])
    )
  })
} 

shinyApp(ui, server)

Answer 1

我认为你遇到的问题是因为你的

matInputFlex()

函数返回一个 html 标签，而不是实际的矩阵。如果你解决这个问题，它应该相对简单。我们可以让它返回一个包含 html 和实际矩阵的列表。

matInputFlex <- function(name, x, y) {
    mat <- matrix(c(x, y), 1, 2, dimnames = list(NULL, c("X", "Y")))
    mat_html <- matrixInput(name,
        value = mat,
        rows = list(extend = TRUE, names = FALSE),
        cols = list(extend = TRUE, delta = 0, names = TRUE, editableNames = FALSE),
        class = "numeric"
    )
    list(
        mat = mat,
        mat_html = mat_html
    )
}

然后，您可以在向其传递此数据的 UI 中添加

tableOutput()

，同时仍将

mat_html

组件传递给

tagList()

：

    output$Vectors <- renderUI({
        input$resetVectorBtn
        var1_m <- matInputFlex("var_1_vector_input", input$periods, input$base_input[1, 1])
        var2_m <- matInputFlex("var_2_vector_input", input$periods, input$base_input[2, 1])

        mat_df <- rbind(var1_m$mat, var2_m$mat)

        output$matrices <- renderTable(mat_df)
        tagList(
            h5(strong("Adjust Var_1 (Y) at time X:")),
            var1_m$mat_html,
            h5(strong("Adjust Var_2 (Y) at time X:")),
            var2_m$mat_html
        )
    })

完整的应用程序代码

library(shiny)
library(shinyMatrix)

matInputBase <- function(name) {
    matrixInput(name,
        value = matrix(c(0.2), 2, 1, dimnames = list(c("Var_1", "Var_2"), NULL)),
        rows = list(extend = FALSE, names = TRUE),
        cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
        class = "numeric"
    )
}

matInputFlex <- function(name, x, y) {
    mat <- matrix(c(x, y), 1, 2, dimnames = list(NULL, c("X", "Y")))
    mat_html <- matrixInput(name,
        value = mat,
        rows = list(extend = TRUE, names = FALSE),
        cols = list(extend = TRUE, delta = 0, names = TRUE, editableNames = FALSE),
        class = "numeric"
    )
    list(
        mat = mat,
        mat_html = mat_html
    )
}

ui <- fluidPage(
    sidebarPanel(
        sliderInput("periods", "Time window (W):", min = 1, max = 20, value = 20),
        h5(strong("Var (Y) over time window:")),
        matInputBase("base_input"),
        actionButton("resetVectorBtn", "Reset"),
        uiOutput("Vectors")
    ),
    mainPanel(tableOutput("matrices")) # show new object that copies adjustable
)

server <- function(input, output, session) {
    periods <- reactive(input$periods)
    base_input <- reactive(input$base_input)

    output$Vectors <- renderUI({
        input$resetVectorBtn
        var1_m <- matInputFlex("var_1_vector_input", input$periods, input$base_input[1, 1])
        var2_m <- matInputFlex("var_2_vector_input", input$periods, input$base_input[2, 1])

        mat_df <- rbind(var1_m$mat, var2_m$mat)

        output$matrices <- renderTable(mat_df)
        tagList(
            h5(strong("Adjust Var_1 (Y) at time X:")),
            var1_m$mat_html,
            h5(strong("Adjust Var_2 (Y) at time X:")),
            var2_m$mat_html
        )
    })
}

shinyApp(ui, server)