На самом деле все гораздо проще.Вместо просмотра числовых входов вы можете наблюдать, какая вкладка выбрана, и обновлять определенный numericInput, когда пользователь попадает на эту вкладку.Поэтому все, что нам нужно, это предоставить id для sidebarMenu (id = "tabs", ...) и наблюдать содержимое этой входной переменной:
observe({
if (req(input$tabs) == "tab2") {
updateSelectInput(...)
}
})
Обновленный код:
library(shiny)
library(shinydashboard)
ui = dashboardPage(
dashboardHeader(title = "Example"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Tab 1", tabName = "tab1", icon = icon("chart-line")),
menuItem("Tab 2", tabName = "tab2", icon = icon("chart-line")),
menuItem("Other Tab", tabName = "tab3", icon = icon("project-diagram"))
)
),
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "tab1",
# Input first number
numericInput("input1", label = "Input 1", value = 1000, min=1, step=1),
plotOutput("plot1")
),
# Second tab content
tabItem(tabName = "tab2",
# Input second number
numericInput("input2", label = "Input 2", value = 1000, min=1, step=1),
plotOutput("plot2")
),
# Third tab content
tabItem(tabName = "tab3", "Unrelated content")
)
)
)
server = function(input, output, session) {
# some (not so) long computation
long_comp1 <- reactive({
x <- sample(input$input1, size=10000000, replace = TRUE)
y <- sample(input$input1, size=10000000, replace = TRUE)
m <- matrix(x, nrow = 500, ncol=200)
n <- matrix(y, nrow = 200, ncol=500)
p <- n %*% m
p
})
output$plot1 <- renderPlot({
hist(long_comp1(), main = paste("input1 is", input$input1))
})
# some (not so) long computation
long_comp2 <- reactive({
x <- sample(input$input2, size=10000000, replace = TRUE)
y <- sample(input$input2, size=10000000, replace = TRUE)
m <- matrix(x, nrow = 500, ncol=200)
n <- matrix(y, nrow = 200, ncol=500)
p <- n %*% m
p
})
output$plot2 <- renderPlot({
hist(long_comp2(), main = paste("input2 is", input$input2))
})
# Update inputs to match each other
observe({
if (req(input$tabs) == "tab2") {
updateSelectInput(session = session,
inputId = "input2",
selected = input$input1)
}
})
observe({
if (req(input$tabs) == "tab1") {
updateSelectInput(session = session,
inputId = "input1",
selected = input$input2)
}
})
}
shinyApp(ui = ui, server = server)
Предыдущий ответ, который не сработал:
Я думаю, что это может быть решением.Один набор reactiveValues отслеживает, когда длинные вычисления завершены.Другой набор reactiveValues получает метки времени последнего изменения в input$input1 и input$input2.Функция reactive решает, нужно ли обновлять входы, основываясь на входных значениях и реактивных значениях длительного завершения задания.Наконец, входные данные обновляются на основе более поздней отметки времени двух входных виджетов.Внутри того же наблюдателя реактивные значения длинных заданий сбрасываются до FALSE, так что обновления до тех пор, пока они не будут завершены, не обновляются.Насколько я вижу, он избегает бесконечного цикла.
Альтернативой является установка наблюдателя, который обновляет входные данные, чтобы реагировать на кнопку, чтобы пользователь мог решить, когда распространять входные значения на другие вкладки.Если вычисления действительно длинные, то это потенциально сэкономит время, поскольку вычисления на другой вкладке будут выполняться только после того, как пользователь убедится, что ему нужно новое входное значение.
Код:
library(shiny)
library(shinydashboard)
ui = dashboardPage(
dashboardHeader(title = "Example"),
dashboardSidebar(sidebarMenu(
menuItem("Tab 1", tabName = "tab1", icon = icon("chart-line")),
menuItem("Tab 2", tabName = "tab2", icon = icon("chart-line")),
menuItem(
"Other Tab",
tabName = "tab3",
icon = icon("project-diagram")
)
)),
dashboardBody(tabItems(
# First tab content
tabItem(
tabName = "tab1",
# Input first number
numericInput(
"input1",
label = "Input 1",
value = 1000,
min = 1,
step = 1
),
plotOutput("plot1")
),
# Second tab content
tabItem(
tabName = "tab2",
# Input second number
numericInput(
"input2",
label = "Input 2",
value = 1000,
min = 1,
step = 1
),
plotOutput("plot2")
),
# Third tab content
tabItem(tabName = "tab3", "Unrelated content")
))
)
server = function(input, output, session) {
# monitor whether long jobs are done
long_jobs <- reactiveValues(job1=FALSE, job2=FALSE)
# some (not so) long computation
long_comp1 <- reactive({
a <- input$input1
x <- sample(a, size=100000000, replace = TRUE)
y <- sample(a, size=100000000, replace = TRUE)
m <- matrix(x, nrow = 5000, ncol=200)
n <- matrix(y, nrow = 200, ncol=5000)
p <- n %*% m
p
})
output$plot1 <- renderPlot({
hist(long_comp1(), main = paste("input1 is", input$input1))
long_jobs$job1 <- TRUE
})
# some (not so) long computation
long_comp2 <- reactive({
a <- input$input2
x <- sample(a, size=100000000, replace = TRUE)
y <- sample(a, size=100000000, replace = TRUE)
m <- matrix(x, nrow = 5000, ncol=200)
n <- matrix(y, nrow = 200, ncol=5000)
p <- n %*% m
p
})
output$plot2 <- renderPlot({
hist(long_comp2(), main = paste("input2 is", input$input2))
long_jobs$job2 <- TRUE
})
# monitor when inputs have last changed
time_stamps <- reactiveValues()
observeEvent(input$input1, {
time_stamps$in1_ts <- Sys.time()
})
observeEvent(input$input2, {
time_stamps$in2_ts <- Sys.time()
})
# update if inputs are different and long jobs are done
update_inputs <- reactive({
if (req(input$input1) != req(input$input2) & all(c(long_jobs$job1, long_jobs$job2))) {
TRUE
} else {
FALSE
}
})
# Update inputs to match each other
# taking the input that changed last
observeEvent(update_inputs(), {
new_input <- ifelse(time_stamps$in1_ts > time_stamps$in2_ts, "input1", "input2")
updateSelectInput(session = session,
inputId = "input2",
selected = input[[new_input]])
updateSelectInput(session = session,
inputId = "input1",
selected = input[[new_input]])
# reset the long job reactive values
# because now the inputs have changed and
# plots need to be recalculated
long_jobs$job1 <- FALSE
long_jobs$job2 <- FALSE
})
}
shinyApp(ui = ui, server = server)