10 动态UI

到目前为止，我们已经看到了UI和server函数之间的清晰分离：用户界面在应用程序启动时静态定义，因此它无法对应用程序中发生的任何事情做出响应。在本章中，您将学习如何创建动态用户界面，通过server函数中运行的代码来更改UI。

创建动态用户界面有三个关键技术：

使用update系列的函数来修改输入控件的参数。
使用tabsetPanel()来有条件地显示和隐藏用户界面的部分。
使用uiOutput()和renderUI()通过代码生成用户界面的选定部分。

这三个工具为您提供了相当强大的功能，通过修改输入和输出来响应用户。我将演示一些您可以应用它们的更有用的方式，但最终您的创造力是唯一的限制。同时，这些工具可能会使您的应用程序变得更难理解，因此请谨慎使用，并始终努力使用解决您问题的最简单技术。

接下来是R代码库的加载部分：

1 2	library(shiny) library(dplyr, warn.conflicts = FALSE)

10.1 更新输入

我们将从一个简单的技术开始，该技术允许您在创建后修改输入：update系列的函数。每个输入控件，例如textInput()，都配有一个更新函数，例如updateTextInput()，允许您在创建后修改该控件。

请考虑以下代码示例，结果如图10.1所示。该应用程序有两个输入控件，它们控制另一个输入控件（滑块）的范围（最小值和最大值）。关键的想法是使用observeEvent()来触发updateSliderInput()，每当最小或最大输入发生变化时。

ui <- fluidPage(
  numericInput("min", "Minimum", 0),
  numericInput("max", "Maximum", 3),
  sliderInput("n", "n", min = 0, max = 3, value = 1)
)
server <- function(input, output, session) {
  observeEvent(input$min, {
    updateSliderInput(inputId = "n", min = input$min)
  })  
  observeEvent(input$max, {
    updateSliderInput(inputId = "n", max = input$max)
  })
}

在这个例子中，observeEvent()监视min和max输入的变化，并在它们变化时调用updateSliderInput()来更新滑块的最小和最大值。renderText()用于在textOutput()控件中显示当前范围。


图10.1 应用程序加载时的界面（左），增加最大值后的界面（中），然后减少最小值后的界面（右）。请访问 https://hadley.shinyapps.io/ms-update-basics 查看实时效果

更新函数与其他Shiny函数有些不同：它们都接受输入的名称（作为字符串）作为inputId参数。其余的参数对应于输入构造函数中可以在创建后修改的参数。

为了帮助您掌握更新函数的使用，我将展示几个简单的示例，然后我们将深入探讨使用分层选择框的复杂案例研究，最后讨论循环引用的问题。

10.1.1 简单应用

更新函数最简单的用法是为用户提供一些小的便利。例如，您可能希望轻松地将参数重置为其初始值。以下代码片段展示了如何结合使用actionButton()、observeEvent()和updateSliderInput()，结果如图10.2所示。

ui <- fluidPage(
  sliderInput("x1", "x1", 0, min = -10, max = 10),
  sliderInput("x2", "x2", 0, min = -10, max = 10),
  sliderInput("x3", "x3", 0, min = -10, max = 10),
  actionButton("reset", "Reset")
)

server <- function(input, output, session) {
  observeEvent(input$reset, {
    updateSliderInput(inputId = "x1", value = 0)
    updateSliderInput(inputId = "x2", value = 0)
    updateSliderInput(inputId = "x3", value = 0)
  })
}


图10.2 应用加载时（左图），拖动一些滑块后（中图），然后点击重置（右图）。在线查看地址：https://hadley.shinyapps.io/ms-update-reset

一个类似的应用是调整动作按钮的文本，以便你确切知道它将执行什么操作。图10.3展示了下面代码的结果。

ui <- fluidPage(
  numericInput("n", "Simulations", 10),
  actionButton("simulate", "Simulate")
)

server <- function(input, output, session) {
  observeEvent(input$n, {
    label <- paste0("Simulate ", input$n, " times")
    updateActionButton(inputId = "simulate", label = label)
  })
}


图 10.3 应用加载时（左），将模拟次数设置为 1（中），再将模拟次数设置为 100（右）。在线查看地址：https://hadley.shinyapps.io/ms-update-button

有很多方法可以用这种方式使用更新函数；在开发复杂应用时，要注意找出向用户提供更多信息的方法。一个特别重要的应用是通过逐步筛选来简化从一长串可能选项中进行选择的过程。这通常是“分层选择框”的问题。

10.1.2 分层选择框

更新函数的一个更复杂但特别有用的应用是允许在多个类别之间进行交互式深入探索。我将用一个来自 https://www.kaggle.com/kyanyoga/sample-sales-data 的销售仪表板的虚拟数据来说明它们的使用方法。

sales <- vroom::vroom("sales-dashboard/sales_data_sample.csv", col_types = list(), na = "")
sales %>% 
  select(TERRITORY, CUSTOMERNAME, ORDERNUMBER, everything()) %>%
  arrange(ORDERNUMBER)
#> # A tibble: 2,823 × 25
#>    TERRITORY CUSTOM…¹ ORDER…² QUANT…³ PRICE…⁴ ORDER…⁵ SALES ORDER…⁶ STATUS QTR_ID
#>    <chr>     <chr>      <dbl>   <dbl>   <dbl>   <dbl> <dbl> <chr>   <chr>   <dbl>
#>  1 NA        Online …   10100      30   100         3 5151  1/6/20… Shipp…      1
#>  2 NA        Online …   10100      50    67.8       2 3390  1/6/20… Shipp…      1
#>  3 NA        Online …   10100      22    86.5       4 1903. 1/6/20… Shipp…      1
#>  4 NA        Online …   10100      49    34.5       1 1689. 1/6/20… Shipp…      1
#>  5 EMEA      Blauer …   10101      25   100         4 3782  1/9/20… Shipp…      1
#>  6 EMEA      Blauer …   10101      26   100         1 3773. 1/9/20… Shipp…      1
#>  7 EMEA      Blauer …   10101      45    31.2       3 1404  1/9/20… Shipp…      1
#>  8 EMEA      Blauer …   10101      46    53.8       2 2473. 1/9/20… Shipp…      1
#>  9 NA        Vitachr…   10102      39   100         2 4808. 1/10/2… Shipp…      1
#> 10 NA        Vitachr…   10102      41    50.1       1 2056. 1/10/2… Shipp…      1
#> # … with 2,813 more rows, 15 more variables: MONTH_ID <dbl>, YEAR_ID <dbl>,
#> #   PRODUCTLINE <chr>, MSRP <dbl>, PRODUCTCODE <chr>, PHONE <chr>,
#> #   ADDRESSLINE1 <chr>, ADDRESSLINE2 <chr>, CITY <chr>, STATE <chr>,
#> #   POSTALCODE <chr>, COUNTRY <chr>, CONTACTLASTNAME <chr>,
#> #   CONTACTFIRSTNAME <chr>, DEALSIZE <chr>, and abbreviated variable names
#> #   ¹CUSTOMERNAME, ²ORDERNUMBER, ³QUANTITYORDERED, ⁴PRICEEACH, ⁵ORDERLINENUMBER,
#> #   ⁶ORDERDATE

在这个演示中，我将重点关注数据中的自然层次结构：

每个区域包含客户。
每个客户有多个订单。
每个订单包含行。

我想创建一个用户界面，你可以：

选择一个区域来查看所有客户。
选择一个客户来查看所有订单。
选择一个订单来查看底层行。

用户界面的核心是简单的：我将创建三个选择框和一个输出表格。customername和ordernumber选择框的选项将动态生成，因此我将设置choices = NULL。

ui <- fluidPage(
  selectInput("territory", "Territory", choices = unique(sales$TERRITORY)),
  selectInput("customername", "Customer", choices = NULL),
  selectInput("ordernumber", "Order number", choices = NULL),
  tableOutput("data")
)

在服务器函数中，我自上而下地工作：

我创建了一个响应式对象 territory()，它包含与所选区域匹配的 sales 中的行。
每当 territory() 发生变化时，我都会更新 input$customername 选择框中的选项列表。
我创建了另一个响应式对象 customer()，它包含与所选客户匹配的 territory() 中的行。
每当 customer() 发生变化时，我都会更新 input$ordernumber 选择框中的选项列表。
我在 output$data 中显示所选订单。

你可以看到下面的组织结构：

server <- function(input, output, session) {
  territory <- reactive({
    filter(sales, TERRITORY == input$territory)
  })
  observeEvent(territory(), {
    choices <- unique(territory()$CUSTOMERNAME)
    updateSelectInput(inputId = "customername", choices = choices) 
  })
  
  customer <- reactive({
    req(input$customername)
    filter(territory(), CUSTOMERNAME == input$customername)
  })
  observeEvent(customer(), {
    choices <- unique(customer()$ORDERNUMBER)
    updateSelectInput(inputId = "ordernumber", choices = choices)
  })
  
  output$data <- renderTable({
    req(input$ordernumber)
    customer() %>% 
      filter(ORDERNUMBER == input$ordernumber) %>% 
      select(QUANTITYORDERED, PRICEEACH, PRODUCTCODE)
  })
}


图 10.4 我选择“EMEA”（左），然后选择“Lyon Souveniers”（中），然后（右）查看订单。在线查看地址：https://hadley.shinyapps.io/ms-update-nested

你可以在 https://hadley.shinyapps.io/ms-update-nested 尝试这个简单的示例，或者在 https://github.com/hadley/mastering-shiny/tree/master/sales-dashboard 查看一个更加完善的应用示例。

10.1.3 冻结响应式输入

有时，这种分层选择会短暂地创建一个无效的输入集，导致出现不想要的输出闪烁。例如，考虑这个简单的应用，你首先选择一个数据集，然后选择要汇总的变量：

ui <- fluidPage(
  selectInput("dataset", "Choose a dataset", c("pressure", "cars")),
  selectInput("column", "Choose column", character(0)),
  verbatimTextOutput("summary")
)

server <- function(input, output, session) {
  dataset <- reactive(get(input$dataset, "package:datasets"))
  
  observeEvent(input$dataset, {
    updateSelectInput(inputId = "column", choices = names(dataset()))
  })
  
  output$summary <- renderPrint({
    summary(dataset()[[input$column]])
  })
}

如果你在 https://hadley.shinyapps.io/ms-freeze 上尝试这个实时应用，你会注意到当你切换数据集时，摘要输出会短暂地闪烁。这是因为 updateSelectInput() 只有在所有输出和观察者都运行之后才会生效，因此会暂时出现一个状态，即你拥有数据集 B 和来自数据集 A 的变量，因此输出会包含 summary(NULL)。

你可以通过“freezing”输入值来解决这个问题，使用 freezeReactiveValue()。这确保了任何使用输入的响应式对象或输出都不会更新，直到下一次完整的失效周期。

server <- function(input, output, session) {
  dataset <- reactive(get(input$dataset, "package:datasets"))
  
  observeEvent(input$dataset, {
    freezeReactiveValue(input, "column")
    updateSelectInput(inputId = "column", choices = names(dataset()))
  })
  
  output$summary <- renderPrint({
    summary(dataset()[[input$column]])
  })
}

请注意，你不需要“thaw”输入值；当 Shiny 检测到会话和服务器再次同步时，这会自动发生。

你可能会好奇什么时候应该使用 freezeReactiveValue()：实际上，当你动态更改输入值时，使用它总是一个好习惯。实际的修改需要一些时间才能流向浏览器，然后再返回给 Shiny，而在此期间，任何对该值的读取都可能是浪费的，在最坏的情况下可能导致错误。使用 freezeReactiveValue() 告诉所有下游计算，输入值是陈旧的，它们应该保存它们的努力，直到它变得有用。

10.1.4 循环引用

如果你想使用 update 函数来改变输入的当前value，那么我们需要讨论一个重要的问题。从 Shiny 的角度来看，使用 update 函数来修改值与用户通过点击或输入来修改值没有区别。这意味着 update 函数可以像人类一样触发响应式更新。这意味着你现在已经超出了纯响应式编程的范围，你需要开始担心循环引用和无限循环的问题。

例如，看看下面这个简单的应用。它包含一个输入控件和一个观察者，后者将其值加一并更新。每次运行 updateNumericInput() 时，它都会更改 input$n，导致 updateNumericInput() 再次运行，因此应用陷入无限循环，持续增加 input$n 的值。

ui <- fluidPage(
  numericInput("n", "n", 0)
)
server <- function(input, output, session) {
  observeEvent(input$n,
    updateNumericInput(inputId = "n", value = input$n + 1)
  )
}

虽然你不太可能在自己的应用中创建这种显而易见的问题，但如果你在更新相互依赖的多个控件时，可能会遇到类似的问题，如下一个例子所示。

10.1.5 相互关联的输入

在应用中出现循环引用很容易发生在有多个“事实来源”时。例如，假设你想创建一个温度转换应用，用户既可以输入摄氏温度也可以输入华氏温度：

ui <- fluidPage(
  numericInput("temp_c", "Celsius", NA, step = 1),
  numericInput("temp_f", "Fahrenheit", NA, step = 1)
)

server <- function(input, output, session) {
  observeEvent(input$temp_f, {
    c <- round((input$temp_f - 32) * 5 / 9)
    updateNumericInput(inputId = "temp_c", value = c)
  })
  
  observeEvent(input$temp_c, {
    f <- round((input$temp_c * 9 / 5) + 32)
    updateNumericInput(inputId = "temp_f", value = f)
  })
}

如果你尝试这个应用，https://hadley.shinyapps.io/ms-temperature，你会发现它大部分时候可以正常工作，但你可能也会注意到它有时会触发多次更改。例如：

将温度设为120华氏度，然后点击向下的箭头。
华氏度变为119，摄氏度更新为48。
48摄氏度转换为118华氏度，因此华氏度再次变为118。
幸运的是，118华氏度仍然是48摄氏度，所以更新在那里停止了。

这个问题没有解决办法，因为你在应用中有一个概念（温度），但有两个表达式（摄氏度和华氏度）。在这里我们很幸运，因为循环迅速收敛到一个同时满足两个约束的值。一般来说，除非你愿意非常仔细地分析你创建的底层动态系统的收敛性质，否则最好避免这种情况。

10.1.6 练习

请在下面的用户界面中添加一个服务器函数，以更新input$date，这样你只能选择input$year中的日期。
1
2
3
4
ui <- fluidPage(
numericInput("year", "year", value = 2020),
dateInput("date", "date")
)

请在下面的用户界面中添加一个服务器函数，根据input$state更新input$county的选择。作为一个额外的挑战，请也将路易斯安那州的标签从“County”改为“Parish”，阿拉斯加州的标签改为“Borough”。

library(openintro, warn.conflicts = FALSE)
#> Loading required package: airports
#> Loading required package: cherryblossom
#> Loading required package: usdata
#> Registered S3 methods overwritten by 'readr':
#>   method                    from 
#>   as.data.frame.spec_tbl_df vroom
#>   as_tibble.spec_tbl_df     vroom
#>   format.col_spec           vroom
#>   print.col_spec            vroom
#>   print.collector           vroom
#>   print.date_names          vroom
#>   print.locale              vroom
#>   str.col_spec              vroom
states <- unique(county$state)

ui <- fluidPage(
  selectInput("state", "State", choices = states),
  selectInput("county", "County", choices = NULL)
)

使用服务器函数完善下面的用户界面，根据input$continent更新input$country的选择。使用output$data显示所有匹配的行。

library(gapminder)
continents <- unique(gapminder$continent)

ui <- fluidPage(
  selectInput("continent", "Continent", choices = continents), 
  selectInput("country", "Country", choices = NULL),
  tableOutput("data")
)

扩展之前的应用，以便您还可以选择选择所有大洲，从而查看所有国家。您需要将“(All)”添加到选择列表中，然后在过滤时特殊处理它。
在https://community.rstudio.com/t/29307?上描述的问题的核心是什么？

10.2 动态可见性

复杂性的下一步是有选择地显示和隐藏用户界面中的部分。如果您了解一些JavaScript和CSS，那么可以使用更复杂的方法，但有一种有用的技术不需要任何额外的知识：使用选项卡集（如在6.3.1节中介绍的）隐藏可选的用户界面。这是一种巧妙的技巧，允许您根据需要显示和隐藏用户界面，而无需从头开始重新生成它（您将在下一节中学到）。

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectInput("controller", "Show", choices = paste0("panel", 1:3))
    ),
    mainPanel(
      tabsetPanel(
        id = "switcher",
        type = "hidden",
        tabPanelBody("panel1", "Panel 1 content"),
        tabPanelBody("panel2", "Panel 2 content"),
        tabPanelBody("panel3", "Panel 3 content")
      )
    )
  )
)

server <- function(input, output, session) {
  observeEvent(input$controller, {
    updateTabsetPanel(inputId = "switcher", selected = input$controller)
  })
}


图10.5 选择panel1（左），然后选择panel2（中），最后选择panel3（右）。查看实时效果请访问 https://hadley.shinyapps.io/ms-dynamic-panels

这里主要有两个想法：

使用带有隐藏选项卡的选项卡集面板。
使用updateTabsetPanel()从服务器切换选项卡。

这是一个简单的想法，但结合一点创意，它将赋予你相当大的能力。接下来的两节将举例说明如何在实践中使用它的两个小例子。

10.2.1 条件用户界面

想象一下，你想要一个应用，允许用户模拟正态分布、均匀分布和指数分布。每种分布都有不同的参数，因此我们需要某种方法来显示不同分布的不同控件。在这里，我将为每个分布的唯一用户界面放在它自己的tabPanel()中，然后将三个选项卡组织成一个tabsetPanel()。

parameter_tabs <- tabsetPanel(
  id = "params",
  type = "hidden",
  tabPanel("normal",
    numericInput("mean", "mean", value = 1),
    numericInput("sd", "standard deviation", min = 0, value = 1)
  ),
  tabPanel("uniform", 
    numericInput("min", "min", value = 0),
    numericInput("max", "max", value = 1)
  ),
  tabPanel("exponential",
    numericInput("rate", "rate", value = 1, min = 0),
  )
)

然后，我将把这部分嵌入到一个更完整的用户界面中，允许用户选择样本数量，并显示结果的直方图：

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectInput("dist", "Distribution", 
        choices = c("normal", "uniform", "exponential")
      ),
      numericInput("n", "Number of samples", value = 100),
      parameter_tabs,
    ),
    mainPanel(
      plotOutput("hist")
    )
  )
)

请注意，我已经仔细地将input$dist中的choices与选项卡面板的名称相匹配。这使得编写下面的observeEvent()代码变得很容易，该代码会在分布变化时自动切换控件。该应用的其他部分使用了你已经熟悉的技术。最终结果如图10.6所示。

server <- function(input, output, session) {
  observeEvent(input$dist, {
    updateTabsetPanel(inputId = "params", selected = input$dist)
  }) 
  
  sample <- reactive({
    switch(input$dist,
      normal = rnorm(input$n, input$mean, input$sd),
      uniform = runif(input$n, input$min, input$max),
      exponential = rexp(input$n, input$rate)
    )
  })
  output$hist <- renderPlot(hist(sample()), res = 96)
}


图10.6 正态分布（左）、均匀分布（中）和指数分布（右）的结果。查看实时效果请访问 https://hadley.shinyapps.io/ms-dynamic-conditional

请注意，（例如）input$mean的值是否对用户可见是独立的。底层的HTML控件仍然存在；只是你看不到它。

10.2.2 向导界面

你还可以使用这个想法来创建一个“wizard”，这是一种界面类型，通过将其分散到多个页面上，更容易收集大量信息。在这里，我们在每个“page”中嵌入动作按钮，使其易于向前和向后移动。结果如图10.7所示。

ui <- fluidPage(
  tabsetPanel(
    id = "wizard",
    type = "hidden",
    tabPanel("page_1", 
      "Welcome!",
      actionButton("page_12", "next")
    ),
    tabPanel("page_2", 
      "Only one page to go",
      actionButton("page_21", "prev"),
      actionButton("page_23", "next")
    ),
    tabPanel("page_3", 
      "You're done!",
      actionButton("page_32", "prev")
    )
  )
)

server <- function(input, output, session) {
  switch_page <- function(i) {
    updateTabsetPanel(inputId = "wizard", selected = paste0("page_", i))
  }
  
  observeEvent(input$page_12, switch_page(2))
  observeEvent(input$page_21, switch_page(1))
  observeEvent(input$page_23, switch_page(3))
  observeEvent(input$page_32, switch_page(2))
}


图10.7 向导界面将复杂的用户界面分割成多个页面。在这里，我们通过一个非常简单的示例来演示这个想法，点击“下一步”以进入下一页。查看实时效果请访问 https://hadley.shinyapps.io/ms-wizard

请注意，使用switch_page()函数可以减少服务器代码中的重复量。我们将在第18章再次回到这个想法，然后在第19.4.2节中创建一个模块来自动化向导界面。

10.2.3 练习

使用隐藏的选项卡集，仅当用户选中“advanced”复选框时才显示额外的控件。
创建一个应用，该应用绘制ggplot(diamonds, aes(carat))，但允许用户选择使用的geom：geom_histogram()、geom_freqpoly()或geom_density()。使用隐藏的选项卡集，允许用户根据geom选择不同的参数：geom_histogram()和geom_freqpoly()具有binwidth参数；geom_density()具有bw参数。
修改你在前一个练习中创建的应用，允许用户选择是否显示每个geom（即，而不是始终使用一个geom，他们可以选择0、1、2或3个）。确保你可以独立控制直方图和频率多边形的binwidth。

10.3 使用代码创建用户界面

有时，上面描述的技术无法提供您所需的动态性水平：更新函数只允许您更改现有的输入，而选项卡集仅在您具有固定且已知的可能组合集时才有效。有时，您需要根据其他输入创建不同类型的输入（或输出）或不同数量的输入（或输出）。这种最终技术使您能够这样做。

值得注意的是，您一直使用代码创建用户界面，但到目前为止，您总是在应用启动之前这样做。这种技术使您能够在应用运行时创建和修改用户界面。这个解决方案有两个部分：

uiOutput() 在用户界面 (ui) 中插入一个占位符。这留下了一个“洞”，您的服务器代码稍后可以填充它。
renderUI() 在 server() 中被调用，用于将占位符填充为动态生成的用户界面。

我们将通过一个简单的示例来了解这是如何工作的，然后深入探讨一些实际的应用。

10.3.1 入门

让我们从一个简单的应用开始，该应用动态地创建输入控件，其类型和标签由另外两个输入控件控制。最终的应用如图10.8所示。

ui <- fluidPage(
  textInput("label", "label"),
  selectInput("type", "type", c("slider", "numeric")),
  uiOutput("numeric")
)
server <- function(input, output, session) {
  output$numeric <- renderUI({
    if (input$type == "slider") {
      sliderInput("dynamic", input$label, value = 0, min = 0, max = 10)
    } else {
      numericInput("dynamic", input$label, value = 0, min = 0, max = 10) 
    }
  })
}


图10.8 应用加载时（左），然后将类型更改为数值（中），再将标签更改为“我的标签”。查看实时效果请访问 https://hadley.shinyapps.io/ms-render-simple

如果你自己运行这段代码，你会发现应用在加载后需要一段时间才能显示。这是因为它是响应式的：应用必须先加载，触发一个响应事件，然后调用服务器函数，生成要插入页面的HTML。这是renderUI()的一个缺点；过多地依赖它可能会导致用户界面出现延迟。为了获得良好的性能，请尽量使用本章前面描述的技术，保持用户界面的固定部分。

这种方法还有一个问题：当你更改控件时，会丢失当前选定的值。在使用代码创建用户界面时，保留现有状态是一大挑战。这就是为什么如果适用，选择性显示和隐藏用户界面是更好的方法——因为你没有销毁和重新创建控件，所以不需要做任何事情来保留值。然而，在许多情况下，我们可以通过将新输入的值设置为现有控件的当前值来解决这个问题：

server <- function(input, output, session) {
  output$numeric <- renderUI({
    value <- isolate(input$dynamic)
    if (input$type == "slider") {
      sliderInput("dynamic", input$label, value = value, min = 0, max = 10)
    } else {
      numericInput("dynamic", input$label, value = value, min = 0, max = 10)
    }
  })
}

使用 isolate() 非常重要。我们将在 15.4.1 节中详细讨论它的作用，但在这里，它确保我们不会创建一个响应式依赖，导致每次 input$dynamic 发生变化时（每当用户修改值时都会发生）都重新运行此代码。我们只希望在 input$type 或 input$label 发生变化时更改它。

10.3.2 多个控件

当你需要生成任意数量或类型的控件时，动态用户界面（UI）最有用。这意味着你将使用代码生成用户界面，我建议使用函数式编程来完成此类任务。在这里，我将使用 purrr::map() 和 purrr::reduce()，但你也可以使用基础的 lapply() 和 Reduce() 函数来实现同样的效果。

1	library(purrr)

如果你不熟悉函数式编程中的 map() 和 reduce()，你可能希望在继续之前先阅读有关Functional programming的内容。我们也将在第 18 章中再次讨论这个想法。这些想法相当复杂，所以如果你在第一次阅读时没有理解，请不要担心。

为了具体说明，想象一下你想要用户能够提供自己的颜色调色板。他们首先会指定他们想要的颜色的数量，然后为每个颜色提供一个值。用户界面相当简单：我们有一个 numericInput() 来控制输入的数量，一个 uiOutput() 用于放置生成的文本框，以及一个 textOutput() 来证明我们已经正确地将所有内容连接在一起。

ui <- fluidPage(
  numericInput("n", "Number of colours", value = 5, min = 1),
  uiOutput("col"),
  textOutput("palette")
)

服务器函数很短，但包含了一些重要的想法：

server <- function(input, output, session) {
  col_names <- reactive(paste0("col", seq_len(input$n)))
  
  output$col <- renderUI({
    map(col_names(), ~ textInput(.x, NULL))
  })
  
  output$palette <- renderText({
    map_chr(col_names(), ~ input[[.x]] %||% "")
  })
}

我使用了一个响应式对象 col_names() 来存储即将生成的每个颜色输入的名称。
然后，我使用 map() 创建一个 textInput() 列表，每个列表项对应 col_names() 中的一个名称。renderUI() 随后将这个 HTML 组件列表添加到用户界面。
我需要使用一个新技巧来访问输入值。到目前为止，我们总是使用 $ 来访问输入的组件，例如 input$col1。但在这里，我们的输入名称存储在一个字符向量中，比如 var <- "col1"。在这种情况下，$ 不再适用，因此我们需要切换到 [[，即 input[[var]]。
我使用 map_chr() 将所有值收集到一个字符向量中，并在 output$palette 中显示。不幸的是，在浏览器渲染新输入之前，有一个短暂的时间段，其值会是 NULL。这会导致 map_chr() 报错，我们使用方便的 %||% 函数来解决这个问题：当左侧为 NULL 时，它返回右侧的值。

你可以在图 10.9 中看到结果。


图10.9 应用程序加载时（左），将n设置为3后（中），然后输入一些颜色（右）。请在https://hadley.shinyapps.io/ms-render-palette查看实时效果

如果你运行这个应用程序，你会发现一个非常恼人的行为：每当你改变颜色的数量时，所有输入的数据都会消失。我们可以使用与之前相同的技术来解决这个问题：将value设置为（孤立的）当前值。我还会稍微调整外观，使其看起来更漂亮一些，包括在图中显示所选颜色。示例截图如图10.10所示。

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      numericInput("n", "Number of colours", value = 5, min = 1),
      uiOutput("col"),
    ),
    mainPanel(
      plotOutput("plot")  
    )
  )
)

server <- function(input, output, session) {
  col_names <- reactive(paste0("col", seq_len(input$n)))
  
  output$col <- renderUI({
    map(col_names(), ~ textInput(.x, NULL, value = isolate(input[[.x]])))
  })
  
  output$plot <- renderPlot({
    cols <- map_chr(col_names(), ~ input[[.x]] %||% "")
    # convert empty inputs to transparent
    cols[cols == ""] <- NA
    
    barplot(
      rep(1, length(cols)), 
      col = cols,
      space = 0, 
      axes = FALSE
    )
  }, res = 96)
}


图10.10 填写彩虹的颜色（左），然后将颜色数量减少到3（右）；请注意，现有颜色被保留。实时效果请访问https://hadley.shinyapps.io/ms-render-palette-full查看实时效果

10.3.3 动态过滤

为了结束本章，我将创建一个应用程序，允许你动态过滤任何数据框。每个数值变量都会得到一个范围滑块，每个因子变量都会得到一个多选控件，所以（例如）如果一个数据框有三个数值变量和两个因子，应用程序将有三个滑块和两个选择框。

我将从一个为单个变量创建用户界面的函数开始。对于数值输入，它将返回一个范围滑块；对于因子输入，它将返回一个多选控件；对于其他所有类型，它将返回NULL（无）。

make_ui <- function(x, var) {
  if (is.numeric(x)) {
    rng <- range(x, na.rm = TRUE)
    sliderInput(var, var, min = rng[1], max = rng[2], value = rng)
  } else if (is.factor(x)) {
    levs <- levels(x)
    selectInput(var, var, choices = levs, selected = levs, multiple = TRUE)
  } else {
    # Not supported
    NULL
  }
}

接着，我将编写此函数的服务器端等效项：它接收输入控件的变量和值，并返回一个逻辑向量，说明是否包含每个观测值。使用逻辑向量可以轻松组合来自多个列的结果。

filter_var <- function(x, val) {
  if (is.numeric(x)) {
    !is.na(x) & x >= val[1] & x <= val[2]
  } else if (is.factor(x)) {
    x %in% val
  } else {
    # No control, so don't filter
    TRUE
  }
}

然后，我可以手动使用这些函数为 iris 数据集生成一个简单的过滤用户界面：

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      make_ui(iris$Sepal.Length, "Sepal.Length"),
      make_ui(iris$Sepal.Width, "Sepal.Width"),
      make_ui(iris$Species, "Species")
    ),
    mainPanel(
      tableOutput("data")
    )
  )
)
server <- function(input, output, session) {
  selected <- reactive({
    filter_var(iris$Sepal.Length, input$Sepal.Length) &
      filter_var(iris$Sepal.Width, input$Sepal.Width) &
      filter_var(iris$Species, input$Species)
  })
  
  output$data <- renderTable(head(iris[selected(), ], 12))
}

你可能注意到了，我已经厌倦了复制粘贴，所以这个应用程序只适用于三列。通过使用一些函数式编程，我可以让它适用于所有列：

在ui中，使用map()为每个变量生成一个控件。
在server()，我使用map()为每个变量生成选择向量。然后，我使用reduce()将每个变量的逻辑向量组合成一个单一的逻辑向量，通过&将每个向量连接在一起。

再次强调，如果你不完全理解这里发生了什么，请不要太过担心。主要的收获是，一旦你掌握了函数式编程，你就可以编写非常简洁的代码，从而生成复杂且动态的应用程序。

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      map(names(iris), ~ make_ui(iris[[.x]], .x))
    ),
    mainPanel(
      tableOutput("data")
    )
  )
)
server <- function(input, output, session) {
  selected <- reactive({
    each_var <- map(names(iris), ~ filter_var(iris[[.x]], input[[.x]]))
    reduce(each_var, ~ .x & .y)
  })
  
  output$data <- renderTable(head(iris[selected(), ], 12))
}

从此处开始，对其进行简单泛化，使其可以与任何数据框配合使用。在此，我将使用datasets包中的数据框进行说明，但你可以很容易地想象如何将其扩展到用户上传的数据。结果如图10.13所示。

dfs <- keep(ls("package:datasets"), ~ is.data.frame(get(.x, "package:datasets")))

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectInput("dataset", label = "Dataset", choices = dfs),
      uiOutput("filter")
    ),
    mainPanel(
      tableOutput("data")
    )
  )
)
server <- function(input, output, session) {
  data <- reactive({
    get(input$dataset, "package:datasets")
  })
  vars <- reactive(names(data()))
  
  output$filter <- renderUI(
    map(vars(), ~ make_ui(data()[[.x]], .x))
  )
  
  selected <- reactive({
    each_var <- map(vars(), ~ filter_var(data()[[.x]], input[[.x]]))
    reduce(each_var, `&`)
  })
  
  output$data <- renderTable(head(data()[selected(), ], 12))
}

10.3.4 对话框

在结束本章之前，我想提一下一个相关的技术：对话框。在8.4.1节中，你已经看到了对话框，其内容是固定的文本字符串。但由于modalDialog()是在服务器函数中调用的，因此你可以像renderUI()一样动态地生成内容。如果你想在继续常规应用程序流程之前强制用户做出某些决定，这是一个很有用的技术。

10.3.5 练习

根据本节中的初始示例，创建一个非常简单的应用程序：

ui <- fluidPage(
  selectInput("type", "type", c("slider", "numeric")),
  uiOutput("numeric")
)
server <- function(input, output, session) {
  output$numeric <- renderUI({
    if (input$type == "slider") {
      sliderInput("n", "n", value = 0, min = 0, max = 100)
    } else {
      numericInput("n", "n", value = 0, min = 0, max = 100)  
    }
  })
}

你如何使用动态可见性来实现它？如果你实现了动态可见性，当你更改控件时，如何保持值的同步？

解释这个应用程序是如何工作的。为什么当你第二次点击“输入密码”按钮时，密码会消失？

ui <- fluidPage(
  actionButton("go", "Enter password"),
  textOutput("text")
)
server <- function(input, output, session) {
  observeEvent(input$go, {
    showModal(modalDialog(
      passwordInput("password", NULL),
      title = "Please enter your password"
    ))
  })

  output$text <- renderText({
    if (!isTruthy(input$password)) {
      "No password"
    } else {
      "Password entered"
    }
  })
}

在·10.3.1·节的应用程序中，如果你从value <- isolate(input$dynamic)中去掉isolate()会发生什么？
为make_ui()和filter_var()添加对日期和日期时间列的支持。
（高级）如果你了解S3面向对象编程（S3 OOP）系统，请考虑如何使用通用函数替换make_ui()和filter_var()中的if块。

10.4 总结

在阅读本章之前，你只能在服务器函数运行之前静态地创建用户界面。现在你已经学会了如何根据用户操作修改用户界面并完全重新创建它。动态用户界面将极大地增加你的应用程序的复杂性，所以如果你发现自己很难调试正在发生的事情，不要感到惊讶。始终记住使用最简单的技术来解决你的问题，并回到5.2节中的调试建议。

下一章将转向讨论书签功能，使应用程序能够与他人共享当前状态。

加关注

关注公众号“生信之巅”。

敬告：使用文中脚本请引用本文网址，请尊重本人的劳动成果，谢谢！Notice: When you use the scripts in this article, please cite the link of this webpage. Thank you!

了尘兰若的小坑

分享微生物生物信息学分析方法，欢迎加入QQ群交流945751012，不接受群内广告！