Shiny: Global Reactive Dataset

Question

I have a global data-frame (it would be defined in Global.R) that is constructed by querying a postgre database. This data-frame needs to be shared across multiple sessions.

Answer 1

Here is a working example:

library(shiny)
library(dplyr)
library(RSQLite)

# global data-frame
df <- data.frame(id = letters[1:10], decision = 0, another_col = LETTERS[1:10])
con <- dbConnect(RSQLite::SQLite(), "my.db", overwrite = FALSE)

if (!"df" %in% dbListTables(con)) {
  dbWriteTable(con, "df", df)
}

# drop global data-frame
rm("df")

update_decision_value <- function (id, dec) {
  dbExecute(con, sprintf("UPDATE df SET decision = '%s' WHERE id = '%s';", dec, id))
}

ui <- fluidPage(textOutput("shiny_session"),
                uiOutput('select_id'),
                uiOutput('decision_value'),
                dataTableOutput('my_table'))

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

  output$shiny_session <- renderText(paste("Shiny session:", session$token))

  session$onSessionEnded(function() {
    if (!is.null(con)) {
      dbDisconnect(con)
      con <<- NULL # avoid warning; sqlite uses single connection for multiple shiny sessions
    }
  })

  df_ini <- dbGetQuery(con, "SELECT id, decision FROM df;")
  all_ids <- df_ini$id

  df <- reactivePoll(
    intervalMillis = 100,
    session,
    checkFunc = function() {
      req(con)
      df_current <- dbGetQuery(con, "SELECT id, decision FROM df;")
      if (all(df_current == df_ini)) {
        return(TRUE)
      }
      else{
        df_ini <<- df_current
        return(FALSE)
      }
    },
    valueFunc = function() {
      dbReadTable(con, "df")
    }
  )

  filter.data <- reactive({
    df() %>%
      filter(decision == 0)
  })

  output$select_id <- renderUI({
    selectInput('selected_id', "ID:", choices = all_ids)
  })

  output$decision_value <- renderUI({
    radioButtons(
      'decision_value',
      "Decision Value:",
      choices = c("Display" = 0, "Hide" = 1),
      selected = df()[df()$id == input$selected_id, "decision"]
    )
  })

  output$my_table <- renderDataTable({
    filter.data()
  })

  observeEvent(input$decision_value, {
    update_decision_value(input$selected_id, input$decision_value)
  })
}

shinyApp(ui, server)

Edit ------------------------------------

Updated version which reduces load on the db by avoiding to compare the entire table and instead only searches shiny-session-wise unkown changes (taking into account a ms-timestamp, which is updated for every decision change):

library(shiny)
library(dplyr)
library(RSQLite)

# global data-frame
df <- data.frame(id = letters[1:10], decision = 0, last_mod=as.numeric(Sys.time())*1000, another_col = LETTERS[1:10])
con <- dbConnect(RSQLite::SQLite(), "my.db", overwrite = FALSE)

if (!"df" %in% dbListTables(con)) {
  dbWriteTable(con, "df", df)
}

# drop global data-frame
rm("df")

update_decision_value <- function (id, dec) {
  dbExecute(con, sprintf("UPDATE df SET decision = '%s', last_mod = '%s' WHERE id = '%s';", dec, as.numeric(Sys.time())*1000, id))
}

ui <- fluidPage(textOutput("shiny_session"),
                uiOutput('select_id'),
                uiOutput('decision_value'),
                dataTableOutput('my_table'))

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

  output$shiny_session <- renderText(paste("Shiny session:", session$token))

  session$onSessionEnded(function() {
    if (!is.null(con)) {
      dbDisconnect(con)
      con <<- NULL # avoid warning; sqlite uses single connection for multiple shiny sessions
    }
  })

  df_session <- dbReadTable(con, "df")
  all_ids <- df_session$id
  last_known_mod <- max(df_session$last_mod)

  df <- reactivePoll(
    intervalMillis = 100,
    session,
    checkFunc = function() {
      req(con)
      df_changed_rows <- dbGetQuery(con, sprintf("SELECT * FROM df WHERE last_mod > '%s';", last_known_mod))
      if(!nrow(df_changed_rows) > 0){
        return(TRUE)
      }
      else{
        changed_ind <- match(df_changed_rows$id, df_session$id)
        df_session[changed_ind, ] <<- df_changed_rows
        last_known_mod <<- max(df_session$last_mod)
        return(FALSE)
      }
    },
    valueFunc = function() {
      return(df_session)
    }
  )

  filter.data <- reactive({
    df() %>%
      filter(decision == 0)
  })

  output$select_id <- renderUI({
    selectInput('selected_id', "ID:", choices = all_ids)
  })

  output$decision_value <- renderUI({
    radioButtons(
      'decision_value',
      "Decision Value:",
      choices = c("Display" = 0, "Hide" = 1),
      selected = df()[df()$id == input$selected_id, "decision"]
    )
  })

  output$my_table <- renderDataTable({
    filter.data()
  })

  observeEvent(input$decision_value, {
    update_decision_value(input$selected_id, input$decision_value)
  })
}

shinyApp(ui, server)