r语言 - Shiny:全局反应式数据集

Question

我有一个全局数据帧(它将在 Global.R 中定义(，它是通过查询 postgre 数据库构建的。此数据框需要在多个会话之间共享。

现在，在每个会话的 UI 中，我需要显示一个包含此数据框内容的数据表。我还有一个 radioButton 对象，以便用户可以更改字段的值，在给定行的数据框中decision调用它，并且我希望是否显示数据表中的相应行(即，如果仅decision == 0，将数据框行显示为数据表中的一行(

问题：我希望数据表中的行根据用户提供给decision的值被动隐藏/显示，我希望这在多个会话中发生

因此，如果有 2 个用户并且user_1将行a的decision值从 0(显示(更改为 1(隐藏(，我希望该行被动地隐藏在 TWO user_1 和 user_2 的数据表中，而无需它们中的任何一个刷新或按下 actionButton。

最好的方法是什么？

下面是一个最小的可重现示例：

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

这是一个工作示例：

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)

编辑------------------------------------

更新的版本通过避免比较整个表来减少数据库上的负载，而是只搜索闪亮的会话式未识别更改(考虑到ms时间戳，该时间戳针对每个决策更改都会更新(：

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)