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

Question

The user selects first a value. Based on it, a rhandsontable appears with multiple, empty columns, with dropdown options - except for the last column, Type_action. This column, which is readOnly should be automatically updated based on values in columns Y and Z as follows: if the value in column Y is less than the value in column Z, Type_action should take value "Upgrade", otherwise, value "Downgrade".

Below my attempt, which fails to produce any value for the Type_action column:

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

The source argument of hot_col takes

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

it's not implemented to modify the content of a text cell (as you tried in the code above).

We can modify a text column by changing the underlying (reactive) data.frame.

Please check the following:

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)