DataTable not diplaying correctly after being updated

Question

This question is a continuation of my previous one about Re-binding the SelectInput of a DataTable after being updated.

So, I made quite some progress on this app and I have reached a result that perfectly fits my needs. The app correctly updates the target database and the selectInputs as well as the filter are intuitive and user-friendly enought for what I seek.

There is however one issue, not a critical one but still rather annoying. When the "Update Data" button is clicked on and the underlying data is updated, the displayed datatable acts as if there where no category selected in the filter and returns an empty table. This issue is fixed the moment a modification is made on the filtered categories through the filter button and it doesn't stop the database to be correctly updated, but this is not an expected behaviour.

What is weird is that it seems to be caused by the the virtualSelectInput filter and not the fact that the underlying is filtered, because when I filter it directly in the code, it works just fine. Well aside from the fact that when doing the latter options, if the "Update Data" button is clicked on while no SelectInput has been changed, it will not trigger any update after that even if a SelectInput was later on changed to another value, whereas it works as intended as long as a SelectInput has been changed vefore each time the "Update Data" button has been triggered.

I suspect those two issues to be related one way or another. Is there something that I missed or mishandled ?

Below are the records of the issues :

• Issue where the DataTable is empty after an update, but display the change after resetting the filters

• Without the virtualSelectInput acting as a filter (expected behaviour)

• Without the virtualSelectInput acting as a filter, but without changing a SelectInput before updating a first time (cannot update a change after that)

Edit

You can now run the code without setting up the database beforehand, making the error reproduci with the following R code alone

Here is the code used to create the app :

### Libraries

{
  library(shiny)            # used to create the Shiny App
  library(bslib)            # used to create the framework of the Shiny App
  library(shinyWidgets)     # used to create various widgets
  
  library(RMySQL)           # used to create and access the Database
  
  library(tidyverse)        # used for many things (mainly data manipulation)
  library(DT)               # used for creating interactive DataTable
}

### JS Module
# Unbinds the Select Input ids when "Update Data" is clicked

js <- c(
  "$('#updateButton').on('click', function() {",
  "  Shiny.unbindAll(table.table().node());",
  "});"
)


# Initialize the dummy database
divinite_data <- tibble(
  ID = 1:11,
  Divinite = c("Quetzalcoatl", "Odin", "Ra", "Zeus", "Tiamat", "Isis", "Hades", "Thot", "Thor", "Persephone", "Amatsu"),
  ID_pantheon = c(5, 3, 2, 8, 4, 10, rep(0, 5))
)

pantheon_data <- tibble(
  id_pantheon = c(0:12),
  nom_pantheon = c("Non Défini", "Grec", "Egyptien", "Nordique", "Sumerien", "Azteque", "Japonais", rep(c("Mineure", "Majeure"), 3)),
  id_parent = c(rep(NA, 7), rep(1:3, each = 2))
)

con <- dbConnect(drv = RSQLite::SQLite(), 
                 dbname = ":memory:")

dbWriteTable(conn = con, 
             name = "Z_TEST",
             value = divinite_data)

dbWriteTable(conn = con, 
             name = "Z_TEST2",
             value = pantheon_data)


### Queries

QDisplay <- "
  SELECT ID, Divinite, 
  Z_TEST.ID_pantheon AS ID_Panth, PT1.id_parent AS ID_Panth_parent, PT1.nom_pantheon AS Pantheon, PT2.nom_pantheon AS Panth_parent
  
  FROM Z_TEST
  LEFT JOIN Z_TEST2 AS PT1 ON Z_TEST.ID_pantheon = PT1.id_pantheon
  LEFT JOIN Z_TEST2 AS PT2 ON PT2.id_pantheon = PT1.id_parent;
"

QGetID <- "
  SELECT id_pantheon AS ID_Panth
  FROM Z_TEST2 
  WHERE nom_pantheon = '%s'
"

QGetIDIfParent <- "
  SELECT PT1.id_pantheon AS ID_Panth
  FROM Z_TEST2 AS PT1
  LEFT JOIN Z_TEST2 AS PT2 ON PT2.id_pantheon = PT1.id_parent
  WHERE PT1.nom_pantheon = '%s'AND PT2.nom_pantheon = '%s'
"

QEdit <- "
  UPDATE Z_TEST
  SET ID_pantheon = %d
  WHERE ID = %d
"

QRef <- "
  SELECT PT1.id_pantheon AS ID_Panth, PT1.nom_pantheon AS Panth_nom, PT1.id_parent AS ID_Panth_parent, PT2.nom_pantheon AS Panth_nom_parent
  FROM Z_TEST2 AS PT1
  LEFT JOIN Z_TEST2 AS PT2 ON PT2.id_pantheon = PT1.id_parent
"


### Useful functions

# Create levels to choose from in the Select Input
factorOptions <- function(factor_levels) {
  optionList <- ""
  for (i in factor_levels) {
    optionList <- paste0(optionList, '<option value="', i, '">', i, '</option>\n')}
  
  return(optionList)
}

# Create the Select Input with ID and corresponding entry from the joined table
mySelectInput <- function(id_list, selected_factors, factor_levels) {
  select_input <- paste0('<select id="single_select_', id_list, '"style="width: 100%;">\n', 
                         sprintf('<option value="%s" selected>%s</option>\n', selected_factors, selected_factors), 
                         factorOptions(factor_levels), '</select>')
  return(select_input)
}

# Get the reference levels for the Select Input and Filter
dt_panth_ref <- dbGetQuery(con, QRef) %>% as_tibble() %>% 
  mutate(unique_libelle = ifelse(is.na(Panth_nom_parent), Panth_nom, paste0(Panth_nom_parent, " / ", Panth_nom)), 
         Categorie = ifelse(is.na(Panth_nom_parent), Panth_nom, Panth_nom_parent))

# Preset options for the displayed table
displayTable <- function(data) {
  displayed_table <- datatable(
    data = data    , 
    selection = 'none', escape = FALSE, rownames = FALSE, editable = list(target = 'cell', disable = list(columns = c(0:6))),
    callback = JS(js), extensions = "KeyTable",
    options = list(
      keys = TRUE,
      pageLength = 15,
      preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
      drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
    )
  )
  return(displayed_table)
}


### Shiny App

ui <- page_sidebar(
  sidebar = card_body(
    virtualSelectInput(
      inputId = "idFilter",
      label = "Filtre :",
      choices = prepare_choices(
        dt_panth_ref,
        label = Panth_nom,
        value = ID_Panth,
        group_by = Categorie
      ),
      multiple = TRUE,
      selected = 0:12,
      width = "100%",
      dropboxWrapper = "body"
    ), br(),
    actionButton("updateButton", "Update Data")
  ),
  card(DTOutput("interactiveTable"))
)

server <- function(input, output, session) {
  # Fetch the underlying data
  panth_data <- reactiveVal()
  observe(panth_data(dbGetQuery(con, QDisplay) %>% as_tibble() %>% replace_na(list(Pantheon = "Non Défini")) %>% 
                       mutate(unique_libelle = ifelse(is.na(Panth_parent), Pantheon, paste0(Panth_parent, " / ", Pantheon))) %>%
                       filter(ID_Panth %in% input$idFilter)
  ))
  
  # Initialize the DataTable
  output$interactiveTable <- renderDT({
    filt_panth <- panth_data() %>% filter(ID_Panth %in% input$idFilter)
    
    if (nrow(filt_panth) > 0) {
      displayTable(data = filt_panth %>% mutate(Select_Pantheon = mySelectInput(ID, unique_libelle, dt_panth_ref %>% pull(unique_libelle))))
    } else {
      displayTable(data = filt_panth %>% mutate(Select_Pantheon = NA))
    }
  })
  
  observeEvent(input$updateButton, {
    rows_filtered <- input$interactiveTable_rows_all
    rows_displayed <- rows_filtered[1:min(length(rows_filtered), input$interactiveTable_state$length)]
    
    # Fetch the corresponding ID of the selected gamme and update the database
    for (h in panth_data()$ID[rows_displayed]) {
      h_input <- as.character(input[[paste0("single_select_", h)]])
      current_h <- filter(panth_data(), ID == h)$unique_libelle
      
      if (h_input != current_h) {
        split_input <- str_split(h_input, " / ")[[1]]
        
        if (length(split_input) == 1) {
          i <- dbGetQuery(con, sprintf(QGetID, split_input))$ID_Panth
        } else {
          i <- dbGetQuery(con, sprintf(QGetIDIfParent, split_input[2], split_input[1]))$ID_Panth
        }
        
        dbGetQuery(con, sprintf(QEdit, i, h))
      }
    }
    
    # Update the underlying data
    observe(
      panth_data(dbGetQuery(con, QDisplay) %>% as_tibble() %>% replace_na(list(Pantheon = "Non Défini")) %>% 
                   mutate(unique_libelle = ifelse(is.na(Panth_parent), Pantheon, paste0(Panth_parent, " / ", Pantheon))) %>% 
                   filter(ID_Panth %in% input$input$idFilter)
      ))
  })
  
  session$onSessionEnded(function() {
    dbDisconnect(con)
    stopApp()})
}


shinyApp(ui, server)