具有Shiny和数据库的企业级仪表板
image.png
在企业内部，仪表板应该具有最新信息，尽管有大量数据支持它，但在任何设备上都可以获得快速响应时间。最终用户可能希望单击图中的条形图或列将导致更详细的报告或构成该编号的实际记录列表。本文将介绍如何使用一组R软件包以及Shiny来满足这些要求。
代码
上图所示仪表板的工作示例如下：航班仪表板。该示例具有本文中讨论的所有功能，但数据库连接除外。仪表板的代码可在此Gist：app.R中找到
实际连接到数据库的仪表板代码可在此Gist：app.R中找到
shinydashboard
该shinydashboard包有三个重要的优点：
-
提供开箱即用的框架，以在Shiny中创建仪表板。这节省了大量时间，因为开发人员不必使用“base”Shiny手动创建仪表板功能。
-
具有仪表板 - 友好标签结构。这允许开发人员快速入门。内dashboardPage()标签，在dashboardHeader()，dashboardSidebar()并且dashboardBody()可以添加到容易制定出一个新的仪表板。
-
它是移动就绪的。没有任何其他代码，仪表板布局将自动适应较小的屏幕。
快速举例
如果您是新手shinydashboard，请随意复制并粘贴以下代码，以查看您环境中非常简单的仪表板：
library(shinydashboard)
library(shiny)
ui <- dashboardPage(
dashboardHeader(title = "Quick Example"),
dashboardSidebar(textInput("text", "Text")),
dashboardBody(
valueBox(100, "Basic example"),
tableOutput("mtcars")
)
)
server <- function(input, output) {
output$mtcars <- renderTable(head(mtcars))
}
shinyApp(ui, server)
部署使用 config
在开发过程中使用的凭据与用于发布的凭证不同是很常见的。对于数据库，适应此目的的最佳方法是在两个环境中设置具有相同别名的数据源名称（DSN）。如果无法设置DSN，则config可以使用该程序包在不同环境中使用的凭据之间切换不可见。该RStudio连接产品支持使用的config包装开箱。使用config代替Kerberos或DSN的另一个优点是使用的凭证不会出现在R代码的纯文本中。Make scripts可移植文章中提供了更详细的说明。
此代码段是一个config能够读取的示例YAML文件。它有一个用于本地开发的驱动程序名称，以及在部署期间使用的其他名称：
default:
mssql:
Driver: "SQL Server"
Server: "[server's path]"
Database: "[database name]"
UID: "[user id]"
PWD: "[pasword]"
Port: 1433
rsconnect:
mssql:
Driver: "SQLServer"
Server: "[server's path]"
Database: "[database name]"
UID: "[user id]"
PWD: "[pasword]"
Port: 1433
default开发时将自动使用该设置，并且RStudio Connect将rsconnect在执行此代码时使用这些值：
dw <- config::get("mssql")
con <- DBI::dbConnect(odbc::odbc(),
Driver = dw$Driver,
Server = dw$Server,
UID = dw$UID,
PWD = dw$PWD,
Port = dw$Port,
Database = dw$Database)
purrr
Shiny输入从表或查询中检索它们的值是很常见的。由于仪表板中的其他查询将使用所选输入进行相应过滤，因此传递给其他查询所需的值通常是标识代码，而不是下拉列表中显示的标签。要将键与值分开，可以使用包中的map()函数purrr。在下面的示例中，收集airlines表中的所有记录，并创建名称列表，map()然后将运营商代码插入每个名称节点。
# This code runs in ui
airline_list <- tbl(con, "airlines") %>%
collect %>%
split(.$name) %>% # Place here the field that will be used for the labels
map(~.$carrier) # Place here the field that will be used for keys
在selectInput()下拉菜单能够读取所产生的airline_list列表变量。
# This code runs in ui
selectInput(
inputId = "airline",
label = "Airline:",
choices = airline_list) # Use airline_list as the choices argument value
dplyr
仪表板通常具有公共数据主题，该主题源自公共数据集。可以构建基本查询，因为dplyr转换为封面下的SQL，并且由于“懒惰”，在从其请求某些内容之前不会评估查询。
db_flights <- tbl(con, "flights") %>%
left_join(tbl(con, "airlines"), by = "carrier") %>%
rename(airline = name) %>%
left_join(tbl(con, "airports"), by = c("origin" = "faa")) %>%
rename(origin_name = name) %>%
select(-lat, -lon, -alt, -tz, -dst) %>%
left_join(tbl(con, "airports"), by = c("dest" = "faa")) %>%
rename(dest_name = name)
dplyr然后，该变量可用于多个Shiny输出。第二个例子是用于构建下highcharter图的代码。
output$total_flights <- renderValueBox({
result <- db_flights %>% # Use the db_flights variable
filter(carrier == input$airline)
if(input$month != 99) result <- filter(result, month == input$month)
result <- result %>%
tally %>%
pull %>% # Use pull to get the total count as a vector
as.integer()
valueBox(value = prettyNum(result, big.mark = ","),
subtitle = "Number of Flights")
})
深入研究
“向下钻取”操作的想法是最终用户能够看到构成仪表板中显示的聚合结果的部分或全部数据。“向下钻取”动作有两个部分：
- 单击显示结果的仪表板元素。结果通常是汇总数据。
- 将显示一个带有其他报告的新屏幕。新报告可能是另一个显示较低级别聚合的报告，也可能显示构成结果的行列表。
单击仪表板元素
以下是捕获点击事件的一种方法。我们的想法是在条形图中显示给定航空公司的顶级机场目的地。单击一个条形时，所需的结果是绘图激活向下钻取。该highcharter示例中将使用该程序包。
要捕获条形单击事件highcharter，需要编写一个小的JavaScript。在大多数情况下，可以使用以下示例，因此您可以将其原样复制并粘贴到代码中。变量名称和输入名称（bar_clicked）将是唯一必须更改以匹配您的图表的两个语句。
js_bar_clicked <- JS("function(event) {Shiny.onInputChange('bar_clicked', [event.point.category]);}")
上面的命令在R中创建了一个新的JavaScript，可以跟踪单击一个栏的时间。以下是代码的细分：
- JS - 表示以下函数是JavaScript
- function（event） - 创建一个新函数，并期望一个event变量。Highchart将传递的事件是单击一个栏，因此event将包含有关该给定栏的信息。
- Shiny.onInputChange - JavaScript将用于与Shiny交互的函数
- bar_clicked - 是新Shiny输入的名称; 它的值将默认为下一个项目
- [event.point.category] - 传递点击的点的类别值
下一节将说明如何捕获新变化input$bar_clicked，并执行“向下钻取”的第二部分。
在renderHighchart()输出函数中，包含JavaScript的变量作为事件列表的一部分传递：events = list(click = js_bar_clicked))。因为事件在hc_add_series()创建条形图的内部，所以这样的点击事件与单击条形图相关联。
output$top_airports <- renderHighchart({
# Reuse the dplyr db_flights variable as the base query
result <- db_flights %>%
filter(carrier == input$airline)
if(input$month != 99) result <- filter(result, month == input$month)
result <- result %>
group_by(dest_name) %>%
tally() %>%
arrange(desc(n)) %>%
collect %>%
head(10)
highchart() %>%
hc_add_series(
data = result$n,
type = "bar",
name = paste("No. of Flights"),
events = list(click = js_bar_clicked)) %>% # The JavaScript variable is called here
hc_xAxis(
categories = result$dest_name, # Value in event.point.category
tickmarkPlacement="on")})
使用appendTab()
计划是每次最终用户点击栏时显示新的向下钻取报告。为了防止不必要地拉出相同的数据，代码将足够智能，如果之前点击了相同的栏，则只需将焦点切换到现有选项卡。
新的，非常酷的appendTab()函数用于动态创建一个新的Shiny选项卡，其中包含DataTable，其中包含选择的前100行。名为的简单向量tab_list用于跟踪所有现有详细信息选项卡。该updateTabsetPanel()功能用于切换到新创建或以前创建的选项卡。
该observeEvent()函数是“捕获”JavaScript执行的事件的函数，因为它监视bar_clickedShiny输入。评论将添加到下面的代码中，以涵盖如何使用这些功能的更多方面。
tab_list <- NULL
observeEvent(input$bar_clicked,{
airport <- input$bar_clicked[1] # Selects the first value sent in [event.point.category]
tab_title <- paste(input$airline, # tab_title is the tab's name and unique identifier
"-", airport ,
if(input$month != 99)
paste("-" , month.name[as.integer(input$month)]))
if(tab_title %in% tab_list == FALSE){ # Checks to see if the title already exists
details <- db_flights %>% # Reuses the db_flights dbplyr variable
filter(dest_name == airport, # Uses the [event.point.category] value for the filter
carrier == input$airline) # Matches the current airline filter
if(input$month != 99) # Matches the current month selection
details <- filter(details, month == input$month)
details <- details %>%
head(100) %>% # Select only the first 100 records
collect() # Brings the 100 records into the R environment
appendTab(inputId = "tabs", # Starts a new Shiny tab inside the tabsetPanel named "tabs"
tabPanel(
tab_title, # Sets the name & ID
DT::renderDataTable(details) # Renders the DataTable with the 100 newly collected rows
))
tab_list <<- c(tab_list, tab_title) # Adds the new tab to the list, important to use <<-
}
# Switches over to a panel that matched the name in tab_title.
# Notice that this function sits outside the if statement because
# it still needs to run to select a previously created tab
updateTabsetPanel(session, "tabs", selected = tab_title)
})
使用removeTab()和删除所有选项卡purrr
动态创建新选项卡可能会使仪表板混乱。因此，actionLink()可以添加一个简单的按钮dashboardSidebar()，以删除除主仪表板选项卡以外的所有选项卡。
# This code runs in ui
dashboardSidebar(
actionLink("remove", "Remove detail tabs"))
observeEvent()再次使用该函数来捕获单击链接的时间。在walk()从命令purrr然后被用于通过在每个选项卡的标题迭代tab_list向量，并且前进到执行闪亮removeTab()每个名称命令。之后，重置选项卡列表变量。由于环境范围，确保<<-在重置变量时使用double小于（），因此它知道重置在函数外部定义的变量observeEvent()。
# This code runs in server
observeEvent(input$remove,{
# Use purrr's walk command to cycle through each
# panel tabs and remove them
tab_list %>%
walk(~removeTab("tabs", .x))
tab_list <<- NULL
})
结论
此示例使用Shinydashboard创建企业仪表板，但也有其他技术。Flexdashboard是在R Markdown中构建类似企业仪表板的好方法。我们使用SQL Server填充此仪表板，但您可以使用任何数据库。有关使用R的数据库的更多信息，请参阅http://db.rstudio.com/。
