Does anyone know how to make the title of a tabBox go above the tabs in a shinydashboard app? For example, in the figure below, the title is on the right, but I would like it to go on top of the box.
Code for this tabBox:
library(shiny)
library(shinydashboard)
ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(),
dashboardBody(
fluidRow(
tabBox(title = HTML("Hello friend<br>"),
tabPanel("merp", "hi there"),
tabPanel("derp", "hello"),
tabPanel("herp", "howdy")
))
)
)
server = function(input, output) {
# The currently selected tab from the first box
output$tabset1Selected <- renderText({
input$tabset1
})
}
shinyApp(ui = ui, server = server
)
For those who might look for the solution here, a pretty simple fix was to put the tabBox (with no title) inside of a box with a title:
library(shiny)
library(shinydashboard)
ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(),
dashboardBody(
fluidRow(box(title = HTML("Hello friend<br>"),
tabBox(
tabPanel("merp", "hi there"),
tabPanel("derp", "hello"),
tabPanel("herp", "howdy"))
))
)
)
server = function(input, output) {
# The currently selected tab from the first box
output$tabset1Selected <- renderText({
input$tabset1
})
}
shinyApp(ui = ui, server = server)
There is the side argument e.g
library(shiny)
library(shinydashboard)
body <- dashboardBody(
fluidRow(
tabBox(
title = "First tabBox",
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset1", height = "250px",side = 'right',
tabPanel("Tab1", "First tab content"),
tabPanel("Tab2", "Tab content 2")
)
))
shinyApp(
ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body),
server = function(input, output) {
# The currently selected tab from the first box
output$tabset1Selected <- renderText({
input$tabset1
})
}
)
Related
I have a tabBox in a shiny dashboard and would like to add a download button on the right of the tabs where the title of the tabBox would usually appear:
Any suggestions on how to do this?
Here is some minimal code to work with (without the required download box):
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "tabBoxes"),
dashboardSidebar(disable=TRUE),
dashboardBody(
fluidRow(
tabBox(
title = 'Download Button',
width = 12,
tabPanel("Tab1", "Some text for tab 1"),
tabPanel("Tab2", "Some text for tab 2")
)
))
)
server <- function(input, output) { }
shinyApp(ui, server)
Turns out its as simple as setting the tabBox title equal to a downloadButton!
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "tabBoxes"),
dashboardSidebar(disable=TRUE),
dashboardBody(
fluidRow(
tabBox(
title = downloadButton(outputId = 'downloadData', label='Download'),
width = 12,
tabPanel("Tab1", "Some text for tab 1"),
tabPanel("Tab2", "Some text for tab 2")
)
))
)
server <- function(input, output) { }
shinyApp(ui, server)
I want to display a table of data in a pop-up window by clicking on valueBox. The valueBox itself should work as an actionButton.
When I click on the valueBox it should render a table in pop-up window as in the picture below.
Can anyone help on this code?
My code:
library(shiny)
library(shinydashboard)
data <- iris
ui <- dashboardPage(
dashboardHeader(title = "Telemedicine HP"),
dashboardSidebar(),
dashboardBody(
fluidRow(
valueBox( 60, subtitle = tags$p("Attended", style = "font-size: 200%;"),
icon = icon("trademark"), color = "purple", width = 4,
href = NULL))))
server <- function(input,output){
}
shinyApp(ui, server)
Here is another solution without shinyjs
library(shiny)
library(shinydashboard)
library(shinyBS)
data <- iris
ui <- tagList(
dashboardPage(
dashboardHeader(title = "Telemedicine HP"),
dashboardSidebar(),
dashboardBody(
fluidRow(
div(id='clickdiv',
valueBox(60, subtitle = tags$p("Attended", style = "font-size: 200%;"), icon = icon("trademark"), color = "purple", width = 4, href = NULL)
)
),
bsModal("modalExample", "Data Table", "clickdiv", size = "large",dataTableOutput("table"))
)
)
)
server <- function(input, output, session){
output$table <- renderDataTable({
head(data)
})
}
shinyApp(ui, server)
You can create an onclick event with shinyjs. Therefore you need to add useShinyjs() in your ui, which you can do by wrapping your ui in a tagList.
The onclick function is triggered in your server when an element with a given ID is clicked. So you also need to give the valueBox an ID. I decided to wrap it in a div with an ID.
Next part is to create a popup whenever the onclick event is triggered. You can do this by using the showModal function from shinyBS.
Working example
library(shiny)
library(shinydashboard)
library(shinyjs)
library(shinyBS)
data <- iris
ui <- tagList(
useShinyjs(),
dashboardPage(
dashboardHeader(title = "Telemedicine HP"),
dashboardSidebar(),
dashboardBody(
fluidRow(
div(id='clickdiv',
valueBox(60, subtitle = tags$p("Attended", style = "font-size: 200%;"), icon = icon("trademark"), color = "purple", width = 4, href = NULL)
)
)
)
)
)
server <- function(input, output, session){
onclick('clickdiv', showModal(modalDialog(
title = "Your title",
renderDataTable(data)
)))
}
shinyApp(ui, 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)
I setup the UI in server.R for more control, but shinyDashboard does not work when defined in server.R.
I use this method with navBarPage without problems.
This code works
library(shiny)
library(shinydashboard)
ui <- dashboardPage( dashboardHeader( ),
dashboardSidebar(),
dashboardBody() )
server <- shinyServer(function(input, output) { })
runApp(list(ui= ui, server = server))
But this one just show an empty page
ui <- uiOutput('dash')
server <- shinyServer(function(input, output) {
output$dash <- renderUI({
dashboardPage(dashboardHeader( ),
dashboardSidebar(),
dashboardBody() )
})
})
runApp(list(ui= ui, server = server))
This is an example using navBarPage, that works fine
ui <- uiOutput('nav')
server <- shinyServer(function(input, output) {
output$nav <- renderUI({
navbarPage("App Title",
tabPanel("Tab 1"),
tabPanel("Tab 2") )
})
})
runApp(list(ui= ui, server = server))
I don't think that you can use only a uiOutput to create a dashboard. I'm assuming that your goal is to create a dynamic dashboard. For that you need to define the header, body and side bar in your UI and use functions such as renderMenu on SERVER to create it. Here is an example to create a dashboard with all the UI defined in the SERVER.
ui <- dashboardPage(
dashboardHeader(title = "My Page"),
dashboardSidebar(sidebarMenuOutput("sideBar_menu_UI")),
dashboardBody(
uiOutput("body_UI"),
uiOutput("test_UI")
)
)
server <- shinyServer(function(input, output, session) {
output$sideBar_menu_UI <- renderMenu({
sidebarMenu(id = "sideBar_Menu",
menuItem("Menu 1", tabName="menu1_tab", icon = icon("calendar")),
menuItem("Menu 2", tabName="menu2_tab", icon = icon("database"))
)
})
output$test_UI <- renderUI ({
tabItems(
tabItem(tabName = "menu1_tab", uiOutput("menu1_UI")),
tabItem(tabName = "menu2_tab", uiOutput("menu2_UI"))
)
})
output$body_UI <- renderUI ({
p("Default content in body outsite any sidebar menus.")
})
output$menu1_UI <- renderUI ({
box("Menu 1 Content")
})
output$menu2_UI <- renderUI ({
box("Menu 2 Content")
})
})
runApp(list(ui= ui, server = server))
In this example, a menu for the sidebar is not selected by default and the content of body_UI will be visible all the time. If you want that your dashboard starts on a specific menu, put the sidebarMenu in your UI. Also you can delete the body_UI.
I have initial loading of data from the DB in the server.R which takes a few seconds. Until this is done, the page displayed is distorted (wrong data in selection box, and weird placing of the boxes, see below).
I want to display a different page (or at least different content in my first-displayed tab) until the data is completely loaded.
I thought about doing some kind of conditionalPanel using a condition based on a dedicated global variable (initial_loading_done), but wherever I tried placing the conditionalPanel it didn't work.
This is the structure of my UI.R:
shinyUI(
dashboardPage(
dashboardHeader(title = "Title"),
dashboardSidebar(
sidebarMenu(
menuItem("Tab1", tabName = "Tab1",icon = icon("dashboard")),
menuItem("Tab2", tabName = "Tab2", icon = icon("bar-chart-o"))
)
),
dashboardBody(
includeCSS("custom_css.css"),
tabItems(
tabItem(tabName = "Tab1",
fluidRow(<content>),
mainPanel(
fluidRow(<content>)
)
),
tabItem(tabName = "Tab2",
fluidRow(<content>),
mainPanel(
dataTableOutput('my_data_table')
)
)
)
)
)
)
Here's a very simple example using shinyjs package
The idea is to create the loading "page" and the content "page" under different IDs, have the content page initially hidden, and use show() and hide() after the app is ready
library(shiny)
library(shinyjs)
load_data <- function() {
Sys.sleep(2)
hide("loading_page")
show("main_content")
}
ui <- fluidPage(
useShinyjs(),
div(
id = "loading_page",
h1("Loading...")
),
hidden(
div(
id = "main_content",
"Data loaded, content goes here"
)
)
)
server <- function(input, output, session) {
load_data()
}
shinyApp(ui = ui, server = server)
In server I like to use reactiveValues() to store a setupComplete condition. Then, when the data is loaded my setupComplete is set to TRUE.
In the ui we can then assess this setupComplete condition in a conditionalPanel, and only display the content (in my example the three box() widgets).
Here's a working example
## app.R ##
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
actionButton(inputId = "btn_data", label = "Download"),
conditionalPanel(condition = "output.setupComplete",
box( title = "box1" ),
box( title = "box2" ),
box( title = "boc3" )
),
conditionalPanel(condition = "!output.setupComplete",
box( title = "loading"))
)
)
server <- function(input, output) {
rv <- reactiveValues()
rv$setupComplete <- FALSE
## simulate data load
observe({
if(input$btn_data){
df <- data.frame(id = seq(1,200),
val = rnorm(200, 0, 1))
## Simulate the data load
Sys.sleep(5)
## set my condition to TRUE
rv$setupComplete <- TRUE
}
## the conditional panel reads this output
output$setupComplete <- reactive({
return(rv$setupComplete)
})
outputOptions(output, 'setupComplete', suspendWhenHidden=FALSE)
})
}
shinyApp(ui, server)
The code
hidden(
div(
id = "main_content",
"Data loaded, content goes here"
)
doesn't work with tabsetPanel. But if you move the id to the div level it works beautifully. Thanks to shinyjs author Dean Attali for this tip. https://stackoverflow.com/users/4432127/keshete
hidden(
div(id = "mainTabsetPanel",
tabsetPanel(
....