在 R Shiny 中，如何正确 link 矩阵值？

Question

在下面的 MWE 代码中，用户可以选择通过一系列逐步矩阵输入（在本例中为 3）来优化模型 assumptions/inputs。首次调用应用程序时默认显示的第一个矩阵是 X 周期内的固定利率 Y。通过单击“显示”调用的第二个矩阵允许用户在 X 周期内改变 Y（构建“曲线”）。第三个矩阵，通过单击“添加场景”操作按钮调用，允许用户添加曲线场景（请注意，为简化 MWE，此第三个矩阵当前不水平扩展）。

矩阵在一个方向上链接：第一个矩阵中的值输入第二个矩阵，第二个矩阵输入第三个矩阵，最后一个矩阵在所有计算中优先。（请注意，由于我尚未下载补丁的 shinyMatrix 包中的一个小错误，可扩展矩阵的任何输入可能必须从右到左）。

MWE中矩阵1的id是flatInput，矩阵2是curveBaseRate，矩阵3是curveBaseRateAdd.

我遇到的问题是，如果第二个矩阵发生变化（添加了任何行），它不会正确反映在第三个矩阵中（如底部的第三张图片所示）。如果第二个矩阵未更改而仅显示，则第二个矩阵正确地馈入第三个矩阵（如底部的第二个图像所示）。这怎么能解决？我相信我在模态对话框中呈现的矩阵 3 中对矩阵 2 row/column 的引用有问题（行 input$curveBaseRate[,1] 和 input$curveBaseRate[,2]，但我不知道我在做什么错了。

MWE 代码：

library(shiny);library(shinyMatrix);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("Base", "Spread")

xDflt <- .05 # << default value for x column of input matrix
yDflt <- .01  # << default value for y column of input matrix

flatRate <- function(inputId,x,y){
  matrixInput(inputId, 
              value = matrix(c(x,y), 1, 1, dimnames = list(c("Base rate"),NULL)),
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")
} 

curveRate <- function(inputId,w,x,y){
  matrixInput(inputId,
              label = w,
              value = matrix(c(x,y),1,2,dimnames=list(NULL,c("Period (X)","Curved (Y)"))),
              rows =  list(extend = TRUE,  names = FALSE),
              cols =  list(extend = FALSE, names = TRUE, 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;}"
      ))
    ),
    titlePanel("Model"),
    sidebarLayout(
      sidebarPanel(uiOutput("Panel")),
      mainPanel(tabsetPanel(tabPanel("Rates", value=2),id = "tabselected"))
    ) 
  ) 

server <- function(input,output,session)({
  output$Panel <- renderUI({
      conditionalPanel(
          condition = "input.tabselected == 2",
          useShinyjs(),
          helpText("Modeled periods (X):"),
          sliderInput('periods','',min=2,max=120,value=60),
          helpText("Initial rates (Y):"),
          flatRate("flatInput",xDflt,yDflt), 
          helpText("Generate curves (Y|X):"),
          tableOutput("checkboxes"),
          hidden(uiOutput("curveBaseRate")),
          actionButton("addScenarios","Add scenarios")
      )
  }) 
  
  ### Begin checkbox matrix ###
  output[["checkboxes"]] <- 
    renderTable({tbl}, 
                rownames = TRUE, align = "c",
                sanitize.text.function = function(x) x
    )
  
  observeEvent(input[["show1"]], {
    if(input[["show1"]]){
      shinyjs::show("curveBaseRate")
    } else {
      shinyjs::hide("curveBaseRate")
    }
  })
  ### End checkbox matrix ###
  
  output$curveBaseRate <- renderUI({
    req(input$periods,input$flatInput)
    input[["reset1"]]
    curveRate("curveBaseRate",
              "Base rates curve (Y|X):",
              input$periods,
              input$flatInput[1,1])
  })
  
  outputOptions(output, "curveBaseRate", suspendWhenHidden = FALSE)
  
  observeEvent(input$addScenarios, {
    showModal(
      modalDialog(
        curveRate("curveBaseRateAdd",
                  "Base rates curve (Y|X):",
                  input$curveBaseRate[,1],
                  input$curveBaseRate[,2]),
        footer =  modalButton("Close")
      ))
  }) 
  
}) 

shinyApp(ui, server)

解释性图片：

第一张图片显示第一个用户输入矩阵。
第二张图片显示了正确呈现的第二个用户输入矩阵（点击“显示”后）在模态对话框中输入第三个用户输入矩阵，没有用户更改第二个输入矩阵。
第三张图片显示在用户对第二个输入矩阵进行更改后，模态对话框中第三个输入矩阵的渲染不正确。

Answer 1

在上面的代码中，您只传递了第二个矩阵的前两列：

          input$curveBaseRate[,1],
          input$curveBaseRate[,2])

老实说，我会去掉所有未至少调用两次的自定义函数（否则没有附加值 - 只会造成混淆）。

请检查以下内容：

library(shiny);library(shinyMatrix);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("Base", "Spread")

xDflt <- .05 # << default value for x column of input matrix
yDflt <- .01  # << default value for y column of input matrix

flatRate <- function(inputId,x,y){
  matrixInput(inputId, 
              value = matrix(c(x,y), 1, 1, dimnames = list(c("Base rate"),NULL)),
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")
} 

curveRate <- function(inputId,w,x,y){
  matrixInput(inputId,
              label = w,
              value = matrix(c(x,y),1,2,dimnames=list(NULL,c("Period (X)","Curved (Y)"))),
              rows =  list(extend = TRUE,  names = FALSE),
              cols =  list(extend = FALSE, names = TRUE, 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;}"
      ))
    ),
    titlePanel("Model"),
    sidebarLayout(
      sidebarPanel(uiOutput("Panel")),
      mainPanel(tabsetPanel(tabPanel("Rates", value=2),id = "tabselected"))
    ) 
  ) 

server <- function(input,output,session)({
  output$Panel <- renderUI({
    conditionalPanel(
      condition = "input.tabselected == 2",
      useShinyjs(),
      helpText("Modeled periods (X):"),
      sliderInput('periods','',min=2,max=120,value=60),
      helpText("Initial rates (Y):"),
      flatRate("flatInput",xDflt,yDflt), 
      helpText("Generate curves (Y|X):"),
      tableOutput("checkboxes"),
      hidden(uiOutput("curveBaseRate")),
      actionButton("addScenarios","Add scenarios")
    )
  }) 
  
  ### Begin checkbox matrix ###
  output[["checkboxes"]] <- 
    renderTable({tbl}, 
                rownames = TRUE, align = "c",
                sanitize.text.function = function(x) x
    )
  
  observeEvent(input[["show1"]], {
    if(input[["show1"]]){
      shinyjs::show("curveBaseRate")
    } else {
      shinyjs::hide("curveBaseRate")
    }
  })
  ### End checkbox matrix ###
  
  output$curveBaseRate <- renderUI({
    req(input$periods,input$flatInput)
    input[["reset1"]]
    curveRate("curveBaseRate",
              "Base rates curve (Y|X):",
              input$periods,
              input$flatInput[1,1])
  })
  
  outputOptions(output, "curveBaseRate", suspendWhenHidden = FALSE)
  
  observeEvent(input$addScenarios, {
    showModal(
      modalDialog(
        matrixInput(inputId = "curveBaseRateAdd",
                    label = "Base rates curve (Y|X):",
                    value = input$curveBaseRate,
                    rows =  list(extend = TRUE,  names = FALSE),
                    cols =  list(extend = FALSE, names = TRUE, editableNames = FALSE),
                    class = "numeric"),
        footer =  modalButton("Close")
      ))
  }) 
  
}) 

shinyApp(ui, server)

使用 do.call 的示例 - 请参阅 flatInputArgs

library(shiny);library(shinyMatrix);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("Base", "Spread")

xDflt <- .05 # << default value for x column of input matrix
yDflt <- .01  # << default value for y column of input matrix

flatInputArgs <- list(inputId = "flatInput", 
            value = matrix(c(xDflt,yDflt), 1, 1, dimnames = list(c("Base rate test"),NULL)),
            rows =  list(extend = FALSE, names = TRUE),
            cols =  list(extend = FALSE, names = FALSE, editableNames = FALSE),
            class = "numeric")

curveRate <- function(inputId,w,x,y){
  matrixInput(inputId,
              label = w,
              value = matrix(c(x,y),1,2,dimnames=list(NULL,c("Period (X)","Curved (Y)"))),
              rows =  list(extend = TRUE,  names = FALSE),
              cols =  list(extend = FALSE, names = TRUE, 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;}"
      ))
    ),
    titlePanel("Model"),
    sidebarLayout(
      sidebarPanel(uiOutput("Panel")),
      mainPanel(tabsetPanel(tabPanel("Rates", value=2),id = "tabselected"))
    ) 
  ) 

server <- function(input,output,session)({
  output$Panel <- renderUI({
    conditionalPanel(
      condition = "input.tabselected == 2",
      useShinyjs(),
      helpText("Modeled periods (X):"),
      sliderInput('periods','',min=2,max=120,value=60),
      helpText("Initial rates (Y):"),
      do.call(matrixInput, flatInputArgs),
      helpText("Generate curves (Y|X):"),
      tableOutput("checkboxes"),
      hidden(uiOutput("curveBaseRate")),
      actionButton("addScenarios","Add scenarios")
    )
  }) 
  
  ### Begin checkbox matrix ###
  output[["checkboxes"]] <- 
    renderTable({tbl}, 
                rownames = TRUE, align = "c",
                sanitize.text.function = function(x) x
    )
  
  observeEvent(input[["show1"]], {
    if(input[["show1"]]){
      shinyjs::show("curveBaseRate")
    } else {
      shinyjs::hide("curveBaseRate")
    }
  })
  ### End checkbox matrix ###
  
  output$curveBaseRate <- renderUI({
    req(input$periods,input$flatInput)
    input[["reset1"]]
    curveRate("curveBaseRate",
              "Base rates curve (Y|X):",
              input$periods,
              input$flatInput[1,1])
  })
  
  outputOptions(output, "curveBaseRate", suspendWhenHidden = FALSE)
  
  observeEvent(input$addScenarios, {
    showModal(
      modalDialog(
        matrixInput(inputId = "curveBaseRateAdd",
                    label = "Base rates curve (Y|X):",
                    value = input$curveBaseRate,
                    rows =  list(extend = TRUE,  names = FALSE),
                    cols =  list(extend = FALSE, names = TRUE, editableNames = FALSE),
                    class = "numeric"),
        footer =  modalButton("Close")
      ))
  }) 
  
}) 

shinyApp(ui, server)

在 R Shiny 中，如何正确 link 矩阵值？

In R Shiny, how to correctly link matrix values?

r

matrix

shiny

shiny-reactivity