shinylive

shiny

可视化

R语言

构建shiny应用程序的一般流程及常用模板

作者

不止BI

发布于

2024年5月4日

在本文中，我们将探讨 Shiny 应用程序的构建过程。

任何一个 Shiny 应用程序都由三个部分组成：

用户界面（UI）：用户在应用程序中看到的内容
服务器功能（Server）：操作背后的服务处理（稍后详细介绍）
将 UI 和Server结合在一起的 ShinyApp() 函数调用

让我们先看看一个shiny应用程序的基本结构是什么样的，然后再逐个讨论前两个部分。

从空白页面开始

让我们从构建 UI 开始。创建 UI 最简单的方法是使用 bslib包中的 page_*() 系列函数，我们首先构造一个完全空白的app 。

bslib包

bslib包是一个用于创建基于Bootstrap的网页主题的工具包。它提供了一组现代化的CSS样式和JavaScript组件，可以帮助用户快速、简单地设计和定制网页主题。b slib包基于Bootstrap框架，提供了许多预定义的样式和布局选项，同时也支持用户自定义样式和主题。用户可以使用bslib包创建响应式、现代化的网页设计，适用于各种类型的网站和应用程序

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical
library(shiny)
library(bslib)
ui <- page_fluid()

server <- function(input, output, session) {
}

shinyApp(ui, server)

添加输入元素

要填充 UI 内容，可以使用输入元素。例如，可以在页面上添加滑块输入和下拉菜单。创建此类 UI 元素的两个函数是 sliderInput 和 selectInput。

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical
library(shiny)
library(bslib)
ui <- page_fluid(
  sliderInput(
    inputId = "slider1",
    label = "滑动筛选器",
    min = 0,
    max = 100,
    value = 0,
    step = 1
  ),
  selectInput(
    "select1",
    label = "下拉筛选器",
    choices = c("选项1", "选项2", "选项3")
  )
)


server <- function(input, output, session) {
}

shinyApp(ui, server)

如在代码中所见，每个输入函数都需要三个要素：

首先是一个 inputId,用于唯一识别输入元素，
然后是该 UI 元素的标签，
最后是特定于输入的参数

显然，不仅希望生成输入，我们还希望看到数据随输入变化而变化。这就是输出output的作用。

添加输出

可以使用专用的输出函数向 UI 添加各种不同的输出。例如，让我们使用 outputText() 函数添加一个文本输出。

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical
library(shiny)
library(bslib)
ui <- page_fluid(
  sliderInput(
    inputId = "slider1",
    label = "滑动筛选器",
    min = 0,
    max = 100,
    value = 0,
    step = 1
  ),
  selectInput(
    "select1",
    label = "下拉筛选器",
    choices = c("选项1", "选项2", "选项3")
  ),
  textOutput(outputId = "text1")
)

server <- function(input, output, session) {
}


shinyApp(ui, server)

现在查看应用程序，会发现还没有输出,一切看起来仍然一样。这是因为我们还没用构建server函数。

创建server函数

如前所述，server函数是 Shiny操作背后的大脑。函数确保应用程序中实际发生的事情。在 Shiny 框架中，server基本上只是一个带有输入、输出和会话参数的函数。正如我们之前所见，可以想象的最简单的server只是一个空函数。

每当用户界面中的某些内容被点击时，调用的这个函数 server，应该检测到发生了什么，并做出适当的反应。但为了做到这一点，server需要有指令来渲染/显示输出。

要渲染输出，必须在server内部为想要渲染的内容的输出 ID 分配一个渲染函数。听起来过于复杂，实际上非常简单。让我们看一个例子。

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical
library(shiny)
library(bslib)
ui <- page_fluid(
  sliderInput(
    inputId = "slider1",
    label = "滑动筛选器",
    min = 0,
    max = 100,
    value = 0,
    step = 1
  ),
  selectInput(
    "select1",
    label = "下拉筛选器",
    choices = c("选项1", "选项2", "选项3")
  ),
  textOutput(outputId = "text1")
)

server <- function(input, output, session) {
  output$text1 <- renderText({
    glue::glue(
      "当前滑动筛选器选中的值为:{input$slider1}",
      "当前下拉筛选选中:{input$select1}",
      .sep = "\n"
    )
  })
}


shinyApp(ui, server)

我们之前给 textOutput() 分配了 outputId: text1。因此，我们必须为 output$text1 分配渲染说明。为了分配这些说明，有 renderText() 函数。

渲染函数

请注意命名约定。在这里，我们使用 renderText() 来渲染 textOutput()。同样，对于各种不同的输出，有不同的渲染函数。例如，对于 plotOutput()，有 renderPlot()。

所有这些函数的工作方式都是相同的。基本上，通过 {} 将代码块放入这些渲染函数中，这些代码块中计算的最后一件事就是要显示的输出。

在这里，我们可以使用简单的 glue() 调用将从下拉输入和滑块输入中选择的内容粘贴在一起,当前显示在 UI 中的内容可以通过 input$<input_id> 很容易地访问。

要看到它的实际效果，只需使用的 UI 和server变量运行 shinyApp()

进阶操作

事件绑定及缓存计算

bindEvent可以让生成的对象对输入参数具有响应性依赖。例如，可以用它使观察者仅在按下按钮时执行。
在进行响应式的复杂计算时，可以使用bindCache将复杂计算存入缓存中。如果复杂计算的输入命中了历史的输入，则直接输出缓存的内容。

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical
library(shiny)
library(bslib)

ui <- page_fluid(
  sliderInput("x", "x", 1, 10, 5),
  sliderInput("y", "y", 1, 10, 5),
  actionButton("go", "开始计算"),
  div("x * y: "),
  verbatimTextOutput("txt")
)
server <- function(input, output) {
  r <- reactive({
    message("进行复杂计算中...")
    Sys.sleep(2)
    input$x * input$y
  }) |>
    bindCache(input$x, input$y, cache = "session") |>
    bindEvent(input$go)

  output$txt <- renderText(r())
}


shinyApp(ui, server)

非阻塞任务

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical
library(shiny)
library(bslib)
library(future)
library(promises)
future::plan(multisession)

ui <- page_fluid(
  p("The time is ", textOutput("current_time", inline = TRUE)),
  hr(),
  numericInput("x", "x", value = 1),
  numericInput("y", "y", value = 2),
  input_task_button("btn", "Add numbers"),
  textOutput("sum")
)

server <- function(input, output, session) {
  output$current_time <- renderText({
    invalidateLater(1000)
    format(Sys.time(), "%H:%M:%S %p")
  })

  sum_values <- ExtendedTask$new(function(x, y) {
    future_promise({
      Sys.sleep(5)
      x + y
    })
  }) |>
    bind_task_button("btn")

  observeEvent(input$btn, {
    sum_values$invoke(input$x, input$y)
  })

  output$sum <- renderText({
    sum_values$result()
  })
}

shinyApp(ui, server)

条件检查

req函数用于在执行特定代码块之前检查是否满足某些条件。通常用于在执行任何计算或显示输出之前验证输入或条件。如以下例子中，必须选中一个数据集，才会执行输出表格

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical
library(shiny)
library(bslib)
ui <- page_fluid(
  selectizeInput(
    "data",
    "选择一个数据集",
    c("", "cars", "mtcars", "pressure", "faithful")
  ),
  tableOutput("tbl")
)

server <- function(input, output) {
  output$tbl <- renderTable({
    req(input$data)

    head(get(input$data, "package:datasets", inherits = FALSE))
  })
}


shinyApp(ui, server)

自动刷新

invalidateLater可以让数据在指定时间后自动更新

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical

library(shiny)
library(bslib)


ui <- page_fluid(
  h2(textOutput("currentTime"))
)


server <- function(input, output, session) {
  output$currentTime <- renderText({
    invalidateLater(1000, session)
    paste("当前系统时间为:", Sys.time())
  })
}

shinyApp(ui, server)

模块扩展

通过module自定义shiny模块，将相同的功能封装为模块，可以避免重复代码，提高开发效率，让整体逻辑更加清晰

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 400
#| components: [editor, viewer]
#| layout: vertical

library(shiny)
library(bslib)

counterUI <- function(id, label = "Counter") {
  ns <- NS(id)
  tagList(
    actionButton(ns("button"), label = label),
    verbatimTextOutput(ns("out"))
  )
}

counterServer <- function(id) {
  moduleServer(
    id,
    function(input, output, session) {
      count <- reactiveVal(0)
      observeEvent(input$button, {
        count(count() + 1)
      })
      output$out <- renderText({
        count()
      })
      count
    }
  )
}

ui <- page_fluid(
  counterUI("counter1", "Counter #1"),
  counterUI("counter2", "Counter #2")
)
server <- function(input, output, session) {
  counterServer("counter1")
  counterServer("counter2")
}


shinyApp(ui, server)

权限控制

shinyauthr/shinymanager可以在前端添加权限控制

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 600
#| components: [editor, viewer]
#| layout: vertical
library(shiny)
library(tibble)
library(htmltools)
library(bslib)
# dataframe that holds usernames, passwords and other user data
user_base <- tibble::tibble(
  user = c("user1", "user2"),
  password = c("pass1", "pass2"),
  permissions = c("admin", "standard"),
  name = c("User One", "User Two")
)

ui <- page_fluid(
  # add logout button UI
  div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
  # add login panel UI function
  shinyauthr::loginUI(
    id = "login",
    additional_ui = div(
      img(
        src = "https://notjustbi.rbind.io/images/%E5%BE%AE%E4%BF%A1%E5%85%AC%E4%BC%97%E5%8F%B7.png",
        alt = "不止BI",
        height = "96px"
      ),
      style = "text-align: center;"
    )
  ),
  # setup table output to show user info after login
  tableOutput("user_table")
)

server <- function(input, output, session) {
  # call login module supplying data frame,
  # user and password cols and reactive trigger
  credentials <- shinyauthr::loginServer(
    id = "login",
    data = user_base,
    user_col = user,
    pwd_col = password,
    log_out = reactive(logout_init())
  )

  # call the logout module with reactive trigger to hide/show
  logout_init <- shinyauthr::logoutServer(
    id = "logout",
    active = reactive(credentials()$user_auth)
  )

  output$user_table <- renderTable({
    # use req to only render results when credentials()$user_auth is TRUE
    req(credentials()$user_auth)
    credentials()$info
  })
}


shinyApp(ui = ui, server = server)

常用组件及模板

bslib模板

shinyWidgets

常用对象汇总

读取url参数

代码

library(shiny)
ui <- bootstrapPage(
  h3("Url参数为:"),
  verbatimTextOutput("queryText")
)

server <- function(input, output, session) {
  output$queryText <- renderText({
    session$clientData$url_search
  })
}

shinyApp(ui = ui, server = server)

回到顶部