每次更新输出时更新 Shiny UI 输入参数中的随机值

Question

这是一个完全没有必要的用例，不过我想我会从答案中学到一些有价值的东西:)

我想在闪亮的应用程序加载输出时显示随机 gif（从 selected urls 之前的列表中随机抽取）。

我正在使用 shinycssloaders 包在输出加载时放入微调器，并从 url 的列表中为它提供图像。下面是开箱即用的直方图示例应用程序，带有微调器和一些 gif urls.

gif url 仅在每次加载应用时显示为采样。我希望它在每次输出活动运行时重新 select（抱歉，如果我在这里使用技术术语）。我的真实应用程序使用 actionButton 和 eventReactive，以便仅在单击按钮时重新加载输出。

这里的示例代码可以是运行。它会在每次输入更改后加载直方图之前休眠 3 秒以显示 gif。

library(shiny)
library(shinycssloaders)

gifs <- c(
    "https://media.giphy.com/media/QPQ3xlJhqR1BXl89RG/giphy.gif", 
    "https://media.giphy.com/media/26n6xBpxNXExDfuKc/giphy.gif", 
    "https://media.giphy.com/media/lP4jmO461gq9uLzzYc/giphy.gif"   
)

# Define UI for application that draws a histogram
ui <- fluidPage(

    # Application title
    titlePanel("Old Faithful Geyser Data"),

    # Sidebar with a slider input for number of bins 
    sidebarLayout(
        sidebarPanel(
            sliderInput("bins",
                        "Number of bins:",
                        min = 1,
                        max = 50,
                        value = 30)
        ),

        # Show a plot of the generated distribution
        mainPanel(
            withSpinner(
                plotOutput("distPlot"), image = sample(gifs, 1)
            )
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

    output$distPlot <- renderPlot({
        # generate bins based on input$bins from ui.R
        x    <- faithful[, 2]
        Sys.sleep(3)
        bins <- seq(min(x), max(x), length.out = input$bins + 1)

        # draw the histogram with the specified number of bins
        hist(x, breaks = bins, col = 'darkgray', border = 'white')
    })
}

# Run the application 
shinyApp(ui = ui, server = server)

会话信息：

R version 4.1.1 (2021-08-10)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 22000)

Matrix products: default

locale:
[1] LC_COLLATE=English_United States.1252  LC_CTYPE=English_United States.1252    LC_MONETARY=English_United States.1252
[4] LC_NUMERIC=C                           LC_TIME=English_United States.1252    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
 [1] shinycssloaders_1.0.0 RODBC_1.3-18          shinythemes_1.2.0     DT_0.19               forcats_0.5.1        
 [6] stringr_1.4.0         dplyr_1.0.7           purrr_0.3.4           readr_2.0.1           tidyr_1.1.4          
[11] tibble_3.1.4          ggplot2_3.3.5         tidyverse_1.3.1       shiny_1.6.0          

loaded via a namespace (and not attached):
 [1] Rcpp_1.0.7        lubridate_1.7.10  here_1.0.1        assertthat_0.2.1  rprojroot_2.0.2   digest_0.6.27    
 [7] utf8_1.2.2        mime_0.11         R6_2.5.1          cellranger_1.1.0  backports_1.2.1   reprex_2.0.1     
[13] httr_1.4.2        pillar_1.6.2      rlang_0.4.11      readxl_1.3.1      rstudioapi_0.13   jquerylib_0.1.4  
[19] htmlwidgets_1.5.4 bit_4.0.4         munsell_0.5.0     broom_0.7.9       compiler_4.1.1    httpuv_1.6.3     
[25] modelr_0.1.8      janitor_2.1.0     pkgconfig_2.0.3   htmltools_0.5.2   sourcetools_0.1.7 tidyselect_1.1.1 
[31] fansi_0.5.0       crayon_1.4.1      tzdb_0.1.2        dbplyr_2.1.1      withr_2.4.2       later_1.3.0      
[37] grid_4.1.1        jsonlite_1.7.2    xtable_1.8-4      gtable_0.3.0      lifecycle_1.0.0   DBI_1.1.1        
[43] magrittr_2.0.1    scales_1.1.1      cachem_1.0.6      cli_3.0.1         stringi_1.7.4     vroom_1.5.4      
[49] fs_1.5.0          promises_1.2.0.1  snakecase_0.11.0  bslib_0.3.0       xml2_1.3.2        ellipsis_0.3.2   
[55] keyring_1.2.0     generics_0.1.0    vctrs_0.3.8       tools_4.1.1       bit64_4.0.5       glue_1.4.2       
[61] crosstalk_1.1.1   hms_1.1.0         yaml_2.2.1        rsconnect_0.8.24  fastmap_1.1.0     colorspace_2.0-2 
[67] rvest_1.0.1       haven_2.4.3       sass_0.4.0

Answer 1

ui 中的所有代码只执行一次。我们需要在服务器内部进行采样以不断更改显示的 gif。一种方法是使用 renderUI 每次创建具有不同图像的 plotOutput。

请注意，我添加了一个名为 signal 的反应值，这是为了防止在我们使用 observeEvent(input$bins, {...}) 渲染 UI 时发生的 gif 变灰。

应用程序：

library(shiny)
library(shinycssloaders)

set.seed(111111111)

gifs <- c(
    "https://media.giphy.com/media/QPQ3xlJhqR1BXl89RG/giphy.gif",
    "https://media.giphy.com/media/26n6xBpxNXExDfuKc/giphy.gif",
    "https://media.giphy.com/media/lP4jmO461gq9uLzzYc/giphy.gif"
)

# Define UI for application that draws a histogram
ui <- fluidPage(
    
    # Application title
    titlePanel("Old Faithful Geyser Data"),
    
    # Sidebar with a slider input for number of bins
    sidebarLayout(
        sidebarPanel(
            sliderInput("bins",
                        "Number of bins:",
                        min = 1,
                        max = 50,
                        value = 30
            )
        ),
        
        # Show a plot of the generated distribution
        mainPanel(
            uiOutput("dynamic_gif")
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
    signal <- reactiveVal(rnorm(1))
    
    output$distPlot <- renderPlot({
        # generate bins based on input$bins from ui.R
        x <- faithful[, 2]
        Sys.sleep(1)
        bins <- seq(min(x), max(x), length.out = input$bins + 1)
        
        signal(rnorm(1)) # change the value for the observer to trigger
        
        # draw the histogram with the specified number of bins
        hist(x, breaks = bins, col = "darkgray", border = "white")
    })
    
    
    observeEvent(signal(), {
        output$dynamic_gif <- renderUI({
            tagList(
                withSpinner(
                    plotOutput("distPlot"),
                    image = sample(gifs, 1)
                )
            )
        })
    })
}

# Run the application
shinyApp(ui = ui, server = server)

每次更新输出时更新 Shiny UI 输入参数中的随机值

Updating a random value in a Shiny UI input parameter every time the output is updated

r

shiny