r shiny：rhandsontable 列根据其他用户更新的列自动更新

Question

用户首先选择一个值。基于它，rhandsontable 出现了多个空列，带有下拉选项 - 除了最后一列，Type_action。此列为只读，应根据 Y 列和 Z 列中的值自动更新，如下所示：如果 Y 列中的值小于 Z 列中的值，Type_action 应取值“Upgrade”，否则，值“降级”。

低于我的尝试，未能为 Type_action 列生成任何值：

library(shiny)
library(rhandsontable)
library(dplyr)
library(shinydashboard)

ui <-  fluidPage( fluidRow(column(6, uiOutput("selA"))),
                  fluidRow(column(6, rHandsontableOutput('tbl1'))
           ) 
      ) 


server <- function(input, output, session){

  dt0 <- data.frame( A = c("S2","S2","S2","S4","S4","S4"),
                     B = c("1","2","3","1","2","3"),
                     C = c(10,20,30,40,15,25),
                     D  = c("A","B","C","D","E","F"))

# get the data for the selected BA
dt <- reactive(subset(dt0, A %in% input$selA))

# Render selectInput selBA
output$selA <- renderUI({
   ba <- as.vector( unique(dt0$A) )
   selectInput("selA","Choose BA", choices = ba)    
})

DF <- data.frame("X" = c(""),
               "Y" = c(""),
               "Z" = c(""),
               "Type_action" = c(""))

 values <- reactiveValues(data = DF)
 Y      <- reactiveVal()
 Z      <- reactiveVal()

observe({
 if(!is.null(input$tbl1)){
   values$data <- as.data.frame(hot_to_r(req(input$tbl1)))
    }
})

observeEvent(input$tbl1,{
       Y(hot_to_r(input$tbl1)$Y)},
       ignoreInit= TRUE
)

observeEvent(input$tbl1,{
   Z(hot_to_r(input$tbl1)$Z)}, 
   ignoreInit= TRUE
)

output$tbl1 = renderRHandsontable({
  req(input$selA)

  tmpTable <- rhandsontable(values$data, rowHeaders = FALSE, selectCallback = TRUE, width = 
                            1000, height = 500) %>% 
              hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>% 
              hot_col(col = "X", type = "dropdown", colWidths = 90, source = 
                       sort(unique(dt()$B))) %>% 
              hot_col(col = "Y", type = "dropdown", colWidths = 65, source = 
                      sort(unique(dt()$D))) %>% 
              hot_col(col = "Z", type = "dropdown", colWidths = 60,source = 
                      sort(unique(dt()$D))) %>% 
              hot_col(col = "Type_action", colWidths = 50, readOnly = TRUE, type = "text")  


 if(!is.null(input$tbl1_select$select$r) && !is.na(values$data$Y[input$tbl1_select$select$r]) 
  && !is.na(values$data$Z[input$tbl1_select$select$r])){
   tmpTable <- hot_col(tmpTable,col = "Type_action", type = "text", colWidths = 60, 
                      source = ifelse(as.numeric(factor(Y())) < as.numeric(factor(Z())),"u","d"))  
                       
  }
 tmpTable
 })
}

shinyApp(ui, server)

Answer 1

hot_col 的 source 参数需要

a vector of choices for select, dropdown and autocomplete column types

它没有实现修改文本单元格的内容（正如您在上面的代码中尝试的那样）。

我们可以通过更改底层（反应式）来修改文本列 data.frame。

请检查以下内容：

library(shiny)
library(rhandsontable)
library(dplyr)
library(shinydashboard)

ui <-  fluidPage( fluidRow(column(6, uiOutput("selA"))),
                  fluidRow(column(6, rHandsontableOutput('tbl1'))
                  ) 
) 


server <- function(input, output, session){
  
  dt0 <- data.frame( A = c("S2","S2","S2","S4","S4","S4"),
                     B = c("1","2","3","1","2","3"),
                     C = c(10,20,30,40,15,25),
                     D  = c("A","B","C","D","E","F"))
  
  # get the data for the selected BA
  dt <- reactive(subset(dt0, A %in% input$selA))
  
  # Render selectInput selBA
  output$selA <- renderUI({
    ba <- as.vector( unique(dt0$A) )
    selectInput("selA","Choose BA", choices = ba)    
  })
  
  DF <- data.frame("X" = c(""),
                   "Y" = c(""),
                   "Z" = c(""),
                   "Type_action" = c(""))
  
  values <- reactiveValues(data = DF)
  Y      <- reactiveVal()
  Z      <- reactiveVal()
  
  observe({
    if(!is.null(input$tbl1)){
      values$data <- as.data.frame(hot_to_r(req(input$tbl1)))
    }
  })
  
  observeEvent(input$tbl1,{
    Y(hot_to_r(input$tbl1)$Y)},
    ignoreInit= TRUE
  )
  
  observeEvent(input$tbl1,{
    Z(hot_to_r(input$tbl1)$Z)}, 
    ignoreInit= TRUE
  )
  
  output$tbl1 = renderRHandsontable({
    req(input$selA)
    
    tmpTable <- rhandsontable(values$data, rowHeaders = FALSE, selectCallback = TRUE, width = 
                                1000, height = 500) %>% 
      hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>% 
      hot_col(col = "X", type = "dropdown", colWidths = 90, source = 
                sort(unique(dt()$B))) %>% 
      hot_col(col = "Y", type = "dropdown", colWidths = 65, source = 
                sort(unique(dt()$D))) %>% 
      hot_col(col = "Z", type = "dropdown", colWidths = 60,source = 
                sort(unique(dt()$D))) %>% 
      hot_col(col = "Type_action", colWidths = 50, readOnly = TRUE, type = "text")  
    
    
    if(!is.null(input$tbl1_select$select$r) && !is.na(values$data$Y[input$tbl1_select$select$r]) 
       && !is.na(values$data$Z[input$tbl1_select$select$r])){
      values$data$Type_action <- ifelse(match(Y(), LETTERS) < match(Z(), LETTERS),"Upgrade","Downgrade")
      
    }
    tmpTable
  })
}

shinyApp(ui, server)

r shiny：rhandsontable 列根据其他用户更新的列自动更新

r shiny: rhandsontable column automatically updating based on other user updated columns

shiny

rhandsontable