R Shiny: боковая панель не отображается правильно при использовании lapply () - PullRequest
Новая
       9

R Shiny: боковая панель не отображается правильно при использовании lapply ()

0 голосов
/ 04 октября 2019

Я пытаюсь создать боковую панель с помощью 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))
         })

         )




})

Это не похоже на работу.

Любая помощь будет принята с благодарностью! Спасибо!

1 Ответ

0 голосов
/ 04 октября 2019

Есть две проблемы с вашим кодом. Во-первых: для включения menuItem() динамически используйте menuItemOutput(), а не sidebarMenuOutput(). Тем не менее, более сложным является второй вопрос.

Вы хотите передать список (результат lapply()) аргументу ..., равному menuItem(). Это следует сделать с помощью do.call(), чтобы расширить список на несколько аргументов. В противном случае у вас в основном будет вызов следующей формы 

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

, который не будет правильно отображаться в блестящем приложении. Это связано с тем, что menuItem ожидает, что все аргументы (кроме name и некоторых других специальных аргументов) будут иметь подэлемент "type", а не список типов. 

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

do.call() можно использовать для получениявокруг этой сложности: следующий блок создает тот же тег пользовательского интерфейса, что и последний блок. 

## 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(). Кроме того, явная установка атрибутов класса обычно не является хорошей привычкой, если вы не являетесь соавтором в коде класса.

...