r语言 - 如何刷新sliderInput()在闪亮的实时(不仅当滑动结束)?

Question

对不起，我不知道这个问题是否足够清楚:在Shiny中，每次滑动条滑动时，它只会计算和更新滑动结束时的值。如果我将它的值链接到图表上，它在滑动时看起来不是很平滑(图表只会在鼠标释放或几秒钟后发生变化，而不是随着滑动而不断变化)。

使用滑动条改变y，图表中红点的位置将会改变。

输入和图表

部分代码如下:

在ui。R:

sliderInput("slider_mean", 
HTML("Try to change the value of ŷ:"),
min = 1, max = 200, value = 100,width="30%"),
plotlyOutput('meanplot'),

在服务器。R:(这段代码可能不完整，只是举个例子)

output$meanplot <- renderPlotly({

meantb <- data.frame(y_hat = 1:200) %>%
mutate(col2 =(y_mean1()-y_hat)^2+(y_mean2()-y_hat)^2+(y_mean3()-y_hat)^2+(y_mean4()-y_hat)^2+(y_mean5()-y_hat)^2+(y_mean6()-y_hat)^2)
#Here is to input the slider value
highlight_adjust <- meantb %>% 
filter(y_hat %in% input$slider_mean)

p=ggplot(meantb,
aes(x = y_hat, y = col2)) + 

geom_point(size =0.7,color="black") +

geom_point(data=highlight_adjust, 
aes(x = y_hat, y = col2), 
color='red')+
geom_line(size = 0.2,color="black") +
ggplotly(p)
})

来自Shiny的例子:

https://shiny.rstudio.com/gallery/slider-bar-and-slider-range.html

如果我们快速移动滑动条，输出值将有延迟。

Answer 1

在阅读了sliderInput的一些源代码后，我发现滑块的默认debounce行为(参见本文的getRatePolicy部分)仅在HTML代码中没有data-immediate属性时才坚持。

也就是说，我们只需要将这个属性添加到HTML中，滑块就会立即做出反应。

。如果您查看前面引用的源代码，您将看到receiveMessage将immediate重置为false。无论何时使用updateSliderInput，都会调用receiveMessage。因此，在调用updateSliderInput之后，我们必须重新分配immediate数据属性，以便仍然看到行为。

在下面的示例中，您可以看到被攻击的滑块的值被即时更新，而第二个滑块显示默认行为。点击update会把这种行为变成附带损害，如果你想使用updateSliderInput，你应该确保再次添加data-immediate属性(reset按钮的代码显示了一种可能的方法)。

然而，他意识到很可能有一个原因，为什么闪亮的团队没有向最终用户公开这个功能，所以这个解决方案应该被视为一个hack，并小心使用。(从源代码判断，他们使用immediate属性来否决使用updateSliderInput(以及receiveMessage)时的默认速率策略。

library(shiny)
library(shinyjs)
my_sld <- function(...) {
sld <- sliderInput(...)
sld$children[[2]]$attribs$`data-immediate` <- "true"
sld
}
shinyApp(
fluidPage(
useShinyjs(),
my_sld("sld1", "Immediate:", 1, 10, 1), 
verbatimTextOutput("dbg1"),
sliderInput("sld2", "Debounced:", 1, 10, 1),
verbatimTextOutput("dbg2"),
actionButton("update", "Update kills Immediateness"),
actionButton("reset", "Re-add immediate attribute")
),
function(input, output, session) {
output$dbg1 <- renderPrint(input$sld1)
output$dbg2 <- renderPrint(input$sld2)
observeEvent(input$update, {
updateSliderInput(session, "sld1", value = 8)
})
observeEvent(input$reset, {
runjs("$('#sld1').data('immediate', true);")
})
})