Shiny: Global Reactive Dataset - r

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.
Now in the UI, of each session, I need to display a data table with the contents of this data frame. I also have a radioButton object so that the user can change the value of a field, call it decision in the data-frame for a given row, and I would like the corresponding line in the data table to be displayed or not (i.e. display the data-frame row as a line in the datatable if decision == 0 only)
Problem:
I would like the line in the datatable to be reactively hidden/displayed according to the value the user gives to decision and I would like that to happen across multiple sessions
So if there are 2 users and user_1 changes the value of decision for row a from 0 (displayed) to 1 (hidden), I would like that row to be reactively hidden in the datatables of BOTH user_1 AND user_2 without either of them having to refresh or press an actionButton.
What would be the best way to go about this?
Here's a minimal reproducible example:
library(shiny)
library(dplyr)
# global data-frame
df <<- data.frame(id = letters[1:10], decision = 0)
update_decision_value <- function (id, dec) {
df[df$id == id, "decision"] <<- dec
}
ui <- fluidPage(
uiOutput('select_id'),
uiOutput('decision_value'),
dataTableOutput('my_table')
)
server <- function(input, output, session) {
filter.data <- reactive({
df %>%
filter(decision == 0)
})
output$select_id <- renderUI({
selectInput('selected_id', "ID:", choices = df$id)
})
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)

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)