Shiny: глобальный реактивный набор данных

Question

У меня есть глобальный фрейм данных (он будет определен в Global.R), который создается путем запроса базы данных postgre.Этот фрейм данных должен использоваться несколькими сеансами.

Теперь в пользовательском интерфейсе каждого сеанса мне нужно отобразить таблицу данных с содержимым этого фрейма данных.У меня также есть объект radioButton, чтобы пользователь мог изменить значение поля, назвать его decision в кадре данных для данной строки, и я хотел бы, чтобы соответствующая строка в таблице данных отображалась или нет (т.е. отображать строку фрейма данных в виде строки в таблице данных, только если decision == 0)

Проблема: Я бы хотел, чтобы строка в таблице данных была реактивно скрыта / отображена в соответствии со значением, которое пользователь дает decision, и я хотел бы, чтобы это происходило за несколько сеансов

Так что, если есть 2 пользователя, а user_1 изменяет значение decision для строки a от 0 (отображается) до 1 (скрыто), я бы хотел, чтобы эта строка была реактивно скрыта в таблицах данных ОБА пользователь_1 И пользователь_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, которая обновляется длякаждое изменение решения):

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)