У меня есть эта начальная блестящая приборная панель, которую я собрал вместе:
## app.R ##
library(shiny)
library(shinydashboard)
library(readxl)
ui <- dashboardPage(
dashboardHeader(dropdownMenuOutput("messageMenu"),
dropdownMenuOutput("notificationMenu")),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("ImportForcast", tabName = "ImportForcast", icon = icon("arrow-down")),
menuItem("Visualization", tabName = "Visualization", icon = icon("dashboard")),
menuItem("Help", tabName = "Help", icon = icon("list-alt") ),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
)
),
## Body content
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "dashboard",
fluidRow(
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
)
)
),
tabItem(tabName = "ImportForcast",
fluidRow(
span(headerPanel("Import forcast file"), style="color:red"),
sidebarPanel(
radioButtons("pdt", "Choisir produit:",
c("Option1" = "Option1",
"Option2" = "Option2")),
fileInput('file1', 'Choose CSV File',
accept=c('text/csv', 'text/comma-separated-values,text/plain', '.csv')),
tags$hr()
),
actionButton("do", "Export/View"),
dataTableOutput('table'),
mainPanel(
# dygraphOutput("hdpePlot"),
textOutput("text"),
tableOutput('contents')
)
)
),
tabItem(tabName = "Visualization",
titlePanel("Forcast Dataset"),
sidebarLayout(
sidebarPanel(
radioButtons("x", "Select X-axis:",
list("date"='a')),
radioButtons("y", "Select Y-axis:",
list('X000'='f', "inflation"='b',"X004"='c',"X008"='d', "X009"='e','X014'='j'))
),
mainPanel(
textOutput("msg"),
plotOutput("distPlot")
)
)
),
tabItem(tabName = "Help",
fluidRow(
h2(" Help : "),
h1(" Installation guide : "),
h3(" Contact : "),
box(title = "Histogram", status = "primary", plotOutput("plot2", height = 250)),
box(
title = "Inputs", status = "warning",
"Box content here", br(), "More box content",
sliderInput("slider", "Slider input:", 1, 100, 50),
textInput("text", "Text input:")
),
box(
title = "Histogram", background = "maroon", solidHeader = TRUE,
plotOutput("plot4", height = 250)
),
box(
title = "Inputs", background = "black",
"Box content here", br(), "More box content",
sliderInput("slider", "Slider input:", 1, 100, 50),
textInput("text", "Text input:")
)
)
),
# Second tab content
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
)
#Server
server <- function(input, output) {
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
#Show success message if data is successfuly imported
output$text<- reactive({
validate(
need(is.null(input$file1) , "Import Success")
)
"Not imported file yet"
})
#Show msg that inform the user that he must import file before visualization
output$msg<- reactive({
validate(
need(!is.null(input$file1) , "You must import file for visualization")
)
"Enjoy visualisation"
})
output$dataForcast<- reactive({
dataForcast<- read_excel(input$file1)
})
dataForcast <- read_excel("./Forcast.xlsx",
sheet = 1, na = "NA",
skip = 1)
output$table <- renderDataTable(dataForcast)
# Saving files
saveRDS(dataForcast,file="./forcast/RDS/dataForcast.Rds")
write.csv(dataForcast, file = "./forcast/RDS/dataForcastt.csv", row.names = FALSE)
df <- eventReactive(input$do, {
dataForcast <- read_excel("./Forcast.xlsx",
sheet = 1, na = "NA",
skip = 1)
output$table <- renderDataTable(dataForcast)
})
# output$do<- reactive({
#
# output$table <- renderDataTable(dataForcast)
# })
#The visualisation of the data
output$distPlot<- renderPlot({
if(!is.null(input$file1) )
{
if(input$x=='a'){
i<-1}
if(input$y=='b'){
j<-54}
if(input$y=='c'){
j<-4}
if(input$y=='d'){
j<-9}
if(input$y=='e'){
j<-10 }
if(input$y=='f'){
j<-2 }
if(input$y=='j'){
j<-14 }
s <- dataForcast[, i]
k <- dataForcast[, j]
x2 <- data.frame(s,k)
plot(x2)
}
})
#Notification is generated on the server
output$notificationMenu <- renderMenu({
#Initalisation of notification
col_headings <- c('message','status')
# notificationData <- data.frame(' 12 items delivered', 'success')
notificationData<- read.csv('msgs.csv')
names(notificationData) <- col_headings
#add a notification of success importation
if(!is.null(input$file1))
{
not_sucess<- data.frame('Import Success', 'success')
names(not_sucess) <- col_headings
notificationData<-rbind(not_sucess, notificationData)
}
nots <- apply(notificationData, 1, function(row) {
notificationItem(text = row[["message"]], status = row[["status"]])
})
dropdownMenu(type = "notifications", .list = nots)
})
#Message is generated on the server
output$messageMenu<- renderMenu({
dropdownMenu(type = "messages",
messageItem(
from = "Sales Dept",
message = "Sales are steady this month."
),
messageItem(
from = "New User",
message = "How do I register?",
icon = icon("question"),
time = "13:45"
),
messageItem(
from = "Support",
message = "The new server is ready.",
icon = icon("life-ring"),
time = "2014-12-01"
)
)
})
}
shinyApp(ui, server)
Я попытался добавить страницу входа, но это не удалось:
library(shiny)
library(shinydashboard)
source("admin.R")
my_username <- c("test","admin")
my_password <- c("test","123")
get_role=function(user){
if(user=="test") {
return("TEST")
}else{
return("ADMIN")
}
}
get_ui=function(role){
itog=list()
if(role=="TEST"){
itog$title=test_title
itog$main=test_main
itog$side=test_side
return(itog)
}else{
itog$title=admin_title
itog$main=admin_main
itog$side=admin_side
return(itog)
}
}
shinyServer(function(input, output,session) {
USER <- reactiveValues(Logged = FALSE,role=NULL)
ui1 <- function(){
tagList(
div(id = "login",
wellPanel(textInput("userName", "Username"),
passwordInput("passwd", "Password"),
br(),actionButton("Login", "Log in")))
,tags$style(type="text/css", "#login {font-size:10px; text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -10px;margin-left: -150px;}")
)}
observe({
if (USER$Logged == FALSE) {
if (!is.null(input$Login)) {
if (input$Login > 0) {
Username <- isolate(input$userName)
Password <- isolate(input$passwd)
Id.username <- which(my_username == Username)
Id.password <- which(my_password == Password)
if (length(Id.username) > 0 & length(Id.password) > 0) {
if (Id.username == Id.password) {
USER$Logged <- TRUE
USER$role=get_role(Username)
}
}
}
}
}
})
observe({
if (USER$Logged == FALSE) {
output$page <- renderUI({
box(
div(class="outer",do.call(bootstrapPage,c("",ui1()))))
})
}
if (USER$Logged == TRUE) {
output$page <- ui # ui from the first dashboard
}
})
})
Со вторым кодом я получаю окно входа в систему, как на снимке экрана: https://www.screencast.com/t/CO4eiba8fbdN
После того, как я изменил этот блок:
if (USER$Logged == TRUE) {
output$page <- ui # ui from the first dashboard
}
У меня отображается новый интерфейс, но старое боковое меню все еще там, так что это панель инструментов внутри другой панели инструментов, потому что я только что интегрировал весь интерфейс только в страницу вывода $.
Есть ли более простое решение для добавления страницы входа в первую панель инструментов? Или способ интегрировать логин (второй код) с первой информационной панелью (первый код), чтобы пользователь мог войти в систему и отображалась информационная панель?
