我有一个闪亮的应用程序,用户在其中选择一组输入,例如x范围,y范围,缩放类型以及通过下拉列表选择数据集的特定子集.
这一切都是通过使用反应物来完成的.X和Y范围滑块输入对数据集选择的变化作出反应,因为必须再次找到最小值和最大值.这可能需要大约1-2秒,而闪亮的应用程序正在工作,用户在下拉列表中选择一个不同的选项.在这1-2秒期间,绘图将切换为使用旧的x和y范围绘制所选的新数据子集,然后在x和y范围滑块更改后快速切换到正确的绘图.
修复就是通过隔离其他所有内容来刷新按钮上的图.但是有没有办法让情节对变化保持反应,但是等到所有依赖事物都完成计算？
谢谢
这是情节:
output$plot1 <- rCharts::renderChart2({
if(!is.null(input$date_of_interest) &&
!is.null(input$xrange) &&
!is.null(input$yrange) &&
!is.null(data()) &&
isolate(valid_date_of_interest())) {
filtered_data<- dplyr::filter(isolate(data()), id==input$choice)
p <- tryCatch(plot_high_chart(
data,
first_date_of_interest = input$date_of_interest,
ylim = input$yrange,
xlim = input$xrange),
error = function(e) e,
warning = function(w) w)
if(!inherits(p, "error") && !inherits(p, "warning")) {
return(p)
}
}
return(rCharts::Highcharts$new())
})
和x范围(y范围相似):
output$xrange <- renderUI({
if(!is.null(input$date_of_interest) &&
!is.null(input$choice) &&
!is.null(valid_date_of_interest()) &&
isolate(valid_date_of_interest())) {
temp_data <- dplyr::filter(isolate(data()), date == input$date_of_interest)
temp <- data.table::data.table(temp_data, key = "child.id")
the_days <- as.double(as.Date(temp$last.tradeable.dt) - as.Date(temp$date))
min_days <- min(the_days,na.rm=TRUE)
max_days <- max(the_days,na.rm=TRUE)
sliderInput("xrange",
"Days Range (X Axis)",
step = 1,
min = 0,
max = max_days + 10,
value = c(min_days,max_days)
)
}
})
和输入选择:
output$choice<- renderUI({
selectInput("choice",
"Choose:",
unique(data$id),
selected = 1
)
})
实施的一些方向和建议将是有用的.我想过有一些全局变量,比如x_range_updated,y_range_updated,在输出$ choice的代码中设置为false,然后在输出$ xrange等的代码中设置为true.然后让plot1依赖它们为true .其他建议可以解决这个问题.
Nic*_*edy 24
自从Shiny 1.0.0(在我最初编写这个答案之后发布)以来,现在有一个debounce函数可以添加功能来帮助完成这类任务.在大多数情况下,这避免了对我最初编写的代码的需求,尽管它的工作方式类似.但是,据我所知,debounce并没有提供任何方法来使用重绘操作按钮来缩短延迟,就像我在这里所做的那样.因此,我创建了一个debounce提供此功能的修改版本:
library(shiny)
library(magrittr)
# Redefined in global namespace since it's not exported from shiny
`%OR%` <- shiny:::`%OR%`
debounce_sc <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain(), short_circuit = NULL)
{
force(r)
force(millis)
if (!is.function(millis)) {
origMillis <- millis
millis <- function() origMillis
}
v <- reactiveValues(trigger = NULL, when = NULL)
firstRun <- TRUE
observe({
r()
if (firstRun) {
firstRun <<- FALSE
return()
}
v$when <- Sys.time() + millis()/1000
}, label = "debounce tracker", domain = domain, priority = priority)
# New code here to short circuit the timer when the short_circuit reactive
# triggers
if (inherits(short_circuit, "reactive")) {
observe({
short_circuit()
v$when <- Sys.time()
}, label = "debounce short circuit", domain = domain, priority = priority)
}
# New code ends
observe({
if (is.null(v$when))
return()
now <- Sys.time()
if (now >= v$when) {
v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 +
1
v$when <- NULL
}
else {
invalidateLater((v$when - now) * 1000)
}
}, label = "debounce timer", domain = domain, priority = priority)
er <- eventReactive(v$trigger, {
r()
}, label = "debounce result", ignoreNULL = FALSE, domain = domain)
primer <- observe({
primer$destroy()
er()
}, label = "debounce primer", domain = domain, priority = priority)
er
}
这样就可以实现简化的闪亮应用.我已切换到单文件工作模式,但UI仍然与原始模式相同.
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
selectInput("column", "Column", colnames(faithful), selected = "waiting"),
actionButton("redraw", "Redraw")
),
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output, session) {
reac <- reactive(list(bins = input$bins, column = input$column)) %>%
debounce_sc(5000, short_circuit = reactive(input$redraw))
# Only triggered by the debounced reactive
output$distPlot <- renderPlot({
x <- faithful[, reac()$column]
bins <- seq(min(x), max(x), length.out = reac()$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white',
main = sprintf("Histogram of %s", reac()$column))
})
}
shinyApp(ui, server)
你还没有提供一个可重复的例子,所以我已经选择了基于Shiny忠实示例的东西,这是RStudio的默认示例.我得到的解决方案将在输入更改和重绘图之间始终具有(可配置的)5秒延迟.输入中的每次更改都会重置计时器.还有一个不耐烦的重绘按钮,可以立即重绘图形.每次输入改变或计时器滴答时,控制台都会显示无功值'重绘'和输入的值.应将其删除以供生产使用.希望这符合您的需求!
library(shiny)
shinyUI(fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
selectInput("column", "Column", colnames(faithful), selected = "waiting"),
actionButton("redraw", "Redraw")
),
mainPanel(
plotOutput("distPlot")
)
)
))
library(shiny)
shinyServer(function(input, output, session) {
reac <- reactiveValues(redraw = TRUE, bins = isolate(input$bins), column = isolate(input$column))
# If any inputs are changed, set the redraw parameter to FALSE
observe({
input$bins
input$column
reac$redraw <- FALSE
})
# This event will also fire for any inputs, but will also fire for
# a timer and with the 'redraw now' button.
# The net effect is that when an input is changed, a 5 second timer
# is started. This will be reset any time that a further input is
# changed. If it is allowed to lapse (or if the button is pressed)
# then the inputs are copied into the reactiveValues which in turn
# trigger the plot to be redrawn.
observe({
invalidateLater(5000, session)
input$bins
input$column
input$redraw
isolate(cat(reac$redraw, input$bins, input$column, "\n"))
if (isolate(reac$redraw)) {
reac$bins <- input$bins
reac$column <- input$column
} else {
isolate(reac$redraw <- TRUE)
}
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$distPlot <- renderPlot({
x <- faithful[, reac$column]
bins <- seq(min(x), max(x), length.out = reac$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white',
main = sprintf("Histogram of %s", reac$column))
})
})