我有一个运行良好的 R 闪亮应用程序，但是当我通过按“获取数据”按钮检索数据时，服务器函数中的所有组件都会执行两次，而我只希望它们执行一次。我只希望它执行一次的原因是，第二次执行会导致应用程序中的绘图重新渲染，当我在远程服务器上运行它时，这一点很明显。
我附上了代码的简化版本。请注意，范围变量未应用于此简化版本，但我将其包含在内是为了显示两个反应式数据集 dat_subset 和 **dat_filt ** 之间的差异，这是真实应用程序按预期工作所需的。
我知道由于 invalidateLater(500) 代码，代码确实执行了两次 - 但如果我不包含该代码，当我过滤可反应时，绘图不会重新渲染。
我只想在按下 get_data 时执行一次代码，但我也希望在过滤表中的数据时重新渲染和更新柱形图。
所以我的问题是，当过滤表格时，我可以触发重新渲染绘图，而不必使用 invalidateLater 函数吗？
这是代码：
library(shiny)
library(htmlwidgets)
library(reactable)
library(tidyr)
library(dplyr)
library(ggplot2)
library(shinyjs)
library(shinyWidgets)
jsCode <- 'shinyjs.getSortedAndFilteredData = function() {
try {
var instance = Reactable.getInstance("dat_table");
if (instance) {
var filteredIdx = instance.sortedFlatRows.map(x => x.index + 1);
Shiny.onInputChange("filtered_data", filteredIdx);
}
} catch (err) {
console.error(err);
}
}'
# Define UI for application that draws a histogram
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("getSortedAndFilteredData")),
theme = shinythemes::shinytheme("lumen"),
fluidRow(
column(width = 10,
actionButton("get_data", "Get Data", class = "btn-primary")
)
),
fluidRow(
column(width = 7,
plotOutput("age_distribution_plot", height = 300)
)
),
fluidRow(
column(width = 10,
reactableOutput("dat_table")
)
)
)
get_age_cat_plot = function(dat){
dat$age_cat <- cut(dat$age, breaks=c(6, 11, 21, 36, Inf), labels = c("<10","11-20","21-35","36+"), right = TRUE)
d <- dat %>% group_by(gender, age_cat) %>% summarise(count = n(), .groups="keep") %>% na.omit()
d %>%
ggplot(aes(factor(age_cat, levels=rev(levels(dat$age_cat))), count, fill = gender)) +
scale_fill_manual(values = c("M"="#7285A5","F" = "pink3","U"="lightgray"))+
geom_col(alpha=0.3, width=0.8, color="darkgrey") + theme_classic()+
geom_text(aes(label = count), # Adding percentage labels
position = position_stack(vjust = 0.5),
color = "black", size = 5) +labs(y = "age", x="count")
}
server <- shinyServer(function(input, output, session) {
ranges <- reactiveValues(x = NULL, y = NULL)
gene_table_ready <- reactiveVal(FALSE)
dat <- eventReactive(input$get_data,{
print("GETTING THE DATA ")
ranges$x <- NULL; ranges$y <- NULL
gene_table_ready(TRUE)
age <- sample(0:75, 200, replace = TRUE)
gender <- sample(c("M", "F"), 200, replace = TRUE)
data.frame(age = age, gender = gender)
})
dat_subset <- reactive({
print("getting dat subset")
dat <- dat()
if (!is.null(ranges$x))
dat <- subset(dat, chr_start >= ranges$x[1] & chr_start <= ranges$x[2])
dat
})
observe({
if(gene_table_ready()){
js$getSortedAndFilteredData()
invalidateLater(500)
}
})
dat_filt <- reactive({
print("FILTERING....")
dat <- dat_subset()
if(!is.null(input$filtered_data))
dat <- dat[input$filtered_data, ]
dat
})
output$dat_table <- renderReactable({
print("Updating the data table")
dat <- dat_subset()
reactable(
dat,
filterable = TRUE,
)
})
output$age_distribution_plot <- renderPlot({
print("Getting age cat plot... ")
get_age_cat_plot(dat_filt())
})
})
shinyApp(ui = ui, server = server)
问题是，当
dat_subsetdat_filtdat_tableinput$filtered_datadat_filtinput$filtered_data我建议在
reactiveValinput$filtered_datadatreactiveValinput$filtered_datalibrary(shiny)
library(htmlwidgets)
library(reactable)
library(tidyr)
library(dplyr)
library(ggplot2)
library(shinyjs)
library(shinyWidgets)
jsCode <- 'shinyjs.getSortedAndFilteredData = function() {
try {
var instance = Reactable.getInstance("dat_table");
if (instance) {
var filteredIdx = instance.sortedFlatRows.map(x => x.index + 1);
Shiny.onInputChange("filtered_data", filteredIdx);
}
} catch (err) {
console.error(err);
}
}'
# Define UI for application that draws a histogram
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("getSortedAndFilteredData")),
theme = shinythemes::shinytheme("lumen"),
fluidRow(
column(width = 10,
actionButton("get_data", "Get Data", class = "btn-primary")
)
),
fluidRow(
column(width = 7,
plotOutput("age_distribution_plot", height = 300)
)
),
fluidRow(
column(width = 10,
reactableOutput("dat_table")
)
)
)
get_age_cat_plot = function(dat){
dat$age_cat <- cut(dat$age, breaks=c(6, 11, 21, 36, Inf), labels = c("<10","11-20","21-35","36+"), right = TRUE)
d <- dat %>% group_by(gender, age_cat) %>% summarise(count = n(), .groups="keep") %>% na.omit()
d %>%
ggplot(aes(factor(age_cat, levels=rev(levels(dat$age_cat))), count, fill = gender)) +
scale_fill_manual(values = c("M"="#7285A5","F" = "pink3","U"="lightgray"))+
geom_col(alpha=0.3, width=0.8, color="darkgrey") + theme_classic()+
geom_text(aes(label = count), # Adding percentage labels
position = position_stack(vjust = 0.5),
color = "black", size = 5) +labs(y = "age", x="count")
}
server <- shinyServer(function(input, output, session) {
ranges <- reactiveValues(x = NULL, y = NULL)
gene_table_ready <- reactiveVal(FALSE)
# Add a buffer that you can control. Use filtered_data_2() instead of input$filtered_data
filtered_data_2 <- reactiveVal(NULL)
observeEvent(input$filtered_data, {
filtered_data_2(input$filtered_data)
})
dat <- eventReactive(input$get_data,{
print("GETTING THE DATA ")
ranges$x <- NULL; ranges$y <- NULL
gene_table_ready(TRUE)
filtered_data_2(1:200) # Force the update here. Shiny will ignore the JS update that is the same as this.
age <- sample(0:75, 200, replace = TRUE)
gender <- sample(c("M", "F"), 200, replace = TRUE)
data.frame(age = age, gender = gender)
})
dat_subset <- reactive({
print("getting dat subset")
dat <- dat()
if (!is.null(ranges$x))
dat <- subset(dat, chr_start >= ranges$x[1] & chr_start <= ranges$x[2])
dat
})
observe({
if(gene_table_ready()){
js$getSortedAndFilteredData()
invalidateLater(500)
}
})
dat_filt <- reactive({
print("FILTERING....")
dat <- dat_subset()
if(!is.null(filtered_data_2())) # use the new reactiveVal
dat <- dat[filtered_data_2(), ] # use the new reactiveVal
dat
})
output$dat_table <- renderReactable({
print("Updating the data table")
dat <- dat_subset()
reactable(
dat,
filterable = TRUE,
)
})
output$age_distribution_plot <- renderPlot({
print("Getting age cat plot... ")
get_age_cat_plot(dat_filt())
})
})
shinyApp(ui = ui, server = server)