基于先前输入的while循环中的R Shiny conditionalPanel

Question

我想在 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 看起来像这样：

Answer 1

这是一种使用shiny::insertUI / removeUI 的方法。第一个边界输入是在原始应用程序中生成的，但我们没有选择两个国家的缩写（例如，DE-CH），而是选择与from 国家共享边界的国家。然后，为了生成后续的过境点，我们根据最近的b_dir_* 过滤from-to 数据框。我们通过响应值 (index_selection) 跟踪最近激活的 selectInput。为了更好地控制并避免无限循环，我添加了控制按钮，以便用户可以单击下一个过境点并清除所选路线。 （我使用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)