R Shiny/RHandsontable：嘗試實時讀取和更新同一個 RHandsontable

Question

我正在嘗試創建一個 RShiny 頁面來幫助進行一些模糊匹配，並允許用戶確認匹配是否正確。 顯示的表格有幾列，其中最重要的是列表 A 中的名稱、列表 B 中可能匹配的名稱以及末尾的 True/False 列。 理想情況下，當匹配項被確認為正確時，我希望表進行更新 - 不僅僅是將行標記為正確匹配項，而是查找包含該項目潛在匹配項的其他行並將它們刪除（或者，在這種情況下, 將它們的高度降低到 0.5)。 我希望它看起來像選項折疊以僅在選擇匹配的一個時顯示匹配的一個，並且，如果用戶錯誤，如果所選行不匹配，則會出現 rest 行。

除了條件格式之外，我目前還可以使用它（以一種或另一種形式）。 腳本如下。

任何想法或幫助將不勝感激！

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)