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)