For the dropdownMenu in the header, I want to change the icon reactively, so I have to place the code into server. However the styling goes bonkers, is there a way to keep the original styling? I've tried manually copying styles and setting everything important but it still doesn't work.
In this example, there are two dropdownMenu blocks, one in the ui (looks good) and one in the server (looks bad). I want to make the bad one look the same as the good one.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPagePlus(
header = dashboardHeaderPlus(
uiOutput("my_dropdown"),
dropdownMenu(
type = "tasks",
badgeStatus = "danger",
icon = "Looks good"
)
),
sidebar = dashboardSidebar(),
body = dashboardBody(),
rightsidebar = rightSidebar()
),
server = function(input, output) {
output$my_dropdown <- renderUI({
dropdownMenu(
type = "tasks",
badgeStatus = "danger",
icon = "Looks bad"
)
})
}
)
This is what it looks like
This is what it should look like
Related
In the Shiny App below, I am facing a very strange behavior, where selectInput box slides downwards when I type something in this box. Also, the text inside selectInput box moves towards the right while I type in this box. I have spent a lot of time to find out the reason for this problem but could not figure it out. Can someone point out the mistake I am doing causing this strange behavior?
library(shiny)
library(shinydashboard)
library(highcharter)
siderbar <- dashboardSidebar(
sidebarMenu(
selectizeInput(inputId = "select_by", label = "Select by:", choices = NULL, multiple = FALSE, options = NULL)
)
)
body <- dashboardBody(
fluidRow(
tabBox(
side = "right",
selected = "Tab1",
tabPanel("Tab1", "Tab content 1", highchartOutput("tabset1Selected"))
)
),
)
shinyApp(
ui = dashboardPage(
dashboardHeader(title = "tabBoxes"),
siderbar,
body
),
server = function(input, output, session) {
selectedVal <- reactiveValues()
updateSelectizeInput(session, "select_by", choices = c(as.character(1:10000)), selected = 2, server = TRUE)
output$tabset1Selected <- renderHighchart({
selectedVal <- input$select_by
print(highcharts_demo())
})
}
)
We were on the right track. It has something to do with selectize.js updating the items from the server. You can verify that by setting the loadThrottle option to 5000. This option determines how long the widget waits "before requesting options from the server" (see the manual). Now you have to wait exactly 5 seconds and then the select widget flickers.
The issue seems to be caused by a CSS conflict. selectize.js adds a CSS class to the widget. If you remove that feature, the flicker goes away.
selectizeInput(inputId = "select_by", label = "Select by:",
choices = NULL, multiple = FALSE,
options = list(loadThrottle=200, loadingClass=""))
loadingClass sets a specific CSS class (default: 'loading') while loading data from the server. Purpose: to change how the widget looks and communicate to users that an update is in progress.
loadThrottle does not need to be set. It's default is 300. You can set it to any value that suits your needs.
Details
highcharter defines it's own CSS class names loading with these specs:
.loading {
margin-top: 10em;
text-align: center;
color: gray;
}
That is the reason for the CSS conflict. The widget gets a top margin and it's content moved to the center, because the browser does not distinguish the source of the class. It only sees some CSS that fits and uses it. This image shows where you need to look:
I was trying to add website information on my shiny dashboard and for the "About" section (See image) I want few lines to be displayed on the dashboard body when clicked on that tab. how could i possibly achieve it? I could successfully add href for the "contact" section.
Maybe I do not understand your question properly, but what about:
library(shiny)
library(shinydashboard)
header <- dashboardHeader()
sidebar <- dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("About", icon = icon("info"), tabName = "about"),
menuItem("Contact", icon = icon("phone"), tabName = "contact")
)
)
)
body <- dashboardBody(
tabItems(
tabItem("about",
h1("About")),
tabItem("contact",
h1("Contact"))
)
)
shinyApp(
ui = dashboardPage(header, sidebar, body),
server = function(input, output) { }
)
When you click on About you get a new tab in the dashboardBody where you can display whatever you want.
Update
Based on your clarification you can use shinyjs to hide/show the relevant part:
library(shiny)
library(shinydashboard)
library(shinyjs)
header <- dashboardHeader()
sidebar <- dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("About", icon = icon("info"), tabName = "about"),
menuItem("Contact", icon = icon("phone"), tabName = "contact")
)
)
)
body <- dashboardBody(
useShinyjs(),
fluidPage(
fluidRow(id = "mainContent",
column(12, h1("Main Content"))
),
hidden(fluidRow(id = "contact", h1("Contact Info")))
)
)
shinyApp(
ui = dashboardPage(header, sidebar, body),
server = function(input, output) {
observe({
if (input$tabs == "contact") {
hideElement("mainContent")
showElement("contact")
} else {
hideElement("contact")
showElement("mainContent")
}
})
}
)
When you now click on Contact the main part is hidden and the contact is shown. I have, however, the feeling that is a bit mis-using the idea of shinydashboard.
#thothal, it did not allow me to add as a comment coz of the length, hence posting my comment(below) as an answer.
I am sorry if I was unclear. However, your answer helped me partially. I have incorporated tabItems part in my dashboardBody section, as shown below:
dashboardBody(
fluidPage(
fluidRow(
column(12, div(dataTableOutput("dataTable")))
)
),
tabItems(
tabItem("About", h1("text to be displayed"))
)
)
but the "text to be displayed" shows up below the table.
What I want is, About section (when clicked) should display only the text and not the table. I understand this is just formatting of the code in dashboardBody section but I don't know how to do it.
Just to be more clear, my dashboard's section should display the datatable at all times and the about section when clicked should show up the text and not the datatable. I really hope this is clear. Thanks a ton for your help :)
I have an issue while creating a shiny web app using semantic.dashboard library.
Below is the code for my app.
library(semantic.dashboard)
# Define UI
header <- dashboardHeader(
)
sidebar <- dashboardSidebar(
side = "left",
sidebarMenu(
menuItem(tabName = "overview", text = "Overview", icon = icon("home")),
menuItem(tabName = "analysis", text = "Analysis", icon = icon("chart bar"))
)
)
body <- dashboardBody(
dateRangeInput("datepicker", NULL, start = Sys.Date()-30, end = Sys.Date()-1)
)
tabItems(
tabItem(
tabName = "overview",
fluidRow(
)
),
tabItem(
tabName = "analysis",
fluidRow(
)
)
)
ui <- dashboardPage(
header,
sidebar,
body,
title = "My Dashboard",
theme = "lumen"
)
# Define server logic
server <- function(input, output, session) {
session$onSessionEnded(stopApp)
}
# Run the application
shinyApp(ui = ui, server = server)
The result is in the screenshot below:
The main problem is that the dates inside the daterangeinput widget are just like simple text inside textbox.
I can't click on them to change the dates.
Using fluidPage() would resolve the problem, but the whole web page isn't filled totally by the app (and for this app, responsiveness isn't really useful).
Below is the screenshot of the app when I use fluidPage(), you can see that there's so much space between the sidebar and the border, and beetween the sidebar and the body.
app with fluidPage()
I'd like to know if it's possible to use daterangeinput without using fluidPage() or, if not possible, know how to remove the padding between the border and the sidebar when using fluidPage.
Thanks in advance for your help.
Above example doesn't work because it uses bootstrap framework styles - contrary to shiny.semantic or semantic.dashboard packages.
Please check my PR to shiny.semantic package. I've implemented there simple date input with usage of semantic-ui components. You can also use it to create simple date range (added quick example in PR).
In RShiny is there any way to send an array or list of menuItems to sidebarMenu?
dashboardSidebar(width = 180,
sidebarMenu(
menuItem("server1", tabName = "server1", icon = icon("server")),
menuItem("server2", tabName = "server2", icon = icon("server")),
menuItem("server3", tabName = "server3", icon = icon("server"))
)
)
I actually have to add about 30 or menuItems to add and the names will change over time. This is also an issue with sending multiple fluidRows to a tabItem. Hopefully, the same solution can apply to both.
There is the possibility to use uiOutput, but personally, I am not a fan. However, there is not a single solution for all dynamic element additions, especially when not using uiOutput.
Here is a minimal solution that does what you said you wanted, but I guess this is only the first step for you (since I don't think you really just want to add menuItems). If you are looking for a more customized answer, please edit your original post with your actual problems.
You can add menuItems to the sidebar very easily, if you use JavaScript/jQuery. This is mainly because menuItems are not really "connected" to the Shiny-App but merely toggle buttons. It gets more difficult if you wanted to add complex reactive elements.
There is basically the trick that you give the target element (sidebar) an Id for easy selection and add the HTML that is generated by the shiny ui functions. The customMessageHandler gets both components and tells the browser to create the element.
More on customMessageHandlers can be found here.
Sample code below:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(width = 180,
sidebarMenu(id = "nice",
menuItem("server1", tabName = "server1", icon = icon("server")),
menuItem("server2", tabName = "server2", icon = icon("server")),
menuItem("server3", tabName = "server3", icon = icon("server"))
)
),
dashboardBody(
actionButton("button", "Add MenuItem"),
tags$script("
Shiny.addCustomMessageHandler('addMenuItem', function(message){
$('#' + message[0]).append(message[1]);
})
")
)
)
server <- function(input, output, session){
addMenuItem <- function(item, sidebarId){
session$sendCustomMessage(type = "addMenuItem", message = list(sidebarId, as.character(item)))
}
observeEvent(input$button, {
newId <- as.numeric(input$button) + 3
newMenuItem <- menuItem(paste0("server", newId), tabName = paste0("server", newId), icon = icon("server"))
addMenuItem(newMenuItem, "nice")
})
}
shinyApp(ui, server)
So just curious, is there any way to add a company logo to the header of a ShinyDashboard? As I am looking at the documentation, it describes changing the "logo" in the CSS, this is just configuring what goes in the upper left hand corner though as far as I can tell and I would like to keep my title there.
I am not using the drop down menus and so I would like to add my company logo on the top right where the red box is.
Does anyone have any idea how this can be done with Shinydashboard? Thanks.
Update 2020-10-27
For users that are comfortable with HTML or want more flexibility around their user interface and have access to a front end developer, I recently discovered you can use HTML to build the entire user interface. There is a Shiny article about it here. This would allow the entire branding and layout to be done in a way that could comply with your company standards if desired. Hope this helps.
I've been working with a bit of a hack for this, (and I know you didn't ask for it, but here's a clickable logo while we're at it):
library(shiny)
library(shinydashboard)
dbHeader <- dashboardHeader()
dbHeader$children[[2]]$children <- tags$a(href='http://mycompanyishere.com',
tags$img(src='logo.png',height='60',width='200'))
dashboardPage(
dbHeader,
dashboardSidebar(),
dashboardBody()
)
So this nests a shiny.tag inside the header. The second slot in this particular shiny object is the logo slot (You'll need a 'logo.png' in your /www/ folder in the app directory)
EDIT:
I just checked, and as of right now, this hack should no longer be necessary, you can insert the html directly from the dashboardHeader function via the title= parameter, (Before, that parameter was enforcing text only),
I think the answer might still be useful as a method to modify existing shiny functions where things ARE hardcoded in though.
Here's the method now:
dashboardPage(
dashboardHeader(title = tags$a(href='http://mycompanyishere.com',
tags$img(src='logo.png')))
or, adding a little more magic to the logo (I also use my logo as a loading bar):
# Takes a location 'href', an image location 'src', a loading gif 'loadingsrc'
# height, width and alt text, and produces a loading logo that activates while
# Shiny is busy
loadingLogo <- function(href, src, loadingsrc, height = NULL, width = NULL, alt = NULL) {
tagList(
tags$head(
tags$script(
"setInterval(function(){
if ($('html').attr('class')=='shiny-busy') {
$('div.busy').show();
$('div.notbusy').hide();
} else {
$('div.busy').hide();
$('div.notbusy').show();
}
},100)")
),
tags$a(href=href,
div(class = "busy",
img(src=loadingsrc,height = height, width = width, alt = alt)),
div(class = 'notbusy',
img(src = src, height = height, width = width, alt = alt))
)
)
}
dashboardBody(
dashboardHeader(title = loadingLogo('http://mycompanyishere.com',
'logo.png',
'loader.gif'),
dashboardSidebar(),
dashboardBody()
)
Here's my hack (put your logo, as has been mentioned before, into a www subdirectory of your app directory).
Because dashboardHeader() expects a tag element of type li and class dropdown, we can pass such elements instead of dropdownMenus:
library(shiny)
library(shinydashboard)
dbHeader <- dashboardHeader(title = "My Dashboard",
tags$li(a(href = 'http://shinyapps.company.com',
icon("power-off"),
title = "Back to Apps Home"),
class = "dropdown"),
tags$li(a(href = 'http://www.company.com',
img(src = 'company_logo.png',
title = "Company Home", height = "30px"),
style = "padding-top:10px; padding-bottom:10px;"),
class = "dropdown"))
server <- function(input, output) {}
shinyApp(
ui = dashboardPage(
dbHeader,
dashboardSidebar(),
dashboardBody()
),
server = server
)