小贝子编程

ShinyDashboard中的CSS反应式ValueBoxes



我正在尝试使用css在shinydashboard中自定义valueboxes。我发现的问题是：

  1. 我无法标记特定的valuebox，这会使任何css更改适用于所有
  2. 我不知道如何根据服务器端的输入使css无反应

下面是我的代码，说明了我要做的事情。每个值框都应该有不同的颜色字体来表示数字百分比。

library (shiny)
library (shinydashboard)
library (shinydashboardPlus)
rm(list=ls())
###########################/ui.R/##################################
#Header----
header <- dashboardHeaderPlus(
title = "Test",
enable_rightsidebar = TRUE,
rightSidebarIcon = "sliders"
)
#Right SideBar----
rightsidebar <- rightSidebar()
#SideBar----
sidebar <- dashboardSidebar(
#Sidebar Menu----
div(id = "sidebarChoices",
#style = "position: fxed; overflow: visible;", 
sidebarMenu(id = "menuChoice",
menuItem("Functional Dashboards", tabName = "MetricMenu", icon = icon("dashboard"),
menuSubItem("Operations", tabName = "OpsMetricSubMenu", icon = icon("angle-double-right"))
)
)
)
)
#Body----
body <- dashboardBody(
#OPS Page----
tags$head(tags$style(HTML("
.small-box {background-color: #000000 !important;border-radius: 1vh !important; border-color: #D20000 !important;}
.small-box .icon-large {font-size: 8vh !important; bottom: -2vh !important; color: #999999 !important;}
.small-box h3 {font-size: 4vh !important; color: #D20000 !important;}
.small-box p {font-size: 1vh !important;}
"))),

#OPERATIONS KPI----
tabItem(tabName = "OpsMetricSubMenu",
#First Row: KPI Metrics----
div(id = "Ops_FirstRow", 
fluidRow(
valueBoxOutput("Box1", width = 2),
valueBoxOutput("Box2", width = 2),
valueBoxOutput("Box3", width = 2),
valueBoxOutput("Box4", width = 2)
)
)
)
)
#Builds Dashboard Page----
ui <- dashboardPagePlus(header, sidebar, body, rightsidebar)
###########################/server.R/###############################
server <- function(input, output, session) {
output$Box1 <- renderValueBox({
Value <- 50
if (Value <= 100 & Value >= 90) {Color = "#FFFFFF"
} else if (Value < 90 & Value >= 80) {Color = "#F6FC00"
} else if (Value < 80) {Color = "#D20000"
} else {Color = "FFFFFF"}
CommercialOTDBox <- valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
return(CommercialOTDBox)
})
output$Box2 <- renderValueBox({
Value <- 85
if (Value <= 100 & Value >= 90) {Color = "#FFFFFF"
} else if (Value < 90 & Value >= 80) {Color = "#F6FC00"
} else if (Value < 80) {Color = "#D20000"
} else {Color = "FFFFFF"}
CommercialOTDBox <- valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
return(CommercialOTDBox)
})
output$Box3 <- renderValueBox({
Value <- 110
if (Value <= 100 & Value >= 90) {Color = "#FFFFFF"
} else if (Value < 90 & Value >= 80) {Color = "#F6FC00"
} else if (Value < 80) {Color = "#D20000"
} else {Color = "FFFFFF"}
CommercialOTDBox <- valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
return(CommercialOTDBox)
})
output$Box4 <- renderValueBox({
Value <- 98
if (Value <= 100 & Value >= 90) {Color = "#FFFFFF"
} else if (Value < 90 & Value >= 80) {Color = "#F6FC00"
} else if (Value < 80) {Color = "#D20000"
} else {Color = "FFFFFF"}
CommercialOTDBox <- valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
return(CommercialOTDBox)
})


}
#Combines Dasboard and Data together----
shinyApp(ui, server)

编辑

下面的解决方案非常有效！

library (shiny)
library (shinydashboard)
library (shinydashboardPlus)
library (ggplot2)
library (leaflet)
library (date)
library (tidyr)
library (dplyr)
library (data.table)
library (zoo)
library (tibble)
library (billboarder)
library (scales)
library (highcharter)
library (quantmod)
library (gplots)
library (RColorBrewer)
library (plotrix)
library (RODBC)
library (png)
library (rpivotTable)
library (lubridate)
library (timeDate)
library (shinycssloaders)
library (shinyjs)
library (DT)
library (rintrojs)
library (profvis)
library (bit64)
library (collapsibleTree)
rm(list=ls())
###########################/ui.R/##################################
#Header----
header <- dashboardHeaderPlus(
title = tagList(
span(class = "logo-lg", "MRO Dash"),
imageOutput("HLogo")),
tags$li(class = "dropdown",
tags$a(htmlOutput("Refresh"))
),
enable_rightsidebar = TRUE,
rightSidebarIcon = "sliders"
)
#Right SideBar----
rightsidebar <- rightSidebar()
#SideBar----
sidebar <- dashboardSidebar(
#Sidebar Menu----
div(id = "sidebarChoices",
#style = "position: fxed; overflow: visible;", 
sidebarMenu(id = "menuChoice",
menuItem("Functional Dashboards", tabName = "MetricMenu", icon = icon("dashboard"),
menuSubItem("Operations", tabName = "OpsMetricSubMenu", icon = icon("angle-double-right"))
)
)
)

#End )----
) #dashboard sidebar end
#Body----
body <- dashboardBody(
useShinyjs(),
#CSS Formatting----
#Background colors----
#tags$head(tags$style(HTML(".sidebar {height: 90vh; overflow-y: auto;}"))),
tags$head(tags$link(rel="shortcut icon", href="favicon.ico")), 
#   /* other links in the sidebarmenu when hovered */
# .skin-blue .main-sidebar .sidebar .sidebar-menu a:hover{background-color: #E4551F;}
tags$head(tags$style(HTML('
/*** FORMATTING BACKGROUND COLORS ***/
/* Top Left of Header Background */
.skin-blue .main-header .logo {background-color: #000000;}
/*Top Left of Header when Hovered */
.skin-blue .main-header .logo:hover {background-color: #E4551F;}
/* Rest of the Header Background */
.skin-blue .main-header .navbar {background-color: #000000;}
/* Main SideBar Background */
.skin-blue .main-sidebar {background-color: #1A1A1A;}
/* Tabs in SideBar Background */
.skin-blue .main-sidebar .sidebar .sidebar-menu a{background-color: #1A1A1A;}
/* Active Tab in SideBar Background */
.skin-blue .main-sidebar .sidebar .sidebar-menu .active a{background-color: #E4551F;}
/* Left bar on Sidebar */
.skin-blue .sidebar-menu > li.active > a {border-left-color: #E4551F;}
.skin-blue .sidebar-menu > li.active > a, .skin-blue .sidebar-menu > li:hover > a {border-left-color: #E4551F;}
/* toggle button when hovered  */
.skin-blue .main-header .navbar .sidebar-toggle:hover{background-color: #E4551F;}
/* Right SideBar Background */
.control-sidebar-dark+.control-sidebar-bg {background: #1A1A1A;}
.control-sidebar-dark+.nav.nav-tabs.nav-justified.control-sidebar-tabs {background: #1A1A1A;}
.control-sidebar-dark+.control-sidebar.control-sidebar-dark.control-sidebar-open {background: #1A1A1A;}
/* Body Background */ 
.content-wrapper, .right-side {background-color: #FFFFFF;}
'))),
#Header Logo----
tags$head(tags$style(HTML('
.main-header .logo {
padding: 0px 0px;
}
'))),
#Boxes----
tags$head(tags$style(HTML('
.box.box-primary{
border-top-color:#E4551F;
border-bottom-color:#E4551F;
border-color: #E4551F
border-left-color:#E4551F;
border-right-color:#E4551F;
}
.box.box-solid.box-primary{
border-color: #E4551F
}
.box.box-solid.box-primary>.box-header{
background-color: #E4551F;
}

'))), #.nav.nav-tabs.shiny-tab-input.shiny-bound-input > li[class=active] > a {border-top-color:#E4551F;}
#Icon----
tags$style('.fa-plus-square-o {color:#E4551F}'),

#OPS Page----
tags$head(tags$style(HTML("
.small-box {background-color: #000000 !important;border-radius: 1vh !important; box-shadow: 0.3vh 0.3vh 0vh #CCCCCC;}
.small-box .icon-large {font-size: 8vh !important; bottom: -2vh !important; color: #999999 !important;}
.small-box h3 {font-size: 4vh !important;}
.small-box p {font-size: 1vh !important; color: #FFFFFF !important;}
.white .small-box h3{color: #FFFFFF !important;}
.yellow .small-box h3{color: #F6FC00 !important;}
.red .small-box h3{color: #D20000 !important;}
#DailyLinearityShip {height:25vh !important;}
#MonthlyLinearityShip {height:25vh !important;}
"))),

#OPERATIONS KPI----
tabItem(tabName = "OpsMetricSubMenu",
#First Row: KPI Metrics----
div(id = "Ops_FirstRow", 
fluidRow(
valueBoxOutput("Box1", width = 2),
valueBoxOutput("Box2", width = 2),
valueBoxOutput("Box3", width = 2),
valueBoxOutput("Box4", width = 2)
)
),
#Third Row: Linearity----
fluidRow(
div(id = "DailyLinearityBox",
box(
title = "Daily Shipment Linearity", status = "primary", solidHeader = FALSE,
highchartOutput("DailyLinearityShip") %>% withSpinner(color="#E4551F")
)
),
div(id = "MonthlyLinearityBox",
box(
title = "Monthly Shipment Linearity", status = "primary", solidHeader = TRUE,
highchartOutput("MonthlyLinearityShip") %>% withSpinner(color="#E4551F")
)
)
),
#Fourth Row: WIP----   
div(id = "Ops_FourthRow", 
fluidRow(
div(id = "TimingBox",
tabBox(id = "Timing",
title = p("WIP Status",actionLink("WIPOnTimeLink", NULL, icon = icon("plus-square-o"))), width = 4
)
)
)
)
)
)
#Builds Dashboard Page----
ui <- dashboardPagePlus(header, sidebar, body, rightsidebar)
###########################/server.R/###############################
server <- function(input, output, session) {
output$Box1 <- renderValueBox({
Value <- 50
lapply(c("white", "yellow", "red"), function(i) removeClass("Box1", i))
if (Value <= 100 & Value >= 90) {Color = "white"
} else if (Value < 90 & Value >= 80) {Color = "yellow"
} else if (Value < 80) {Color = "red"
} else {Color = "white"}
addClass("Box1", Color)
valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
})
output$Box2 <- renderValueBox({
Value <- 85
lapply(c("white", "yellow", "red"), function(i) removeClass("Box2", i))
if (Value <= 100 & Value >= 90) {Color = "white"
} else if (Value < 90 & Value >= 80) {Color = "yellow"
} else if (Value < 80) {Color = "red"
} else {Color = "white"}
addClass("Box2", Color)
CommercialOTDBox <- valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
return(CommercialOTDBox)
})
output$Box3 <- renderValueBox({
Value <- 110
lapply(c("white", "yellow", "red"), function(i) removeClass("Box3", i))
if (Value <= 100 & Value >= 90) {Color = "white"
} else if (Value < 90 & Value >= 80) {Color = "yellow"
} else if (Value < 80) {Color = "red"
} else {Color = "white"}
addClass("Box3", Color)
CommercialOTDBox <- valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
return(CommercialOTDBox)
})
output$Box4 <- renderValueBox({
Value <- 98
lapply(c("white", "yellow", "red"), function(i) removeClass("Box4", i))
if (Value <= 100 & Value >= 90) {Color = "white"
} else if (Value < 90 & Value >= 80) {Color = "yellow"
} else if (Value < 80) {Color = "red"
} else {Color = "white"}
addClass("Box4", Color)
CommercialOTDBox <- valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
return(CommercialOTDBox)
})

output$MonthlyLinearityShip <- renderHighchart({
SumIntake <- c(5,10,15,20,20,20,25,30,35,40,45,45,45)
SumShip <- c(6,12,14,20,20,20,22,28,33,42,44,50,55)
GoalShip <- c(7,14,21,25,25,25,30,35,40,45,55,60, 65)
Index <- c(1,2,3,4,5,6,7,8,9,10,11,12,13)
Linearity <- data.frame(SumIntake,SumShip,GoalShip,Index)
highchart() %>%
hc_chart(type = "column") %>%
hc_xAxis(categories = Linearity$Index, labels = list(style = list(fontSize = "1.2vh"))) %>%
hc_yAxis(gridLineWidth = 0, labels = list(style = list(fontSize = "1.2vh"))) %>%
hc_add_series(data  = Linearity$SumIntake, name = "Intakes",  color = "#E4551F") %>%
hc_add_series(data  = Linearity$SumShip, name = "Shipments",  color = "#000000") %>%
hc_add_series(data = Linearity$GoalShip, name = "Plan", type = "line",  color = "#F2A900") %>%
hc_plotOptions(line = list(marker = list(enabled = FALSE))) %>%
hc_legend(enabled = TRUE, verticalAlign = "top") %>%
hc_tooltip(crosshairs = TRUE, shared = TRUE, headerFormat = "<b>Day {point.x}</b><br>", allowDecimals = FALSE)
})
output$DailyLinearityShip <- renderHighchart({
SumShip <- c(6,12,14,20,20,20,22,28,33,42,44,50,55)
GoalShip <- c(7,14,21,25,25,25,30,35,40,45,55,60, 65)
Index <- c(1,2,3,4,5,6,7,8,9,10,11,12,13)
Linearity <- data.frame(SumShip,GoalShip,Index)
highchart() %>%
hc_chart(type = "line") %>%
hc_xAxis(categories = Linearity$Index, labels = list(style = list(fontSize = "1.2vh"))) %>%
hc_yAxis(gridLineWidth = 0, labels = list(style = list(fontSize = "1.2vh"))) %>%
hc_add_series(data  = Linearity$SumShip, name = "Shipments",  color = "#000000") %>%
hc_add_series(data = Linearity$GoalShip, name = "Plan", type = "line",  color = "#F2A900") %>%
hc_plotOptions(line = list(marker = list(enabled = FALSE))) %>%
hc_legend(enabled = TRUE, verticalAlign = "top") %>%
hc_tooltip(crosshairs = TRUE, shared = TRUE, headerFormat = "<b>Day {point.x}</b><br>", allowDecimals = FALSE)
})
}
#Combines Dasboard and Data together----
shinyApp(ui, server)

我使用shinjys和addClass/removeClass函数添加了一个css类。3个css类(白色、黄色、红色(是预定义的，并根据valueBox的值进行分配。

在赋值之前，你必须删除所有潜在的类，否则它只会附加css类，然后颜色不会改变。

此示例显示了使用2valueBoxes和2sliderInputs更改valueBoxes值的行为。

更新：shinyjs需要在UI中调用useShinyjs()。

library (shiny)
library (shinydashboard)
library (shinydashboardPlus)
library (shinyjs)
########################### CSS ##########################
css = HTML("
.white .small-box {
background-color: #FFFFFF !important;
}
.yellow .small-box {
background-color: #F6FC00 !important;
}
.red .small-box {
background-color: #D20000 !important;
}
")
###########################/ui.R/##################################
#Header
header <- dashboardHeaderPlus(
title = "Test",
enable_rightsidebar = TRUE,
rightSidebarIcon = "sliders"
)
#Right SideBar
rightsidebar <- rightSidebar()
#SideBar
sidebar <- dashboardSidebar(
#Sidebar Menu
div(id = "sidebarChoices",
#style = "position: fxed; overflow: visible;", 
sidebarMenu(id = "menuChoice",
menuItem("Functional Dashboards", tabName = "MetricMenu", icon = icon("dashboard"),
menuSubItem("Operations", tabName = "OpsMetricSubMenu", icon = icon("angle-double-right"))
)
)
)
)
#Body
body <- dashboardBody(
useShinyjs(),
tags$head(tags$style(css)),

#OPERATIONS KPI
tabItem(tabName = "OpsMetricSubMenu",
#First Row: KPI Metrics
div(id = "Ops_FirstRow", 
fluidRow(
sliderInput("valBox1", "Change Value for Box1", min = 0, 100, 50),
valueBoxOutput("Box1", width = 2),
sliderInput("valBox2", "Change Value for Box2", min = 0, 100, 85),
valueBoxOutput("Box2", width = 2)
)
)
)
)
#Builds Dashboard Page
ui <- dashboardPagePlus(header, sidebar, body, rightsidebar)
###########################/server.R/###############################
server <- function(input, output, session) {
output$Box1 <- renderValueBox({
Value <- input$valBox1
lapply(c("white", "yellow", "red"), function(i) removeClass("Box1", i))
if (Value <= 100 & Value >= 90) {Color = "white"
} else if (Value < 90 & Value >= 80) {Color = "yellow"
} else if (Value < 80) {Color = "red"
} else {Color = "white"}
addClass("Box1", Color)
valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
})
output$Box2 <- renderValueBox({
Value <- input$valBox2
lapply(c("white", "yellow", "red"), function(i) removeClass("Box2", i))
if (Value <= 100 & Value >= 90) {Color = "white"
} else if (Value < 90 & Value >= 80) {Color = "yellow"
} else if (Value < 80) {Color = "red"
} else {Color = "white"}
addClass("Box2", Color)
valueBox(value = paste0(Value, "%"), subtitle = "OTD DIH Commercial MTD /Goal: 90%", icon = icon("plane"), href = "#")
})
}
#Combines Dasboard and Data together----
shinyApp(ui, server)

相关内容

最新更新


热门标签：

javascript python java c# php android html jquery c++ css ios sql mysql arrays asp.net json python-3.x ruby-on-rails .net sql-server django objective-c excel regex ruby linux ajax iphone xml vba spring asp.net-mvc database wordpress string postgresql wpf windows xcode bash git oracle list vb.net multithreading eclipse algorithm macos powershell visual-studio image forms numpy scala function api selenium