Я работаю над приложением shinydashboard с несколькими вкладками, и я хочу отображать содержимое вкладок только при нажатии на него. Я использую библиотеку shinydashboard для создания панели инструментов, приложению требуется около 30 секунд c, и я хотел бы оптимизировать ее, чтобы она отображала только выбранную вкладку.
Пример кода пользовательского интерфейса
dashboardPage(
dashboardHeader(title = "Enrollment Dashboard",titleWidth = 300),
sidebar <- dashboardSidebar(width = 300,
sidebarMenu(
menuItem("Descriptive Analysis", icon = icon("right",lib='glyphicon'), tabName = "desc",
menuSubItem("Statistics",icon = icon("right",lib='glyphicon'),tabName = "kpi" ),
menuSubItem("Marketing" ,icon = icon("right",lib='glyphicon'), tabName = "markd")),
menuItem("Predictive Analysis", icon = icon("right",lib='glyphicon'), tabName = "predictive",
menuItem("Enrollment Number", icon = icon("right",lib='glyphicon'), tabName = "predictive",
menuSubItem("Enrollment prediction - overall" ,icon = icon("right",lib='glyphicon'), tabName = "predictivesummary"),
menuItem("Enrollment prediction per program" , icon = icon("right",lib='glyphicon'),tabName = "predictiveprograms"))
dashboardBody(
tags$head(tags$link(rel = "stylesheet" , type = "text/css" , href = "reload.CSS")),
renderText("test"),
tabItems(tabItem(tabName = "kpi",
frow1<-fluidRow(
infoBoxOutput("value1",width = 3),tags$style("#value1 { padding-top:0px; padding-bottom:0px;color: blue; font-size: 13px;background:#F4F4F4;}"),
infoBoxOutput("value2",width = 3),tags$style("#value2 { padding-top:0px; padding-bottom:0px;color: blue; font-size: 13px;background:#F4F4F4;}"),
box
(uiOutput("value3"),
width = 1,
height = 130
),
box
(uiOutput("value5"),
width = 1,
height = 130
),
box
(uiOutput("value6"),
width = 1,
height = 130
),
infoBoxOutput("value4",width = 3),tags$style("#value4 {padding-top:0px; padding-bottom:0px;color: blue; font-size: 13px;background:#F4F4F4;}")
),
frow2<-fluidRow(
box(
title = "Inquiry (Actuals- Green/Target- Light Grey)"
,width = 3
,height = 330
,status = "warning"
,solidHeader = FALSE
,collapsible = TRUE
,dataTableOutput("plot")
),
box(
title = "Applied (Actuals- Green/Target- Light Grey)"
,width = 3
,status = "warning"
,solidHeader = FALSE
,collapsible = TRUE
,plotlyOutput("applyplot", height = 270)
),
box(
title = "Processed (Actuals- Green/Target- Light Grey)"
,width = 3
,status = "warning"
,solidHeader = FALSE
,collapsible = TRUE
,plotlyOutput("processedplot", height = 270)
),
box(
title = "Enrolled (Actuals- Green/Target- Light Grey)"
,width = 3
,status = "warning"
,solidHeader = FALSE
,collapsible = TRUE
,plotlyOutput("enrolledplot", height = 270)
)),
frow3<-fluidRow(
box(
title = "Enrollment Yearly Progress Growth / Programs "
,width = 12
,solidHeader = FALSE
,collapsible = TRUE
,status = "warning",
tabsetPanel( type = 'pills',
tabPanel('Admissions',
plotlyOutput("threerow", height = 350)
),
tabPanel('Financial',plotlyOutput("frow", height = 350)),
tabPanel('Enrollment',plotlyOutput("erow", height = 350))
)
))
),
tabItem(tabName = "predictivesummary" ,
frow5<- fluidRow(
box("Yearly Predictive Analysis"
,width = 12
,solidHeader = FALSE
,collapsible = TRUE
,status = "warning"
,plotlyOutput("plot_forecast" , height = 350) )),
frow501<- fluidRow(
box("Overall Prediction Yearly - Tabular"
,width = 12
,solidHeader = FALSE
,collapsible = TRUE
,status = "warning"
,dataTableOutput("year_table" , height = 350) ))
)
Сервер
shinyServer(function(input, output ,session ) {
output$value1 <- renderInfoBox({
infoBox(
h2(total.TotalInquiry()),
h4(percentage.TotalInquiry())
,tags$h5('Inquries - Target : ' , total.TargetInquiry())
,
icon = icon("question-sign",lib='glyphicon')
)})
output$value2 <- renderInfoBox({
infoBox(
h2(total.Applied()),
h4(percentage.Applied())
,h5('Applied-Target:',target.Applied())
,
icon = icon("thumbs-up",lib='glyphicon'))
})
output$value3 <- renderText({
paste0(h3(ProcessedA.Accepted()) ,
paste0(percentagepA.Accepted(),'%'),
paste0(),
h5('Processed:' , ProcessedT.Accepted()))
})
output$value5 <- renderText({enter code here
paste0(h3(Processed.Rejected()),h6('Rejected:' ))
})
output$value6 <- renderText({
paste0(h3(Processed.Dropped()),h6('Withdrawan:' ))
})
output$value4 <- renderInfoBox({
infoBox(
#tags$h2(total.enrolled() ,'~' , percentage.enrolled())
tags$h2(total.enrolled()),
h4(percentage.enrolled())
,tags$h5('Enrolled-Target:',target.enrolled())
,
#color = "olive" , fill = TRUE
icon = icon("check",lib='glyphicon') )
})
output$plot <- DT::renderDataTable(expr ={
g <- IA.Applied()
} , options = list(dom = 't',scrollX = TRUE,autowidth = TRUE,columnDefs = list(list(width = '10px', targets = c(1,3)))))
output$applyplot <- renderPlotly(expr ={
g <- IAA.Applied() %>%
mutate(group = 1) %>%
ggplot(aes(Program, Applied_Act)) +
ylim(0,150)+
geom_col(fill = "#b0e0e6") +
geom_text(aes(label = Applied), position = position_dodge(0.3),family = "Times New Roman",size = 3)+
geom_col(aes(y = applied_Tar, group = group), color = "#e7e7e7" ,fill = "#A3A9D1", alpha=0.3) +
theme_classic()+
labs(x = "", y = "")
ggplotly(g, tooltip = "Applied")
})
output$processedplot <- renderPlotly(expr ={
g <- IA.processed() %>%
mutate(group = 1) %>%
ggplot(aes(Program, Act_Processed)) +
ylim(0,150)+
geom_col(fill = "#b0e0e6") +
geom_text(aes(label = Processed), position = position_dodge(0.3),family = "Times New Roman",size = 3)+
geom_col(aes(y = Tar_processed, group = group), color = "#e7e7e7" ,fill = "#A3A9D1", alpha=0.3) +
theme_classic()+
labs(x = "", y = "")
ggplotly(g, tooltip = "Processed")
})