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

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)