R 闪亮:使用 lapply() 时侧边栏显示不正确

Question

我正在尝试使用 lapply(( 创建一个侧边栏。

以下是我想要的：

header  = dashboardHeader(title = "Performance Dashboard", titleWidth = 320)
weekSelectSidebar  = sliderInput(inputId = "week", label = "Select Week in Semster:", min = 1, max = 3, value = 1, step = 1)
taskeSelectSidebar = menuItem("Enter Completed Tasks", tabName = "tasks", icon = icon("th"),
conditionalPanel(condition =" input.week == '1' ", menuSubItem(text = "Week 1", tabName = "W1")),
conditionalPanel(condition =" input.week == '2' ", menuSubItem(text = "Week 1", tabName = "W1"),
     menuSubItem(text = "Week 2", tabName = "W2")),
conditionalPanel(condition =" input.week == '3' ", menuSubItem(text = "Week 1", tabName = "W1"),
     menuSubItem(text = "Week 2", tabName = "W2"),
     menuSubItem(text = "Week 3", tabName = "W3")))

sidebar = dashboardSidebar(sidebarMenu(id = "sidebarMenu", weekSelectSidebar, taskSelectSidebar, width = 320))
body = dashboardBody()
ui   = dashboardPage(header, sidebar, body)
server = function(input, output) {}

我有 12 周的时间要完成，所以我想使用 lapply((。我尝试了以下方法：

header  = dashboardHeader(title = "Performance Dashboard", titleWidth = 320)
weekSelectSidebar  = sliderInput(inputId = "week", label = "Select Week in Semster:", min = 1, max = 3, value = 1, step = 1)
sidebar = dashboardSidebar(sidebarMenu(id = "sidebarMenu", weekSelectSidebar, sidebarMenuOutput("TaskSelect"), width = 320))
body = dashboardBody()
ui   = dashboardPage(header, sidebar, body)
server = function(input, output) {

output$TaskSelect = renderMenu({
w = input$week
menuItem("Enter Completed Tasks:",
icon = icon("th"),
lapply(1:w, function(i) {
menuSubItem(text = paste0("Week ", i), tabName = paste0("W", i))
})
)


})

这似乎行不通。

任何帮助将不胜感激！ 谢谢！

Answer 1

您的代码有两个问题。第一：要动态包含menuItem()，请使用menuItemOutput()，而不是sidebarMenuOutput()。然而，更棘手的是第二个问题。

您想将列表(lapply()的结果(传递给menuItem()的...参数。这应该通过do.call()将列表扩展为几个参数来完成。否则，您基本上具有以下形式的调用

## not rendered correctly
menuItem(
name = "Enter Completed Tasks:",
list(
sub_items[[1]],
sub_items[[2]]
) 
)

这在闪亮的应用程序中无法正确呈现。这是因为menuItem期望所有参数(name和其他一些特殊参数除外(都属于"类型"子项，而不是类型列表。

## rendered correctly
menuItem(
name = "Enter Completed Tasks:",
sub_items[[1]],
sub_items[[2]]
)

do.call()可用于解决此复杂性：以下区块创建与最后一个区块相同的 UI 标记。

## rendered correctly
do.call(
munuItem,
list(name = "Enter Completed Tasks:", sub_items[[1]], sub_items[[2]])
)

基于您的测试用例的可重现解决方案：

library(shiny)
library(shinydashboard)
weekSelectSidebar  = sliderInput(
inputId = "week", 
label = "Select Week in Semster:", 
min = 1, max = 3, value = 1, step = 1)
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarMenu", 
weekSelectSidebar, 
menuItemOutput("TaskSelect"),              ## use the appropriate output function
width = 320
)
)
ui   = dashboardPage(dashboardHeader(), sidebar, dashboardBody())
server = function(input, output) {
output$TaskSelect = renderMenu({
w = input$week
sub_items <- lapply(1:w, function(i) {
menuSubItem(text = paste0("Week ", i), 
tabName = paste0("W", i))
})
do.call(                                   ## use do.call() to pass a list to ...
menuItem,
args = c(name = "Enter Completed Tasks:", sub_items)
)
})
}
shinyApp(ui, server)

替代方法

除了使用do.call()，还可以将sub_items的类型更改为tag.list。有关文档，请参阅?shiny::tagList。

server = function(input, output) {
output$TaskSelect = renderMenu({
w = input$week
sub_items <- lapply(1:w, function(i) {
menuSubItem(text = paste0("Week ", i), tabName = paste0("W", i))
})
class(sub_items) <- c("list", "tag.list")
menuItem(text = "Enter Completed Tasks:", sub_items)
})
}

我个人建议使用do.call()的解决方案，因为它更符合menuItem()的参数文档。此外，显式设置类属性通常不是一个好习惯，除非您是类代码的协作者。