R rhandsontable renderer does not follow column sorting despite being reactive

Question

I am working in a shiny app that displays a rhandsontable. I use a "renderer" to customize cell color and border. In addition, I would like to allow the user to perform column sorting. Here is my problem: when columns are sorted, the borders and the colors defined in the renderer do not follow the sorting. Indeed, they stay at the same position in the table, despite their coordinates are computed in a reactive code block. It looks like the sorting is not detected as a "trigger" of the reactive part. See for example the dummy reproducible example here below:

library(rhandsontable)
library(shiny)
border_width <- 4
border_col <- "green"
ui <- fluidPage(
  rHandsontableOutput('table'),
)
server <- function(input, output) {
  get_data <- reactive({
    if(is.null(input$table)) {
      show_dt <- mtcars
      show_dt[,"cyl4"] <- show_dt$cyl == 4
    } else {
      show_dt <- hot_to_r(input$table)
      show_dt[,"cyl4"] <- as.logical(show_dt[,"cyl4"])
    }
    return(show_dt)
  })
  output$table <- rhandsontable::renderRHandsontable({
    show_dt <- get_data() 
    row_highlight <- which( show_dt$cyl == 4)
    rows21 <- which(show_dt$mpg > 30) - 1
    col21 <- which(colnames(show_dt) == "mpg") -1 
    mycells <- list()
    for(i in seq_along(rows21)) {
      mycells[[i]] <- list(
        range = list(from = list(row = rows21[i], col = col21),
                     to = list(row = rows21[i], col = col21)),
        top = list(width = border_width, color = border_col),
        left = list(width = border_width, color = border_col),
        bottom = list(width = border_width, color = border_col),
        right = list(width = border_width, color = border_col))
    }
    rhandsontable(show_dt, height = 500, row_highlight=row_highlight-1) %>%
      hot_cols(columnSorting = TRUE) %>%
      hot_cols(renderer = "
            function(instance, td, row, col, prop, value, cellProperties) {
                Handsontable.renderers.TextRenderer.apply(this, arguments);
                if (instance.params) {
                    hrows = instance.params.row_highlight
                    hrows = hrows instanceof Array ? hrows : [hrows]
                }
                if (instance.params && hrows.includes(row)) td.style.background = '#FFC5C5';
            }")  %>%  hot_col(col = "cyl4",
                              renderer = "
              function (instance, td, row, col, prop, value, cellProperties) {
                  Handsontable.renderers.CheckboxRenderer.apply(this, arguments);
                  if (value) {
                      td.style.background = '#FFC5C5';
                  } else {
                   td.style.background = '#C3FA9A';
                  }
              }
          ") %>% hot_table(customBorders = mycells)
    
  })
}
shinyApp(ui, server)

Does anyone has an explanation why it does not work as expected ? Do you know how I could make the reactvive code block sensitive to column sorting (so that it re-calculates the correct positions upon sorting) ?

Answer 1

I could not find a way to make this work using the built-in functionality for rhandsontable. However, you can make this work with Javascript. You won't need any additional libraries. You will remove the R coding that creates the borders and highlights. If you don't, the Javascript I've written and rhandsontable will constantly fight even if you can't see it.

I've tried to add events to this type of table in the past, but rhandsontable loves to remove any non-native events. To get around that, I added an event that's based on a time interval instead.

The UI and libraries

library(rhandsontable)
library(shiny)

ui <- tagList(
  tags$head(
    tags$script(type="text/javascript", 
                HTML("function func(){
                        tbl1 = [...document.querySelectorAll('div#table div.wtSpreader table.htCore')][0];
                        cNames = tbl1.children[1].firstChild.children; /* getting column names */
                        cNames.forEach(function(val, i){
                          fc = val.firstChild.firstChild.innerHTML;
                          if(fc === 'mpg') {  /* for borders */
                            ind = i;
                          }
                          if(fc === 'cyl') {  /* for row highlights */
                            cind = i;
                          }
                        });
                        mpgs = [...document.querySelectorAll('div#table div.wtSpreader tbody tr')];
                        mpgs.forEach(function(val, j){        /* getting rows */
                          rs = mpgs[j].children;              /* getting cells */
                          cc = rs[cind].innerText;
                          hlt = false;                        /* default highlight false */
                          if(Number(cc) === 4){               /* if cyl == 4 highlight */
                            hlt = true;
                          }
                          rs.forEach(function(val, k){ 
                            if(rs[k].nodeName == 'TH'){       /* skip header column (row names)*/
                              return;
                            }
                            if(hlt){                          /* highlight */
                              rs[k].style.backgroundColor = '#FFC5C5';
                            }
                            if(rs[k] == rs[ind]){             /* add or remove borders */
                              cs = rs[k].innerText; /*literal cell value in mpg*/
                              console.log(cs + ' ' + Number(cs));
                              ans = Number(cs) > 10;
                              console.log('value greater than 10' + ans);
                              if(Number(cs) > 30){
                                rs[k].style.border = 'solid 4px green';
                              } else {
                                rs[k].style.border = 'solid 1px rgb(204, 204, 204)';
                              }
                            } else {
                              rs[k].style.border = 'solid 1px rgb(204, 204, 204)';
                            }
                          })
                        });
                      }")),
    tags$script(type = "text/javascript",
                HTML("setInterval(func, 500);"))),
  fluidPage(
    rHandsontableOutput('table'),
))

The updated server

server <- function(input, output) {
  get_data <- reactive({
    if(is.null(input$table)) {
      show_dt <- mtcars
      show_dt[,"cyl4"] <- show_dt$cyl == 4
    } else {
      show_dt <- hot_to_r(input$table)
      show_dt[,"cyl4"] <- as.logical(show_dt[,"cyl4"])
    }
    return(show_dt)
  })
  output$table <- rhandsontable::renderRHandsontable({
    show_dt <- get_data() 
    rhandsontable(show_dt, height = 500,
                  manualColumnMove = T
                  ) %>%
      hot_cols(columnSorting = TRUE) 
      }
  )
}
shinyApp(ui, server)