menuItemOutput和renderMenu与模块- shinydashboard R.

Question

我有一个问题与menuItemOutput和renderMenu结合几个模块。仪表板应该从起始页开始。当点击此页面上的按钮时，其他选项卡(例如仪表板)应该出现在菜单中(实际上按钮会开始计算，解决方案将显示在以下选项卡中)。不幸的是，单击该按钮后不会出现新选项卡。我认为两个脚本之间的连接可能不起作用，但我没有发现错误。以下是我的简短脚本:

应用程序。R:

ui <- dashboardPagePlus(

#...shortened....

sidebar <- dashboardSidebar(
collapsed = TRUE,
sidebarMenu(
id = "navbar",
menuItem("Start",
tabName = "page_start",
icon = icon("play")),

menuItemOutput("rend_dashboard"),

#...shortened....    


)
),

body <- dashboardBody(
tags$script(HTML("$('body').addClass('fixed');")),
tabItems(
# Tab Start
tabItem(tabName = "page_start",
startUi("Start")),

# Tab Dashboard
tabItem(tabName = "page_dashboard",
overviewUi("Overview")),

#...shortened....

)
)

)

server <- function(input, output, session) {
startServer("Start")
overviewServer("Overview")
#...shortened....
}
shinyApp(ui = ui, server = server)

开始。R:

#UI-------------------------------------------------------------------------------------------------
startUi <- function(id) {
ns <- NS(id)

fluidPage(

#...shortened....
actionButton(
inputId = ns("start_btn"),
label = "Start",
icon = icon("play-circle")
),

#...shortened....
)
}

#Server---------------------------------------------------------------------------------------------
startServer <- function(id) {
moduleServer(id,
function(input, output, session) {

#Confirm button
observeEvent(input$start_btn, {

#Sidebar update
output$rend_dashboard <- renderMenu({
menuItem(
"Dashboard",
tabName = "page_dashboard",
icon = icon("dashboard")
)
} 
})

})

}

提前感谢!另外:为了更容易禁用点击菜单项并显示"被阻止"的可能性。符号时，点击菜单项，这对我来说也很好。

编辑(关于YBS的回答):最初我计划也使用shinyWidget弹出式。下面的表达式应该出现在开头。R服务器功能。仪表板页面应该显示在SweetAlert "start_confi_true"以"是"确认。

#Confirm button
observeEvent(input$start_btn, {
#browser()
if (input$start_check_promo == TRUE) {
confirmSweetAlert(
session = session,
inputId = "start_confi_true",
title = "Do you want to start the calculation?",
type = "warning",
btn_labels = c("No", "Yes")
)
#Sidebar update
reactive(input$start_btn)

} else
confirmSweetAlert(
session = session,
inputId = "start_confi_false",
title = "Please check the option side and try again",
type = "error",
btn_labels = c("Okay")
)
})

Answer 1

当您在主ui的侧边栏中显示menuItemOutput时，您可以在服务器端使用observeEvent，并从startServer传递操作按钮。试试这个

library(shinydashboardPlus)
#UI-------------------------------------------------------------------------------------------------
startUi <- function(id) {
ns <- NS(id)
tagList(
fluidPage(
#...shortened....
actionButton(
inputId = ns("start_btn"),
label = "Start",
icon = icon("play-circle")
),
plotOutput(ns("p1"))
#...shortened....
))
}
### startServer---------------------------------------------------------------------------------------------
startServer <- function(id) {
moduleServer(id,
function(input, output, session) {
output$p1 <- renderPlot(plot(cars))
#Confirm button
reactive(input$start_btn)
})
}
### runUi  --------------------------
runUi <- function(id) {
ns <- NS(id)
tagList(
checkboxInput(ns("start_check_promo"), "start check promo", TRUE),
plotOutput(ns("norm"))
#...shortened....
)
}
### runServer---------------------------------------------------------------------------------------------
runServer <- function(id, startbtn) {
moduleServer(id,
function(input, output, session) {
ns <- session$ns
observeEvent(startbtn(), {
output$norm <- renderPlot({hist(rnorm(500))})

if (input$start_check_promo == TRUE) {
confirmSweetAlert(
session = session,
inputId = "start_confi_true",
title = "Do you want to start the calculation?",
type = "warning",
btn_labels = c("No", "Yes")
)

} else
confirmSweetAlert(
session = session,
inputId = "start_confi_false",
title = "Please check the option side and try again",
type = "error",
btn_labels = c("Okay")
)
})
})
}
ui <- dashboardPagePlus(
header <- dashboardHeaderPlus(),
#...shortened....
sidebar <- dashboardSidebar(
collapsed = TRUE,
sidebarMenu(
id = "navbar",
menuItem("Start",
tabName = "page_start",
icon = icon("play")) ,
menuItem("Second",
tabName = "page_dashboard",
icon = icon("home")) ,
menuItemOutput("rend_dashboard")
#...shortened....

)
),
body <- dashboardBody(
#tags$script(HTML("$('body').addClass('fixed');")),
tabItems(
# Tab Start
tabItem(tabName = "page_start",
startUi("Start")),
# Tab Dashboard
tabItem(tabName = "page_dashboard", runUi("mod2")
),
tabItem(tabName = "page_dashboard2", plotOutput("unif")
)
#...shortened....
)
)
)

server <- function(input, output, session) {
btn <-  startServer("Start")
runServer("mod2",btn)
observeEvent(btn(), {
#Sidebar update
output$rend_dashboard <- renderMenu({
menuItem(
"Dashboard",
tabName = "page_dashboard2",
icon = icon("dashboard")
)
})
})
output$unif <- renderPlot({hist(runif(500))})
#overviewServer("Overview")
#...shortened....
}
shinyApp(ui = ui, server = server)