在R Shiny中的ggvis繪圖之前更新UI

Question

背景：我正在構建一個與MySQL數據庫連接的儀表板。 用戶指定一個粗略的過濾器以從數據庫中提取數據，然后單擊“提交”，使用ggvis繪制數據，然后用戶可以使用精細過濾器來影響要繪制的數據子集。 這些優良的過濾器取決於從數據庫中提取的數據，因此我使用uiOutput / renderUI從數據生成它們。

問題：我的挑戰是我希望在更新繪圖之前根據數據更新UI。 否則，舊數據集中的精細過濾器將應用於新數據，從而在繪制時導致錯誤。

示例：以下示例使用mtcars大致重現了該問題。 要獲取錯誤，請選擇4個氣瓶，單擊“提交”，然后選擇6個氣瓶，然后再次單擊“提交”。 在這種情況下，當將4圓柱精細過濾器應用於6圓柱數據集時，僅返回單個點，這在嘗試在ggvis應用更平滑器時會導致錯誤。 與我得到的錯誤不一樣，但是足夠接近。

library(shiny)
library(dplyr)
library(ggvis)

ui <- fluidPage(
  headerPanel("Example"),
  sidebarPanel(
    h2("Course Filter:"),
    selectInput("cyl_input", "Cylinders", c(4, 6)),
    actionButton("submit", "Submit"),
    conditionalPanel(condition = "input.submit > 0",
      h2("Fine Filter: "),
      uiOutput("mpg_input")
    )
  ),
  mainPanel(
    ggvisOutput("mtcars_plot")
  )
)

server <- function(input, output) {
  mycars <- eventReactive(input$submit, {
    filter(mtcars, cyl == input$cyl_input)
  })
  output$mpg_input <- renderUI({
    mpg_range <- range(mycars()$mpg)
    sliderInput("mpg_input", "MPG: ",
                min = mpg_range[1], max = mpg_range[2],
                value = mpg_range,
                step = 0.1)
  })
  observe({
    if (!is.null(input$mpg_input)) {
      mycars() %>%
        filter(mpg >= input$mpg_input[1],
               mpg <= input$mpg_input[2]) %>% 
        ggvis(~mpg, ~wt) %>%
        layer_points() %>%
        layer_smooths() %>% 
        bind_shiny("mtcars_plot")
    }
  })
}

shinyApp(ui = ui, server = server)

Answer 1

經過數小時的混亂，我發現了一個非常棘手的解決方法。 我對它不是很滿意，因此希望有人可以提供改進。

總而言之，我的認識是renderUI調用是在應有的時間（即在生成圖之前）執行的。 但是， renderUI不會直接更改UI中的滑塊，而是會向瀏覽器發送一條消息，告訴它更新滑塊。 僅在所有觀察者都運行之后，才執行此類消息。 特別是，這發生在運行將包裝ggvis的調用的觀察者運行之后。 因此，順序似乎是

1. 消息已發送到瀏覽器以更新滑塊。
2. 根據滑塊中的值（仍然是舊值）生成的圖。
3. 瀏覽器更新滑塊。 可惜來不及了:(

因此，為解決此問題，我決定創建一個新的反應變量，以存儲MPG值的范圍。 在應用了粗略過濾器之后，以及在瀏覽器中更新滑塊之前，此變量立即直接引用新的數據框。 之后，當直接使用滑塊播放時，此反應變量將引用滑塊。 這只需要設置一個標志來指定是引用數據框還是滑塊，然后將標志翻轉到一個合適的位置。

這是代碼：

library(shiny)
library(dplyr)
library(ggvis)

ui <- fluidPage(
  headerPanel("Example"),
  sidebarPanel(
    h2("Course Filter:"),
    selectInput("cyl_input", "Cylinders", c(4, 6)),
    actionButton("submit", "Submit"),
    conditionalPanel(condition = "input.submit > 0",
                     h2("Fine Filter: "),
                     uiOutput("mpg_input")
    )
  ),
  mainPanel(
    ggvisOutput("mtcars_plot")
  )
)
server <- function(input, output) {
  # create variable to keep track of whether data was just updated
  fresh_data <- TRUE
  mycars <- eventReactive(input$submit, {
    # data have just been refreshed
    fresh_data <<- TRUE
    filter(mtcars, cyl == input$cyl_input)
  })
  output$mpg_input <- renderUI({
    mpgs <- range(mycars()$mpg)
    sliderInput("mpg_input", "MPG: ",
                min = mpgs[1], max = mpgs[2],
                value = mpgs,
                step = 0.1)
  })
  # make filtering criterion a reactive expression
  # required because web page inputs not updated until after everything else
  mpg_range <- reactive({
    # these next two lines are required though them seem to do nothing
    # from what I can tell they ensure that mpg_range depends reactively on
    # these variables. Apparently, the reference to these variables in the
    # if statement is not enough.
    input$mpg_input
    mycars()
    # if new data have just been pulled reference data frame directly
    if (fresh_data) {
      mpgs <- range(mycars()$mpg)
    # otherwise reference web inputs
    } else if (!is.null(input$mpg_input)) {
      mpgs <- input$mpg_input
    } else {
      mpgs <- NULL
    }
    return(mpgs)
  })
  observe({
    if (!is.null(mpg_range())) {
      mycars() %>%
        filter(mpg >= mpg_range()[1],
               mpg <= mpg_range()[2]) %>% 
        ggvis(~mpg, ~wt) %>%
        layer_points() %>%
        layer_smooths() %>% 
        bind_shiny("mtcars_plot")
    }
    # ui now updated, data no longer fresh
    fresh_data <<- FALSE
  })
}

shinyApp(ui = ui, server = server)