r - 基于先前输入的while循环中的R Shiny conditionalPanel
问题描述
我想在 Shiny 的条件面板上进行类似 while 循环,其中循环的条件基于先前的输入。
详细说明:用户选择他想开始的国家和他想结束的另一个国家。他们还需要选择路线应该通过的边界。我想要实现的是首先更新选择输入中的选项,因此第一个仅包含国家“从”的边界,然后是他们选择去的国家的边界等。另外,我想要第二个和以下选择输入仅显示到用户选择与国家“To”边界的点。
我想到了以下伪代码:
bord_to=sub(".*-", "", input$b_dir_1)
i=2
while(bord_to!=input$cou_to){
conditionalPanel(condition = 'bord_to != input$cou_to',
selectInput("b_dir[i]",
"",
"")
bord_to=sub(".*-", "", input$b_dir[i])
i=i+1
}
我还想将输入命名为“b_dir_i”。
我创建了以下代码,它至少可以处理更新输入,但我仍然错过了有条件地显示输入的方法:
library(shiny)
countries <- c( "AT", "BG", "CH", "CZ", "DE", "FR", "GR", "HR", "HU", "IT-GREC", "IT-NORD", "PL", "RO", "RS", "SI", "SK", "TR" )
borders <- c( "MK-RS", "RS-MK", "AL-GR", "GR-AL", "AL-ME", "ME-AL", "BA-HR", "HR-BA", "BA-ME", "ME-BA", "GR-MK", "MK-GR", "GR-TR", "TR-GR", "RS-BA", "BA-RS", "HU-RS", "RS-HU", "RO-RS", "RS-RO", "HU-UA", "UA-HU", "SK-UA", "UA-SK", "AT-CZ", "CZ-AT", "AT-HU", "HU-AT", "DETE-CZ", "CZ-DETE", "HR-HU" , "HU-HR", "HR-SI", "SI-HR" , "HR-RS", "RS-HR", "GR-IT", "IT-GR", "CH-IT", "IT-CH", "CH-FR" , "FR-CH", "CH-AT", "AT-CH", "CH-DE", "DE-CH", "DE50-CZ", "CZ-DE50", "PL-CZ", "CZ-PL", "DE50-PL", "PL-DE50", "PL-SK", "SK-PL", "BG-MK", "BG-TR", "MK-BG", "TR-BG", "BG-RS", "RS-BG", "BG-GR", "GR-BG", "RO-BG", "BG-RO" )
ui<-fluidPage(
fluidRow( column( 6,
h4("Select countries:"),
selectInput("cou_from", "From:", c("", countries)),
selectInput("cou_to", "To:", c("", countries)) ) ),
h4("Select borders:"),
fluidRow(
column( 3, selectInput("b_dir_1", "", ""), ),
# this is the fragment I want to go on the loop
column( 3,
conditionalPanel(
condition = 'sub(".*-", "", input$b_dir_1) != input$cou_to ',
selectInput("b_dir_2", "", "") ) ) ),
actionButton( "run_anl",
"Run Analysis",
width = "100%",
style = "color: #fff; background-color: #337ab7;
border-color: #2e6da4" )
)
server<-function(input, output, session){
observe({
cou_1<-input$cou_from
choice1<-c("", borders[grepl(paste0("^", cou_1), borders)])
updateSelectInput(session, "b_dir_1", choices=choice1)
})
observe({
bor_ch_1<-input$b_dir_1
choice2<-c("", borders[grepl(paste0("^", sub(".*-", "", bor_ch_1)), borders)])
updateSelectInput(session, "b_dir_2", choices=choice2)
})
}
shinyApp(ui = ui, server = server)
我希望 UI 看起来与此类似:
解决方案
这是一种使用shiny::insertUI / removeUI
. 第一个边界输入是在原始应用程序中生成的,但我们没有选择两个国家的缩写(例如,DE-CH
),而是选择与该from
国家有边界的国家。然后,为了生成后续的过境点,我们from-to
根据最近的b_dir_*
. selectInput
我们通过反应值 ( )跟踪最近激活的index_selection
。为了更好地控制并避免无限循环,我添加了控制按钮,以便用户可以单击下一个过境点并清除所选路线。(我使用tidyverse
函数来准备数据集和过滤,但base R
如果需要,您可以使用代码轻松删除这些依赖项。)
这是该应用程序的 GIF。我认为它让你非常接近,如果不是一直,到所需的行为。
代码:
library(shiny)
library(dplyr)
library(tidyr)
countries <- c( "AT", "BG", "CH", "CZ", "DE", "FR", "GR", "HR", "HU", "IT-GREC", "IT-NORD", "PL", "RO", "RS", "SI", "SK", "TR" )
borders <- c( "MK-RS", "RS-MK", "AL-GR", "GR-AL", "AL-ME", "ME-AL", "BA-HR", "HR-BA", "BA-ME", "ME-BA", "GR-MK", "MK-GR", "GR-TR", "TR-GR", "RS-BA", "BA-RS", "HU-RS", "RS-HU", "RO-RS", "RS-RO", "HU-UA", "UA-HU", "SK-UA", "UA-SK", "AT-CZ", "CZ-AT", "AT-HU", "HU-AT", "DETE-CZ", "CZ-DETE", "HR-HU" , "HU-HR", "HR-SI", "SI-HR" , "HR-RS", "RS-HR", "GR-IT", "IT-GR", "CH-IT", "IT-CH", "CH-FR" , "FR-CH", "CH-AT", "AT-CH", "CH-DE", "DE-CH", "DE50-CZ", "CZ-DE50", "PL-CZ", "CZ-PL", "DE50-PL", "PL-DE50", "PL-SK", "SK-PL", "BG-MK", "BG-TR", "MK-BG", "TR-BG", "BG-RS", "RS-BG", "BG-GR", "GR-BG", "RO-BG", "BG-RO")
borders_left_right <-
tibble(borders) %>% separate(
borders,
into = c("from", "to"),
sep = "-",
remove = FALSE
)
ui <- fluidPage(
fluidRow(column(
6,
h4("Select countries:"),
selectInput("cou_from", "From:", c("", countries)),
selectInput("cou_to", "To:", c("", countries))
)),
h4("Select borders:"),
fluidRow(
column(3, selectInput("b_dir_1", "Border", "")),
div(id="placeholder"),
column(1, actionButton("next_border", "Next border")),
column(1, actionButton("clear", "Clear route"))
),
actionButton(
"run_anl",
"Run Analysis",
width = "100%",
style = "color: #fff; background-color: #337ab7;
border-color: #2e6da4"
)
)
server <- function(input, output, session) {
observe({
cou_1 <- input$cou_from
choice1 <-
filter(borders_left_right, from == cou_1) %>% pull(to)
updateSelectInput(session,
"b_dir_1",
label = paste("Borders of", cou_1),
choices = choice1)
})
# observer to update a reactive value for the selection in the last generated box
index_selection <- reactiveVal(1)
observeEvent(input$next_border, {
last_selection <- paste0("b_dir_", index_selection())
if (req(input[[last_selection]]) != input$cou_to) {
adjacent_countries <-
filter(borders_left_right, from == input[[last_selection]]) %>% pull(to)
insertUI(selector = "#placeholder",
where = "beforeBegin",
ui = tagList(column(3,
selectInput(
inputId = paste0("b_dir_", index_selection() + 1),
label = paste("Borders of", input[[last_selection]]),
choices = adjacent_countries
)
)))
}
# update reactive value
new_index <- index_selection() + 1
index_selection(new_index)
})
# clear route
observeEvent(input$clear, {
# remove inserted uis
if (index_selection() > 1) {
lapply(2:index_selection(), function(x)
removeUI(selector = paste0(".col-sm-3:has(#b_dir_", x, ")" )))
}
# update from / to inputs
updateSelectInput(session = session, inputId = "cou_from", selected = "")
updateSelectInput(session = session, inputId = "cou_to", selected = "")
# reset reactive value
index_selection(1)
})
}
shinyApp(ui = ui, server = server)
推荐阅读
- reactjs - 如何等待来自嵌套请求的 React 评估值?
- asp.net-core - 只有在 AspNetUsers 上的“EmailConfirmed”字段为真(NETCORE 3.1)时,具有有效凭据的用户才能登录
- django - Django Rest Framework 中的自定义字段验证
- python - tolist的numpy数组非常慢
- php - CakePHP 4 JSON 列值查找或设置别名
- react-native - 在 React Native 应用程序中使用的 SignalR npm 包
- python - Python 代码在 Mac 终端中运行,但不在 Neovim 中
- android - Unity 排行榜在 Play 商店发布后无法使用
- javascript - 每当切换输入字段时,状态默认为未定义
- javascript - 根据用户输入对对象数组进行排序