如何将 InputButtons 放置在 R shinydashboard 的 Header 中（使用可能是 CSS,JS,html）
How to place InputButtons in the Header of R shinydashboard (using may be CSS,JS,html)
我有以下 proto-type 我闪亮的应用程序，有两个页面和每个页面中的两个 selectInput 按钮。
ui <- dashboardPage(
dashboardHeader(title = "Header",
dropdownMenuOutput("updatedTimeOutput"),
dropdownMenu(type = "notifications",
badgeStatus = "warning",
icon = icon("bullhorn", "fa-lg"),
notificationItem(icon = icon("bullhorn", "fa-1x"),
status = "info",
text = tags$span(
tags$b("Please notice!")
)
))),
dashboardSidebar( sidebarMenu(id = "tabs",
menuItem("Page1", tabName = "page1"),
menuItem("Page2", tabName = "page2"))),
dashboardBody(
tabItems(
tabItem(
tabName = "page1",
fluidRow(column(2,
selectInput("count1", "Select a category", c("1", "2"))),
column(2,selectInput("count2", "Select a subcategory1",
c("cat1", "cat2", "cat3", "cat4")))),
fluidRow(infoBoxOutput("ibox1")),
fluidRow(valueBoxOutput("vbox1"))
)
,
tabItem(
tabName = "page2",
fluidRow(column(2,
selectInput("count3", "Select a category", c("1", "2"))),
column(2, selectInput("count4", "Select a subcategory2",
c("sub1", "sub2", "sub3", "sub4")))),
fluidRow(infoBoxOutput("ibox2")),
fluidRow(valueBoxOutput("vbox2")
)
)
)
)
)
server <- function(input, output) {
output$ibox1 <- renderInfoBox({
infoBox(
"Title",
input$count1,
icon = icon("credit-card")
)
})
output$vbox1 <- renderValueBox({
valueBox(
"Title",
input$count2,
icon = icon("credit-card")
)
})
output$ibox2 <- renderInfoBox({
infoBox(
"Title",
input$count3,
icon = icon("credit-card")
)
})
output$vbox2 <- renderValueBox({
valueBox(
"Title",
input$count4,
icon = icon("credit-card")
)
})
}
shinyApp(ui, server)
如果应用程序是 运行，我们将在每个页面的 body 中看到两个 selectInput 按钮。是否可以将每个页面中的 selectInput 按钮移动到 header，使其看起来像：
第 1 页：
第 2 页：
inputButtons 应该放在 header 中并且应该显示每个页面的相应输入。如果可以使用任何自定义 CSS 或 javascript 或 html 在闪亮的应用程序中完成，有人可以提供帮助吗？
试试这些 CSS 技巧，适合移动设备。
- 当屏幕太小时，自动返回到选项卡。
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Header"),
dashboardSidebar( sidebarMenu(id = "tabs",
menuItem("Page1", tabName = "page1"),
menuItem("Page2", tabName = "page2"))),
dashboardBody(
tabItems(
tabItem(
tabName = "page1",
fluidRow(class = "select-to-top", column(2,
selectInput("count1", "Select a category", c("1", "2"))),
column(2,selectInput("count2", "Select a subcategory1",
c("cat1", "cat2", "cat3", "cat4")))),
fluidRow(infoBoxOutput("ibox1")),
fluidRow(valueBoxOutput("vbox1"))
)
,
tabItem(
tabName = "page2",
fluidRow(class = "select-to-top", column(2,
selectInput("count3", "Select a category", c("1", "2"))),
column(2, selectInput("count4", "Select a subcategory2",
c("sub1", "sub2", "sub3", "sub4")))),
fluidRow(infoBoxOutput("ibox2")),
fluidRow(valueBoxOutput("vbox2")
)
)
),
tags$style(HTML(
"@media (min-width: 767px) {
.select-to-top {
position: fixed;
top: 0;
left: 49%;
width: 1000px;
z-index: 9999;
}
.main-header .logo {
height: 80px;
}
.left-side, .main-sidebar {
padding-top: 80px;
}
}
"
))
)
)
server <- function(input, output) {
output$ibox1 <- renderInfoBox({
infoBox(
"Title",
input$count1,
icon = icon("credit-card")
)
})
output$vbox1 <- renderValueBox({
valueBox(
"Title",
input$count2,
icon = icon("credit-card")
)
})
output$ibox2 <- renderInfoBox({
infoBox(
"Title",
input$count3,
icon = icon("credit-card")
)
})
output$vbox2 <- renderValueBox({
valueBox(
"Title",
input$count4,
icon = icon("credit-card")
)
})
}
shinyApp(ui, server)
使输入保持在 header
方法一
我们也修复了 header。滚动时，整个 header 固定在顶部。将样式更改为此
tags$style(HTML(
"@media (min-width: 767px) {
.select-to-top {
position: fixed;
top: 0;
left: 49%;
width: 1000px;
z-index: 9999;
}
.main-header .logo {
height: 80px;
position: fixed;
}
.navbar.navbar-static-top {
position: fixed;
height: 80px;
width: 100%;
}
.left-side, .main-sidebar {
padding-top: 80px;
}
.content-wrapper {
padding-top: 80px;
}
}
"
))
方法二
input 和 header 都保持在顶部，不要移动。
用这个样式，只是换了个位置
tags$style(HTML(
"@media (min-width: 767px) {
.select-to-top {
position: absolute;
top: 0;
left: 49%;
width: 1000px;
z-index: 9999;
}
.main-header .logo {
height: 80px;
}
.left-side, .main-sidebar {
padding-top: 80px;
}
}
"
))
使用下拉菜单
这段代码应该能让您使用下拉菜单。
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Header", dropdownMenu(type = "messages",
messageItem(from = "Sales Dept",message = "Sales are steady this month."))),
dashboardSidebar( sidebarMenu(id = "tabs",
menuItem("Page1", tabName = "page1"),
menuItem("Page2", tabName = "page2"))),
dashboardBody(
tabItems(
tabItem(
tabName = "page1",
fluidRow(class = "select-to-top",
column(6, selectInput("count1", "Select a category", c("1", "2"))),
column(6,selectInput("count2", "Select a subcategory1", c("cat1", "cat2", "cat3", "cat4")))
),
fluidRow(infoBoxOutput("ibox1")),
fluidRow(valueBoxOutput("vbox1")),
lapply(1:40, br)
),
tabItem(
tabName = "page2",
fluidRow(class = "select-to-top",
column(6,selectInput("count3", "Select a category", c("1", "2"))),
column(6, selectInput("count4", "Select a subcategory2", c("sub1", "sub2", "sub3", "sub4")))
),
fluidRow(infoBoxOutput("ibox2")),
fluidRow(valueBoxOutput("vbox2")
)
)
),
tags$style(HTML(
"@media (min-width: 767px) {
.select-to-top {
position: absolute;
top: 0;
left: 50%;
color: white;
transform: translateX(-45%);
width: 500px;
z-index: 9999;
}
.main-header .logo {
height: 60px;
}
.left-side, .main-sidebar {
padding-top: 60px;
}
}
"
))
)
)
server <- function(input, output) {
output$ibox1 <- renderInfoBox({
infoBox(
"Title",
input$count1,
icon = icon("credit-card")
)
})
output$vbox1 <- renderValueBox({
valueBox(
"Title",
input$count2,
icon = icon("credit-card")
)
})
output$ibox2 <- renderInfoBox({
infoBox(
"Title",
input$count3,
icon = icon("credit-card")
)
})
output$vbox2 <- renderValueBox({
valueBox(
"Title",
input$count4,
icon = icon("credit-card")
)
})
}
shinyApp(ui, server)
我有以下 proto-type 我闪亮的应用程序，有两个页面和每个页面中的两个 selectInput 按钮。
ui <- dashboardPage(
dashboardHeader(title = "Header",
dropdownMenuOutput("updatedTimeOutput"),
dropdownMenu(type = "notifications",
badgeStatus = "warning",
icon = icon("bullhorn", "fa-lg"),
notificationItem(icon = icon("bullhorn", "fa-1x"),
status = "info",
text = tags$span(
tags$b("Please notice!")
)
))),
dashboardSidebar( sidebarMenu(id = "tabs",
menuItem("Page1", tabName = "page1"),
menuItem("Page2", tabName = "page2"))),
dashboardBody(
tabItems(
tabItem(
tabName = "page1",
fluidRow(column(2,
selectInput("count1", "Select a category", c("1", "2"))),
column(2,selectInput("count2", "Select a subcategory1",
c("cat1", "cat2", "cat3", "cat4")))),
fluidRow(infoBoxOutput("ibox1")),
fluidRow(valueBoxOutput("vbox1"))
)
,
tabItem(
tabName = "page2",
fluidRow(column(2,
selectInput("count3", "Select a category", c("1", "2"))),
column(2, selectInput("count4", "Select a subcategory2",
c("sub1", "sub2", "sub3", "sub4")))),
fluidRow(infoBoxOutput("ibox2")),
fluidRow(valueBoxOutput("vbox2")
)
)
)
)
)
server <- function(input, output) {
output$ibox1 <- renderInfoBox({
infoBox(
"Title",
input$count1,
icon = icon("credit-card")
)
})
output$vbox1 <- renderValueBox({
valueBox(
"Title",
input$count2,
icon = icon("credit-card")
)
})
output$ibox2 <- renderInfoBox({
infoBox(
"Title",
input$count3,
icon = icon("credit-card")
)
})
output$vbox2 <- renderValueBox({
valueBox(
"Title",
input$count4,
icon = icon("credit-card")
)
})
}
shinyApp(ui, server)
如果应用程序是 运行，我们将在每个页面的 body 中看到两个 selectInput 按钮。是否可以将每个页面中的 selectInput 按钮移动到 header，使其看起来像：
第 1 页：
第 2 页：
inputButtons 应该放在 header 中并且应该显示每个页面的相应输入。如果可以使用任何自定义 CSS 或 javascript 或 html 在闪亮的应用程序中完成，有人可以提供帮助吗？
试试这些 CSS 技巧，适合移动设备。
- 当屏幕太小时，自动返回到选项卡。
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Header"),
dashboardSidebar( sidebarMenu(id = "tabs",
menuItem("Page1", tabName = "page1"),
menuItem("Page2", tabName = "page2"))),
dashboardBody(
tabItems(
tabItem(
tabName = "page1",
fluidRow(class = "select-to-top", column(2,
selectInput("count1", "Select a category", c("1", "2"))),
column(2,selectInput("count2", "Select a subcategory1",
c("cat1", "cat2", "cat3", "cat4")))),
fluidRow(infoBoxOutput("ibox1")),
fluidRow(valueBoxOutput("vbox1"))
)
,
tabItem(
tabName = "page2",
fluidRow(class = "select-to-top", column(2,
selectInput("count3", "Select a category", c("1", "2"))),
column(2, selectInput("count4", "Select a subcategory2",
c("sub1", "sub2", "sub3", "sub4")))),
fluidRow(infoBoxOutput("ibox2")),
fluidRow(valueBoxOutput("vbox2")
)
)
),
tags$style(HTML(
"@media (min-width: 767px) {
.select-to-top {
position: fixed;
top: 0;
left: 49%;
width: 1000px;
z-index: 9999;
}
.main-header .logo {
height: 80px;
}
.left-side, .main-sidebar {
padding-top: 80px;
}
}
"
))
)
)
server <- function(input, output) {
output$ibox1 <- renderInfoBox({
infoBox(
"Title",
input$count1,
icon = icon("credit-card")
)
})
output$vbox1 <- renderValueBox({
valueBox(
"Title",
input$count2,
icon = icon("credit-card")
)
})
output$ibox2 <- renderInfoBox({
infoBox(
"Title",
input$count3,
icon = icon("credit-card")
)
})
output$vbox2 <- renderValueBox({
valueBox(
"Title",
input$count4,
icon = icon("credit-card")
)
})
}
shinyApp(ui, server)
使输入保持在 header
方法一
我们也修复了 header。滚动时，整个 header 固定在顶部。将样式更改为此
tags$style(HTML(
"@media (min-width: 767px) {
.select-to-top {
position: fixed;
top: 0;
left: 49%;
width: 1000px;
z-index: 9999;
}
.main-header .logo {
height: 80px;
position: fixed;
}
.navbar.navbar-static-top {
position: fixed;
height: 80px;
width: 100%;
}
.left-side, .main-sidebar {
padding-top: 80px;
}
.content-wrapper {
padding-top: 80px;
}
}
"
))
方法二
input 和 header 都保持在顶部，不要移动。
用这个样式，只是换了个位置
tags$style(HTML(
"@media (min-width: 767px) {
.select-to-top {
position: absolute;
top: 0;
left: 49%;
width: 1000px;
z-index: 9999;
}
.main-header .logo {
height: 80px;
}
.left-side, .main-sidebar {
padding-top: 80px;
}
}
"
))
使用下拉菜单
这段代码应该能让您使用下拉菜单。
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Header", dropdownMenu(type = "messages",
messageItem(from = "Sales Dept",message = "Sales are steady this month."))),
dashboardSidebar( sidebarMenu(id = "tabs",
menuItem("Page1", tabName = "page1"),
menuItem("Page2", tabName = "page2"))),
dashboardBody(
tabItems(
tabItem(
tabName = "page1",
fluidRow(class = "select-to-top",
column(6, selectInput("count1", "Select a category", c("1", "2"))),
column(6,selectInput("count2", "Select a subcategory1", c("cat1", "cat2", "cat3", "cat4")))
),
fluidRow(infoBoxOutput("ibox1")),
fluidRow(valueBoxOutput("vbox1")),
lapply(1:40, br)
),
tabItem(
tabName = "page2",
fluidRow(class = "select-to-top",
column(6,selectInput("count3", "Select a category", c("1", "2"))),
column(6, selectInput("count4", "Select a subcategory2", c("sub1", "sub2", "sub3", "sub4")))
),
fluidRow(infoBoxOutput("ibox2")),
fluidRow(valueBoxOutput("vbox2")
)
)
),
tags$style(HTML(
"@media (min-width: 767px) {
.select-to-top {
position: absolute;
top: 0;
left: 50%;
color: white;
transform: translateX(-45%);
width: 500px;
z-index: 9999;
}
.main-header .logo {
height: 60px;
}
.left-side, .main-sidebar {
padding-top: 60px;
}
}
"
))
)
)
server <- function(input, output) {
output$ibox1 <- renderInfoBox({
infoBox(
"Title",
input$count1,
icon = icon("credit-card")
)
})
output$vbox1 <- renderValueBox({
valueBox(
"Title",
input$count2,
icon = icon("credit-card")
)
})
output$ibox2 <- renderInfoBox({
infoBox(
"Title",
input$count3,
icon = icon("credit-card")
)
})
output$vbox2 <- renderValueBox({
valueBox(
"Title",
input$count4,
icon = icon("credit-card")
)
})
}
shinyApp(ui, server)
