The datatable in my shiny app looks like this:
I don't like the scrollbar and think it's not really necessary to have it if I could shrink the table a bit.
I could do it with div(DT::dataTableOutput("active_cases"), style = "font-size: 75%;").
But with my real-world data, it's still a little bit too wide. If I see the yellow marked columns I don't think that there is a need to reduce font size if I could reduce the space between columns.
Is there a way to make such a table more compact/dense?
MWE
library(shiny)
library(data.table)
library(DT)
library(bslib)
################################################################################
################################ S E R V E R ###################################
################################################################################
server = shinyServer(function(input,output){
output$histogram = renderPlot(
hist(faithful$eruptions, breaks=input$days_plot)
)
output$active_cases = DT::renderDataTable(
mtcars, selection = 'single', options=list(scrollX=TRUE))
})
################################################################################
#################################### U I #######################################
################################################################################
ui = shinyUI(
dashboardPage(
dashboardHeader(
title="iris test"
),
dashboardSidebar(
#h3("Downstream", style="text-align:center;
# color:white;
# background-color:red'"
# ),
sidebarMenu(id="tabs",
menuItem("Iris - Active Cases", tabName="active_cases", icon = icon("magnifying-glass-location")),
menuItem("Iris - Archive", tabName="archive", icon = icon("box-archive")),
menuItem("Configuration", sliderInput("days_plot", "Days into past", 1, 60, 30))
)
),
dashboardBody(
tabItems(
tabItem(tabName="active_cases", shiny::h2("Active Cases"),
fluidRow(
box(title="Cases", status="primary", solidHeader=TRUE, div(DT::dataTableOutput("active_cases"))),
box(title="Cases", status="primary", solidHeader=TRUE, plotOutput("histogram"))
)
),
tabItem(tabName="archive", shiny::h2("Archive"))
)
)
)
)
################################################################################
################################### R U N ######################################
################################################################################
shinyApp(ui, server)
Use following CSS style:
library(shiny)
library(data.table)
library(DT)
library(bslib)
library(shinydashboard)
################################################################################
################################ S E R V E R ###################################
################################################################################
server = shinyServer(function(input,output){
output$histogram = renderPlot(
hist(faithful$eruptions, breaks=input$days_plot)
)
output$active_cases = DT::renderDataTable(
DT::datatable(mtcars, selection = 'single', options=list(scrollX=TRUE))
)
})
################################################################################
#################################### U I #######################################
################################################################################
ui = shinyUI(
dashboardPage(
dashboardHeader(
title="iris test"
),
dashboardSidebar(
#h3("Downstream", style="text-align:center;
# color:white;
# background-color:red'"
# ),
sidebarMenu(id="tabs",
menuItem("Iris - Active Cases", tabName="active_cases", icon = icon("magnifying-glass-location")),
menuItem("Iris - Archive", tabName="archive", icon = icon("box-archive")),
menuItem("Configuration", sliderInput("days_plot", "Days into past", 1, 60, 30))
)
),
dashboardBody(
tabItems(
tabItem(tabName="active_cases", shiny::h2("Active Cases"),
fluidRow(
tags$style(
'
#active_cases th {padding: 0;}
/* #active_cases :is(th, td) {padding: 0;} */
'
),
box(title="Cases", status="primary", solidHeader=TRUE, div(DT::dataTableOutput("active_cases"), style = "width: 100%")),
box(title="Cases", status="primary", solidHeader=TRUE, plotOutput("histogram"))
)
),
tabItem(tabName="archive", shiny::h2("Archive"))
)
)
)
)
################################################################################
################################### R U N ######################################
################################################################################
shinyApp(ui, server)
To make it more compact, use the second commented line in the style instead #active_cases :is(th, td) {padding: 0;}:
Related
I have the following code to build a Shinydashboard app. I'm trying to change the background color in the box on the top of my screen to a custom color (a color hex code color), however the options for the argument background only allow for a set of default colors. Is there a way to change the background color of this box specifically while keeping the white background for the remainder of my boxes?
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = 'Dashboard'),
dashboardSidebar(sidebarMenu
(menuItem(tabName = 'Panel1', text = 'Panel 1'),
dateInput("Start_Date", "Start Date", min = '2000-01-01', max = Sys.Date(), value = '2020-01-01',format = "yyyy-mm-dd")
)
),
dashboardBody(
tabItems(tabItem(tabName = 'Panel1',
fluidRow(box(selectizeInput('select_mean', 'Select Number',
choices = c(12,24,36,48,60,120)),height=80,width=4,
background = 'black')),
fluidRow(box(width = 13, height = 655))
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
You can use htmltools::tagQuery to add a style:
library(htmltools)
library(shinydashboard)
library(shiny)
b <- box(selectInput("id", "label", c("a", "b", "c")))
b <- tagQuery(b)$find(".box")$addAttrs(style = "background-color: pink;")$allTags()
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(b)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
You can do the following steps :
put your box into a tags$div and give it an ID (here : "toto")
add some CSS to the box, which is two div childs after your div toto
You can also put the CSS in a separate file, see https://shiny.rstudio.com/articles/css.html
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = 'Dashboard'),
dashboardSidebar(sidebarMenu
(menuItem(tabName = 'Panel1', text = 'Panel 1'),
dateInput("Start_Date", "Start Date", min = '2000-01-01', max = Sys.Date(), value = '2020-01-01',format = "yyyy-mm-dd")
)
),
dashboardBody(
tags$head(
tags$style(HTML("
#toto > div:nth-child(1) > div:nth-child(1) {
background-color: rgb(128, 0, 0);
}"))),
tabItems(tabItem(tabName = 'Panel1',
fluidRow(
tags$div(
id = "toto",
box(selectizeInput('select_mean', 'Select Number',
choices = c(12,24,36,48,60,120)),height=80,width=4)
)
),
fluidRow(box(width = 13, height = 655))
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
In shiny the ggplotly visual looks like:
If I create a screenshot with shinyscreenshot it appears with a colorless legend:
Is there any way to solve this issue?
Update 12:04
It seems that this issues only appears with colorbars. With factorized groups the legend works:
Unfortunately, in real world data I need the colorbar as its a range between 0.0001 and 100%.
MWE
library(shiny)
library(shinydashboard)
library(shinyscreenshot)
library(data.table)
library(DT)
library(bslib)
library(plotly)
################################################################################
################################ S E R V E R ###################################
################################################################################
server = shinyServer(function(input,output){
output$histogram = renderPlotly(
ggplotly(ggplot(mtcars, aes(x=disp, y=hp, color=gear)) + geom_point())
)
output$active_cases = DT::renderDataTable(
mtcars)
######################### SCREENSHOT REACTIVE FUNCTION #########################
observeEvent(input$go,{
screenshot(id = "to_plot") # plot only ID "to_plot"
})
######################### SCREENSHOT REACTIVE FUNCTION #########################
})
################################################################################
#################################### U I #######################################
################################################################################
ui = shinyUI(
dashboardPage(
dashboardHeader(
title="just a test"
),
dashboardSidebar(
sidebarMenu(id="tabs",
menuItem("Tab1", tabName="active_cases", icon = icon("magnifying-glass-location"))
)
),
dashboardBody(
tabItems(
tabItem(tabName="active_cases", shiny::h2("Active Cases"),
fluidRow(actionButton("go", "go")),
fluidRow(
box(title="Table", status="primary", solidHeader=TRUE, div(DT::dataTableOutput("active_cases")))
),
div(id="to_plot",
fluidRow(
box(title="Visual1", status="primary", solidHeader=TRUE, plotlyOutput("histogram"))
)
)
)))))
################################################################################
################################### R U N ######################################
################################################################################
shinyApp(ui, server)
You could use library(capture) instead of library(shinyscreenshot):
# remotes::install_github("dreamRs/capture")
library(shiny)
library(shinydashboard)
library(capture)
library(data.table)
library(DT)
library(bslib)
library(plotly)
################################################################################
################################ S E R V E R ###################################
################################################################################
server = shinyServer(function(input,output){
output$histogram = renderPlotly(
ggplotly(ggplot(mtcars, aes(x=disp, y=hp, color=gear)) + geom_point())
)
output$active_cases = DT::renderDataTable(
mtcars)
})
################################################################################
#################################### U I #######################################
################################################################################
ui = shinyUI(
dashboardPage(
dashboardHeader(
title="just a test"
),
dashboardSidebar(
sidebarMenu(id="tabs",
menuItem("Tab1", tabName="active_cases", icon = icon("magnifying-glass-location"))
)
),
dashboardBody(
tabItems(
tabItem(tabName="active_cases", shiny::h2("Active Cases"),
fluidRow(
capture::capture(
selector = "#to_plot",
filename = "capture_plotly.png",
icon("camera"), "Capture plotly graph",
options=list(backgroundColor = "white")
)
),
fluidRow(
box(title="Table", status="primary", solidHeader=TRUE, div(DT::dataTableOutput("active_cases")))
),
div(id="to_plot",
fluidRow(
box(title="Visual1", status="primary", solidHeader=TRUE, plotlyOutput("histogram"))
)
)
)))))
################################################################################
################################### R U N ######################################
################################################################################
shinyApp(ui, server)
Once I add an HTML document in my shiny app my graphs stop populating. I am using bs4dash but shinydashboard also has the exact same issue.
Below is my code as well as a screenshot of what is happening.
Code before i add HTML document
Ui
library(shiny)
library(bs4Dash)
library(highcharter)
library(plotly)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
box(width = 12,
plotlyOutput("plot1")
)
),
fluidRow(
box(
#width = 12,
#includeHTML("first.html")
)
)
)
)
Server
server <- function(input, output) {
a = rnorm(100)
output$plot1 = renderPlotly({
plot_ly(x = ~a, type = "histogram")
})
}
Now when i remove the hastags to display my HMTL document. My graph all of a sudden disappears.
Ui
library(shiny)
library(bs4Dash)
library(highcharter)
library(plotly)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
box(width = 12,
plotlyOutput("plot1")
)
),
fluidRow(
box(
width = 12,
includeHTML("first.html")
)
)
)
)
Server
server <- function(input, output) {
a = rnorm(100)
output$plot1 = renderPlotly({
plot_ly(x = ~a, type = "histogram")
})
}
I would like to have the graph still show. What is going wrong in the code. Thank you
I cannot reproduce your problem. I just observed that your fluidRow is the fourth parameter of dashboardPage which, however, expects a dashboardControlbar. Both, putting the fluidRow into dashboardBody or wrapping it in a call to dashboardControlbar works for me.
So either it is your first.html or indeed "just" the missing dashboardControlbar.
first.html
<span>I am an external HTML</span>
app.R
library(shiny)
library(bs4Dash)
library(highcharter)
library(plotly)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
box(width = 12,
plotlyOutput("plot1")
),
fluidRow(
box(
width = 12,
includeHTML("first.html")
)
)
)
)
ui2 <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
box(width = 12,
plotlyOutput("plot1")
)
),
dashboardControlbar(
fluidRow(
box(
width = 12,
includeHTML("first.html")
)
)
)
)
server <- function(input, output) {
a = rnorm(100)
output$plot1 = renderPlotly({
plot_ly(x = ~a, type = "histogram")
})
}
shinyApp(ui, server)
## shinyApp(ui2, server) ## works likewise
Screenshots
I started building my first shiny app but am now struggling with a strange behaviour. First, when I initially load the app, no tab is selected by default. Second, when clicking on any menu on the sidebar it shows the body only on the first time. When I go from "Overview" to "Pivot-Tabelle" and back, the body is blank. What am I missing? Below is the code I used.
library(shiny)
library(shinydashboard)
df<-data.frame(a=c(1,2,3,4),
b=c("A","B","C","D"))
###################Beginn der App################
ui <- dashboardPage(
# Application title
dashboardHeader(),
##----DashboardSidebar----
dashboardSidebar(
menuItem("Overview", tabName = "overview",selected=TRUE),
menuItem("Pivot-Tabelle", tabName = "pivot"),
menuItem("Test", tabName = "farmer")
),
##----DashboardBody----
dashboardBody(
tabItems(
##----TabItem: Overview----
tabItem(tabName="overview",
fluidRow(
valueBoxOutput("A"),
valueBoxOutput("B")
)
),
###----TabItem:Pivot----
tabItem(tabName = "pivot",
##Pivot
column(6,offset=4,titlePanel("Daten-Explorer")),
column(12,
mainPanel(
rpivotTableOutput("pivot")
)
)
),
##----TabItem:Test----
tabItem(tabName = "Test",
h2("In Progress"))
)
)
)
server <- function(input, output) {
##----server:overview----
output$A<-renderValueBox({
valueBox(
paste0(25, "%"), "Landwirte in der Datenbank", icon = icon("Person"),
color = "purple"
)
})
output$B<-renderValueBox({
valueBox(
paste0(55, "%"), "Landwirte in der Datenbank", icon = icon("Person"),
color = "purple"
)
})
##----server:pivot----
output$pivot <- renderRpivotTable({
rpivotTable(data = df)
})
}
# Run the application
shinyApp(ui = ui, server = server)
This seems to work. You need to have sidebarMenu for your menuItems. Also, you need to change tabName to farmer so it matches your menuItem. And I don't think you need mainPanel in there (you can use mainPanel with sidebarPanel as part of a sidebarLayout if you wanted that layout - see layout options). See if this works for you.
library(shiny)
library(shinydashboard)
library(rpivotTable)
df<-data.frame(a=c(1,2,3,4),
b=c("A","B","C","D"))
###################Beginn der App################
ui <- dashboardPage(
# Application title
dashboardHeader(),
##----DashboardSidebar----
dashboardSidebar(
sidebarMenu(
menuItem("Overview", tabName = "overview",selected=TRUE),
menuItem("Pivot-Tabelle", tabName = "pivot"),
menuItem("Test", tabName = "farmer")
)
),
##----DashboardBody----
dashboardBody(
tabItems(
##----TabItem: Overview----
tabItem(tabName="overview",
fluidRow(
valueBoxOutput("A"),
valueBoxOutput("B")
)
),
###----TabItem:Pivot----
tabItem(tabName = "pivot",
##Pivot
column(6,offset=4,titlePanel("Daten-Explorer")),
column(12,
#mainPanel(
rpivotTableOutput("pivot")
#)
)
),
##----TabItem:Test----
tabItem(tabName = "farmer",
h2("In Progress"))
)
)
)
server <- function(input, output) {
##----server:overview----
output$A<-renderValueBox({
valueBox(
paste0(25, "%"), "Landwirte in der Datenbank", icon = icon("Person"),
color = "purple"
)
})
output$B<-renderValueBox({
valueBox(
paste0(55, "%"), "Landwirte in der Datenbank", icon = icon("Person"),
color = "purple"
)
})
##----server:pivot----
output$pivot <- renderRpivotTable({
rpivotTable(data = df)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I am building a shiny dashboard and I want to implement a valueBox within the Dashboard.
body <- dashboardBody(
fluidRow(
valueBox(totalSales,"Total Sales",color="blue")
),
fluidRow(
DT::dataTableOutput("salesTable")
),
fluidRow(
DT::dataTableOutput("top10Sales")
)
)
And this is the result:
The number on the upper left is the variable totalSales but it isn't formatted in a valueBox.
Does anyone know what the problem is?
I appreciate your answers!!
My try with valueBoxOutput, but with the same result:
ui.R
body <- dashboardBody(
fluidRow(
valueBoxOutput("totalSales")
),
fluidRow(
DT::dataTableOutput("salesTable")
),
fluidRow(
DT::dataTableOutput("top10Sales")
)
)
server.R
function(input, output, session) {
output$salesTable = DT::renderDataTable(top10Sales)
output$top10Sales = DT::renderDataTable(top10Sales)
#output$totalSales = DT::renderDataTable(totalSales)
output$totalSales <- renderValueBox({
valueBox(totalSales, "Approval",color = "yellow")
})
}
And still the same result:
By the way: Infobox is working:
infoBox("test", value=1, width=3)
valueBox has to be used on the server side. To display a shiny dynamic UI element, there's generally a function (in this case valueBoxOutput) available to display it:
library(shinydashboard)
library(dplyr)
library(DT)
body <- dashboardBody(
fluidRow(
valueBoxOutput("totalCars")
),
fluidRow(
DT::dataTableOutput("table")
)
)
ui <- dashboardPage(header = dashboardHeader(),
sidebar = dashboardSidebar(),
body = body
)
server <- function(input, output) {
output$table = DT::renderDataTable(mtcars)
output$totalCars <- renderValueBox({
valueBox("Total", nrow(mtcars), color = "blue")
})
}
shinyApp(ui, server)