在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)