R Shiny/RHandsontable：尝试实时读取和更新同一个 RHandsontable

Question

我正在尝试创建一个 RShiny 页面来帮助进行一些模糊匹配，并允许用户确认匹配是否正确。正在显示的表格有几列，其中最重要的是列表 A 中的名称、列表 B 中的潜在匹配名称以及末尾的 True/False 列。理想情况下，当匹配被确认为正确时，我希望表更新 - 不仅仅是将该行标记为正确匹配，而是查找包含该项目的潜在匹配的其他行并将它们删除（或者，在这种情况下, 将它们的高度降低到 0.5)。我希望它看起来像选项折叠以仅在选择匹配的一个时显示匹配的一个，并且在用户错误的情况下，如果所选行不匹配，则显示其余行。

除了条件格式之外，我目前正在使用它（以一种或另一种形式）。脚本如下。

任何想法或帮助将不胜感激！

library(tidyverse)
library(rhandsontable)
library(shiny)


test_DF <- data.frame("ID" = 1:10, 
                      "list A Code" = c("1001", "1001", "1003", "1003", "1003", "1006", "1006", "1007", "1008", "1010"), 
                      "List A Item" = c("Olive Oil", "Olive Oil", "Tomato Sauce", "Tomato Sauce", "Tomato Sauce", "Dried Pasta", "Dried Pasta", "Oregano", "Pesto", "Garlic Bulb"), 
                      "List B Code" = c("2001", "2002", "2003", "2004", "2005", "2006", "2007", "2008", "2009", "2010"),
                      "List B Item" = c("Olive Oil", "Olives", "Tomato", "Tomato Sauce", "Pasta Sauce", "Dried Pasta", "Fresh Pasta", "Oregano", "Pesto", "Garlic Bulb"),
                      "Correct Match" = FALSE)


ui<-(fluidPage(
  fluidRow(
    titlePanel(
      h1("food item potential matches", align = "center")),
    sidebarPanel(
      actionButton("saveBtn", "All matches identified")),
    mainPanel(
      rHandsontableOutput("table", height = "500px"),
      br()
      
      
    )
  )
))
server<-(function(input,output,session){
  
  # returns rhandsontable type object - editable excel type grid data
  output$table <- renderRHandsontable({
    output <- rhandsontable(test_DF) %>%
      hot_col(1:5, readOnly = TRUE) #Outputs the table, and makes it so that only the True/False column is editable

    
    matched_codes <- output$table[,2][output$table[,6] == TRUE] #Creates a list of list A codes that have been successfully matched
    
    incorrect_match_rows <- output$table[,1][output$table$list.A.Code %in% matched_codes & output$table$Correct.Match == FALSE]
    
    if(length(matched_codes>0)) {
      print("matches made") #This is just me trying to test if it gets this far
      for (incorrect_row in incorrect_match_rows) {
        output <- output %>% hot_rows(incorrect_row, rowHeights=0.5) #making the rows to be removed 0.5 in height
      }
    }
    output
    #https://stackoverflow.com/questions/62816744/rhandsontable-using-a-dropdown-to-hide-columns
    
  })
  
  # on click of button the file will be saved to the working directory
  observeEvent(input$saveBtn, {
    write.csv(isolate(hot_to_r(input$table)), file = "Fuzzy_matches.csv", row.names = FALSE)
    print("requirements met")
    stopApp()
  })
  # hot_to_r() converts the rhandsontable object to r data object
})

shinyApp(ui, server)

Answer 1

好的，我相信我现在已经找到了解决这个问题的方法。完整的功能并不是我想要的（即我仍然没有找到折叠行高的方法 - 相反，我将不正确的匹配项放在列表底部，将它们标记为红色，并将其设为唯一可编辑列不可编辑）。

我希望这可以帮助任何寻找类似东西的人！

library(tidyverse)
library(rhandsontable)
library(shiny)


test_DF <- data.frame("ID" = 1:10, 
                      "Pseudo_ID" = 1:10,
                      "list A Code" = c("1001", "1001", "1003", "1003", "1003", "1006", "1006", "1007", "1008", "1010"), 
                      "List A Item" = c("Olive Oil", "Olive Oil", "Tomato Sauce", "Tomato Sauce", "Tomato Sauce", "Dried Pasta", "Dried Pasta", "Oregano", "Pesto", "Garlic Bulb"), 
                      "List B Code" = c("2001", "2002", "2003", "2004", "2005", "2006", "2007", "2008", "2009", "2010"),
                      "List B Item" = c("Olive Oil", "Olives", "Tomato", "Tomato Sauce", "Pasta Sauce", "Dried Pasta", "Fresh Pasta", "Oregano", "Pesto", "Garlic Bulb"),
                      "Correct Match" = FALSE)


ui<-(fluidPage(
  fluidRow(
    titlePanel(
      h1("food item potential matches", align = "center")),
    sidebarPanel(
      actionButton("saveBtn", "All matches identified")),
    mainPanel(
      rHandsontableOutput("table", height = "500px"),
      br()
      
      
    )
  )
))
server<-(function(input,output,session){
  
  values <- reactiveValues(data = test_DF)
  observeEvent(input$table,{
    values$data<-as.data.frame(hot_to_r(input$table))
    
    matched_codes <- values$data[,3][values$data[,7] == TRUE] #Creates a list of list A codes that have been successfully matched
    print(matched_codes)
    incorrect_match_rows <- values$data[,1][values$data$list.A.Code %in% matched_codes & values$data$Correct.Match == FALSE]
    print(incorrect_match_rows)
    print(length(incorrect_match_rows)>0)
    print("matches made") #This is just me trying to test if it gets this far
    values$data$Pseudo_ID <- values$data$ID
    values$data$Pseudo_ID[which(values$data$ID %in% incorrect_match_rows)]<-NA
    values$data<-values$data[order(values$data$Pseudo_ID, na.last=TRUE),]
    print(values$data)
    
    output$table <- renderRHandsontable({
      rhandsontable(values$data)%>%
        hot_col(1:6, readOnly = TRUE) %>% #Outputs the table, and makes it so that only the True/False column is editable
        hot_col(1:2, width = 0.5) %>%
        hot_col(1:6, renderer = "
           function (instance, td, row, col, prop, value, cellProperties) {
             Handsontable.renderers.TextRenderer.apply(this, arguments);
             var ID = instance.getData()[row][0]
             var pseudoID = instance.getData()[row][1]
             if (ID !== pseudoID) {
              td.style.background = 'pink';
              cellProperties.rowheight = '1';
             }
           }") %>%
        hot_col(7, renderer = "
           function (instance, td, row, col, prop, value, cellProperties) {
             Handsontable.renderers.CheckboxRenderer.apply(this, arguments);
             var ID = instance.getData()[row][0]
             var pseudoID = instance.getData()[row][1]
             if (ID !== pseudoID) {
              td.style.background = 'pink';
              cellProperties.rowheight = '1';
              cellProperties.readOnly = true;
             }
           }")
      
    })
  })
  output$table <- renderRHandsontable({
    rhandsontable(values$data)%>%
      hot_col(1:6, readOnly = TRUE) %>% #Outputs the table, and makes it so that only the True/False column is editable
      hot_col(1:2, width = 0.5)
  })
  
  observeEvent(input$saveBtn, {
    write.csv(isolate(hot_to_r(input$table)), file = "Fuzzy_matches.csv", row.names = FALSE)
    print("requirements met")
    stopApp()
  })
})

shinyApp(ui, server)