Shiny：全球反应式数据集

Question

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

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

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

因此，如果有 2 个用户并且 user_1 将行 a 的 decision 的值从 0（显示）更改为 1（隐藏），我希望该行被被动隐藏在 user_1 和的数据表中user_2 无需刷新或按下操作按钮。

最好的方法是什么？

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

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-timestamp，每个决策更改都会更新）：

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)