如何修改R Shiny代码实现matrixInput水平两列分组扩展

MWE Code 1 可实现用户输入值的响应式插值，但当前输入矩阵采用垂直向下扩展的形式，需要调整为向右水平扩展，且每2个值为一组用于插值。MWE Code 2 已实现两值成对、水平扩展的矩阵交互效果，但未覆盖MWE Code 1的完整功能。

注意：MWE Code 2 中两个待插值的输入值需配对归属到同一个“Scenario X”列标题下，该配对规则必须保留。MWE Code 2 给出了按两列一组遍历水平扩展矩阵的计算公式：trunc(1:ncol(mm)/2)+1。

修改MWE Code 1，将矩阵扩展方式从垂直改为和MWE Code 2一致的水平成对扩展。其中matrixInput参数调整难度较低，核心修改点是MWE Code 1中plotData <- reactive({…代码段里的lapply等处理逻辑。

MWE Code 1 #

library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)

interpol <- function(a, b) { # a = 插值周期数, b = 矩阵输入值
  c <- rep(NA, a)
  c[1] <- b[1]
  c[a] <- b[2]
  c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # 插值逻辑
  return(c)
}

ui <- fluidPage(
  sliderInput('periods','插值周期数:',min=2,max=10,value=10),
  matrixInput(
      "myMatrixInput",
      label = "待插值输入值 (myMatrixInput):",
      value =  matrix(c(1, 5), 1, 2, dimnames = list("场景1", c("值1", "值2"))),
      cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
      rows = list(names = TRUE,delete = TRUE, extend = TRUE, delta = 1),
      class = "numeric"),
  plotOutput("plot")
  )


server <- function(input, output, session) {
  
  sanitizedMat <- reactiveVal()
  
  observeEvent(input$myMatrixInput, {
    if(any(rownames(input$myMatrixInput) == "")){
      tmpMatrix <- input$myMatrixInput
      rownames(tmpMatrix) <- paste("场景", seq_len(nrow(input$myMatrixInput)))
      updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    }
    sanitizedMat(na.omit(input$myMatrixInput))
  })
  
  plotData <- reactive({
    req(dim(sanitizedMat())[1] >= 1)
    lapply(seq_len(nrow(sanitizedMat())),
           function(i){
             tibble(
               Scenario = rownames(sanitizedMat())[i],
               X = 1:input$periods,
               Y = interpol(input$periods, sanitizedMat()[i, 1:2])
             )
           }) %>% bind_rows()
  })
  
  output$plot <- renderPlot({
    req(nrow(plotData()) > 0)
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y,
      colour = as.factor(Scenario)
    ))
  })
}

shinyApp(ui, server)

MWE Code 2 #

ui <- fluidPage(
    
    sliderInput('input1','插值周期数(X):',min=2,max=12,value=6),
    matrixInput("input2",
                label = "在第二行空白单元格输入值即可新增插值场景:",
                value = matrix(c(1, 5), 1, 2, dimnames = list("起止值", c("场景1", ""))),
                rows =  list(names = TRUE),
                cols =  list(names = TRUE,
                             extend = TRUE,
                             delta = 2,
                             delete = TRUE,
                             multiheader=TRUE),
                class = "numeric"),
    actionButton("add","新增场景"),
    plotOutput("plot")
)

server <- function(input, output, session){
  
  results <- function(){interpol(req(input$input1),req(input$input2))}
  
  numScenarios <- reactiveValues(numS=1)
  
  observeEvent(input$add,{numScenarios$numS <- (numScenarios$numS+1)})
  
  observe({
    req(input$input2)
    mm <- input$input2
    colnames(mm) <- paste("场景 ", trunc(1:ncol(mm)/2)+1)
    isolate(updateMatrixInput(session, "input2", mm))
  })
  
  output$plot <-renderPlot({
    req(input$input1,input$input2)
    v <- lapply(
      1:numScenarios$numS,
      function(i) tibble(Scenario=i,X=1:input$input1,Y=results())
    ) %>%
      bind_rows()
    v %>% ggplot() + 
      geom_line(aes(x=X, y=Y, colour=as.factor(Scenario)))  +
      geom_point(aes(x=X, y=Y))
  })
  
}

shinyApp(ui, server)

library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)

interpol <- function(a, b) { # a = 插值周期数, b = 成对的输入起止值
  c <- rep(NA, a)
  c[1] <- b[1]
  c[a] <- b[2]
  c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y
  return(c)
}

ui <- fluidPage(
  sliderInput('periods','插值周期数:',min=2,max=10,value=10),
  matrixInput(
    "myMatrixInput",
    label = "待插值输入值（空白列输入值即可新增场景）:",
    value = matrix(c(1, 5), nrow = 1, ncol = 2, 
                   dimnames = list("起止值", c("场景 1", ""))),
    cols = list(extend = TRUE, names = TRUE, editableNames = FALSE, 
                delta = 2, delete = TRUE, multiheader = TRUE),
    rows = list(extend = FALSE, names = TRUE, editableNames = FALSE),
    class = "numeric"
  ),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  sanitizedMat <- reactiveVal()
  
  # 处理矩阵列名，自动配对生成场景名
  observeEvent(input$myMatrixInput, {
    req(input$myMatrixInput)
    tmpMatrix <- input$myMatrixInput
    # 按两列一组生成场景名
    colnames(tmpMatrix) <- paste("场景", trunc(1:ncol(tmpMatrix)/2) + 1)
    # 过滤掉包含NA的无效列组
    valid_cols <- which(apply(tmpMatrix, 2, function(x) !all(is.na(x))))
    valid_groups <- unique(trunc((valid_cols - 1)/2) + 1)
    keep_cols <- unlist(lapply(valid_groups, function(g) c(2*g-1, 2*g)))
    tmpMatrix <- tmpMatrix[, keep_cols, drop = FALSE]
    updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    sanitizedMat(tmpMatrix)
  })
  
  plotData <- reactive({
    req(sanitizedMat())
    mat <- sanitizedMat()
    # 计算场景总数：总列数/2
    scenario_cnt <- ncol(mat)/2
    req(scenario_cnt >= 1)
    
    lapply(seq_len(scenario_cnt), function(i){
      # 提取当前场景对应的两个输入值
      start_end_vals <- mat[1, c(2*i - 1, 2*i)]
      tibble(
        Scenario = paste("场景", i),
        X = 1:input$periods,
        Y = interpol(input$periods, start_end_vals)
      )
    }) %>% bind_rows()
  })
  
  output$plot <- renderPlot({
    req(plotData())
    plotData() %>% ggplot() + 
      geom_line(aes(x = X, y = Y, colour = Scenario)) +
      geom_point(aes(x = X, y = Y)) +
      labs(colour = "场景")
  })
}

shinyApp(ui, server)

1. 调整matrixInput参数：关闭行扩展、开启列扩展，设置每次扩展新增2列，开启多表头实现两列同属一个场景名的效果
2. 修改矩阵预处理逻辑：从修改行名改为按两列一组自动生成场景名，过滤无效的空值列组
3. 重写plotData中的遍历逻辑：从遍历矩阵行改为遍历场景数，每个场景提取对应两列的起止值传入插值函数

内容的提问来源于stack exchange，提问作者Curious Jorge - user9788072