ggvis在R之前更新UI Shiny

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)