如何删除除 header 列以外没有任何值的列？

Question

我运行下面的代码和下面我提供的屏幕截图显示了发生的情况：

第一张图片显示用户成功添加了2个额外的插值场景；一切都好。
第二张图片显示了当用户通过单击场景 2 输入矩阵列 header 中的 [x] 删除上面输入的场景 2 时发生的情况。查看弹出的绘图错误消息。
第三张图是用户点击上图中空白的“场景3”的[x]的结果；输入矩阵和绘图 re-render 正确。一切正常。

我正在尝试自动删除空列，这样用户就不需要执行上面 #3 中提到的额外删除步骤。

我尝试使用的代码是：

# Remove any empty matrix columns
      empty_columns <- sapply(tmpMatrix, function(x) all(is.na(x) | x == ""))
      tmpMatrix[, !empty_columns]

但问题是，它正在寻找要删除的完整空列。我需要对其进行修改，以便它查找忽略任何列 header 的空列。下面的第二张图片显示了我定位的此类列：列 header“场景 3”，但它下面的所有单元格都是空的。

有谁知道如何消除忽略 header 的空列？

请注意，如果我注释掉上面突出显示的 empty_columns <- 部分，这个问题就会消失，但是删除场景 2 时会出现新问题：场景 3 应该成为第二个场景，但它的列header 当它应该变成“场景 2”时仍然是“场景 3”！

代码：

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

interpol <- function(a, b) { # a = periods, b = matrix inputs
  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 # << interpolates
  return(c)
}

ui <- fluidPage(
  sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
  matrixInput(
    "myMatrixInput",
    label = "Values to interpolate paired under each scenario heading:",
    value =  matrix(c(1, 5), 1, 2, dimnames = list(NULL, c("Scenario 1", "NULL"))),
    cols = list(extend = TRUE,  delta = 2, names = TRUE,  delete = TRUE,  multiheader = TRUE),
    rows = list(extend = FALSE, delta = 1, names = FALSE, delete = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  sanitizedMat <- reactiveVal()
  
  observeEvent(input$myMatrixInput, {
    if(any(colnames(input$myMatrixInput) == "")){
      tmpMatrix <- input$myMatrixInput
      
      # Assign column header names
      colnames(tmpMatrix) <- paste("Scenario", trunc(1:ncol(input$myMatrixInput)/2+1))
      
      # Remove any empty matrix columns
      empty_columns <- sapply(tmpMatrix, function(x) all(is.na(x) | x == ""))
      tmpMatrix[, !empty_columns]
      
      updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    }
    else {sanitizedMat(na.omit(input$myMatrixInput))}
  })
  
  plotData <- reactive({
    lapply(seq_len(ncol(sanitizedMat())/2),
           function(i){
             tibble(
               Scenario = colnames(sanitizedMat())[i*2-1],
               X = 1:input$periods,
               Y = interpol(input$periods, sanitizedMat()[1,(i*2-1):(i*2)])
             )
           }) %>% bind_rows()
  })
  
  output$plot <- renderPlot({
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y,
      colour = as.factor(Scenario)
    ))
  })

}

shinyApp(ui, server)

Answer 1

Link 到这个 post Jan 完全解决了它。下面是完全解决这个问题的代码：

interpol <- function(a, b) { # a = periods, b = matrix inputs
  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 # << interpolates
  return(c)
}

ui <- fluidPage(
  sliderInput('periods', 'Periods to interpolate:', min=2, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Values to interpolate paired under each scenario heading:",
    value =  matrix(c(1, 5), 1, 2, dimnames = list(NULL, rep("Scenario 1", 2))),
    cols = list(extend = TRUE,  delta = 2, names = TRUE,  delete = TRUE, multiheader = TRUE),
    rows = list(extend = FALSE, delta = 1, names = FALSE, delete = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  observeEvent(input$myMatrixInput, {
    tmpMatrix <- input$myMatrixInput
    
    # Remove any empty matrix columns
    empty_columns <- sapply(tmpMatrix, function(x) all(is.na(x) | x == ""))
    tmpMatrix <- tmpMatrix[, !empty_columns, drop=FALSE]
    
    # Assign column header names
    colnames(tmpMatrix) <- paste("Scenario", rep(1:ncol(tmpMatrix), each = 2, length.out = ncol(tmpMatrix)))
    
    isolate( # isolate update to prevent infinite loop
      updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    )
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$myMatrixInput)/2),
             function(i){
               tibble(
                 Scenario = colnames(input$myMatrixInput)[i*2-1],
                 X = seq_len(input$periods),
                 Y = interpol(input$periods, input$myMatrixInput[1,(i*2-1):(i*2)])
               )
             }) %>% bind_rows(),
      error = function(e) NULL
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y,
      colour = as.factor(Scenario)
    ))
  })
  
}

shinyApp(ui, server)

如何删除除 header 列以外没有任何值的列？

How to remove a column that has no values other than the column header?

r

matrix

sapply

shiny