I'm putting the finishing touches on a shinydashboard. The dashboard uses googleAuthR for authentication via google oauth. Everything is working... but I currently have to put the login button in either the dashboardSidebar or dashboardBody, and I'd really really like it up where the dropdowns go in dashboardHeader. Unfortunately, it seems like shinydashboard's header is picky about what can go up in the header. Is there a hack (or less than a hack) to put stuff up there?
Here's a thing that definitely doesn't work, for example:
ui = dashboardPage(
dashboardHeader(
title = "My Awesome Dashboard"
, p('Pretend this is a login button')
)
, dashboardSidebar(
p('I don't want the login here.')
)
, dashboardBody(
p('I don't want the login here either.')
)
)
server = function(input, output, session) {
}
shinyApp(
ui = ui
, server = server
)
You can place anything in the header, but it needs to be a li tag of class dropdown. See the following example:
ui = dashboardPage(
dashboardHeader(
title = "My Awesome Dashboard",
tags$li(class = "dropdown",
tags$li(class = "dropdown", textOutput("logged_user"), style = "padding-top: 15px; padding-bottom: 15px; color: #fff;"),
tags$li(class = "dropdown", actionLink("login", textOutput("logintext"))))
)
, dashboardSidebar(), dashboardBody())
server = function(input, output, session) {
logged_in <- reactiveVal(FALSE)
# switch value of logged_in variable to TRUE after login succeeded
observeEvent(input$login, {
logged_in(ifelse(logged_in(), FALSE, TRUE))
})
# show "Login" or "Logout" depending on whether logged out or in
output$logintext <- renderText({
if(logged_in()) return("Logout here.")
return("Login here")
})
# show text of logged in user
output$logged_user <- renderText({
if(logged_in()) return("User 1 is logged in.")
return("")
})
}
shinyApp(ui = ui, server = server)
Ok, I think I figured it out based on Adding a company Logo to ShinyDashboard header , but I'm not sure yet why it works. Here's the general idea:
my_header = dashboardHeader(
title = "My More Awesome Dashboard"
)
my_header$children[[3]]$children[[3]] = p('Login goes here', style = 'float: right')
ui = dashboardPage(db_header, dashboardSidebar, dashboardBody)
Now to see if I can find documentation somewhere explaining the $children stuff...
Related
In order to make an app where panels are created dynamically, I would like to remove, hide and/or update panels from the package shinyWidgets.
I didn't find any function to do so nor way to add IDs to these panel.
If you have the solution or a way around, I would be more than happy. Thank you in advance !
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
panel(
heading = "Test panel",
actionButton("remove_panel", "Remove this panel")
)
)
server <- function(input, output) {
observeEvent(input$remove_panel,{
print("remove panel")
})
}
shinyApp(ui = ui, server = server)
There is no official method you can use to change the panel states, but we can do it with custom expressions.
library(shiny)
library(shinyWidgets)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
panel(
heading = "Test panel1",
id = "test_panel1",
actionButton("remove_panel", "Remove this panel")
),
panel(
heading = "Test panel2",
id = "test_panel2",
"some content"
),
actionButton("hide_panel", "Hide this panel")
)
server <- function(input, output) {
observeEvent(input$remove_panel,{
removeUI('.panel:has([id="test_panel1"])', immediate = TRUE)
})
observeEvent(input$hide_panel,{
toggle(selector = '.panel:has([id="test_panel2"])')
if(input$hide_panel %% 2 == 1) return(updateActionButton(inputId = "hide_panel", label = "Show this panel"))
updateActionButton(inputId = "hide_panel", label = "Hide this panel")
})
}
shinyApp(ui = ui, server = server)
To remove:
add an ID argument to your panel, and use removeUI to remove it. Remember to change the ID in you own case.
To hide/show:
We can use toggle from shinyjs to show or hide some elements we choose.
Use updateActionButton to also change it text when hidden.
I am trying to add an external URL in a shiny dashboard that uses the package bs4Dash but when I click in it their is no response. I have something similar to the example below. It does not work using newTab = FALSE or newTab = TRUE. Am I missing something or this is the way it is supposed to behave?
# NOT RUN {
## Only run this example in interactive R sessions
if (interactive()) {
library(shiny)
library(bs4Dash)
# A dashboard header with 3 dropdown menus
header <- dashboardHeader(
title = "My dashboard"
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("My menu L1", href = "https://rinterface.github.io/bs4Dash/", newTab = FALSE),
menuItem("My menu L2",
menuSubItem("My submenu 1", href = "https://rinterface.github.io/bs4Dash/", newTab = TRUE)
)
)
)
shinyApp(
ui = dashboardPage(
header,
sidebar,
dashboardBody()
),
server = function(input, output) { }
)
}
# }
#Dwight, I "solved" this issue via a hack. Basically, I started using the shinydashboard::menuItem for those particular instances. I think the author fix this and hopefully will be available in the next version (https://github.com/RinteRface/bs4Dash/issues/225).
shinydashboard::menuItem(
text = "Help",
href = "http://example.com"
)
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
I used bsModal successfully in my code before. However, I can't seem to get a modal pop up to show just when the user visits an app's first page by default. I thought something like this would work, but not. Any idea how I can trigger a bsModal on page visit?
library(shiny)
library(shinyBS)
ui <- fluidPage(
mainPanel(
bsModal(id = 'startupModal', title = 'Dum Dum', trigger = '',
size = 'large', p("here is my mumbo jumbo")),
width = 12
)
)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
I simply need to alert the user with a message when they visit the app and then allow them to close the modal pop up and navigate the rest of the app freely. I am using Shinydashboard. So, eventually, this has to work with that.
You can use toggleModal to manually trigger the popup from the server.
library(shiny)
library(shinyBS)
ui <- fluidPage(
mainPanel(
bsModal(id = 'startupModal', title = 'Dum Dum', trigger = '',
size = 'large', p("here is my mumbo jumbo")),
width = 12
)
)
server <- function(input, output, session) {
toggleModal(session, "startupModal", toggle = "open")
}
shinyApp(ui = ui, server = server)
Here is a solution using JS to trigger bsModal when page load "onload" from ui without waiting for the server. Along with a solution proposed here to prevent end users from accidentally closing the modal by clicking outside the modal or press Esc
library(shiny)
library(shinyBS)
bsModalNoClose <-function(...) {
b = bsModal(...)
b[[2]]$`data-backdrop` = "static"
b[[2]]$`data-keyboard` = "false"
return(b)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
bsModalNoClose("window", "Window",
title="Enter Login Details",size='small',
textInput('username', 'Username'),
passwordInput('pwInp', 'Password'),
actionButton('butLogin', 'Login', class = 'btn action-button btn-success', icon = icon('sign-in')),
footer = h4(actionLink('create_account','Create an account'),align='right'),
tags$head(tags$style("#window .modal-footer{display:none}
.modal-header .close{display:none}"),
tags$script("$(document).ready(function(){
$('#window').modal();
});")
))
)
,mainPanel()
))
server <- function(input, output, session) {}
shinyApp(ui, server)
I hope it may be helpful for future readers.
I have a problem with shiny tabs. I want to create a navigation page with two tabs. Right to them, I would like to insert some user's login details. There is no option "text" or other to insert a text in the navbarPage. But I created an additionnal tab instead:
library(shiny)
runApp(list(
ui = navbarPage(
title="My App",
tabPanel("tab1 title"),
tabPanel("tab2 title"),
tabPanel("User: Madzia")),
server = function(input, output) { }
))
It is OK like this, but I do not want the third tab to be "selectible": I want it to be disabled, so that we cannot click on it - the same as on "My App" text. Do you have any idea about how to handle this problem?
Thank you! Best, Madzia
You can achieve disabling a tab with a tiny bit of javascript. I have an example of how to hide a tab (not disable) in recent blog post, you can see the code for that here. I modified that code a bit for disabling instead.
This code is hacky because it was done in 2 minutes but will work for a basic use case
library(shiny)
library(shinyjs)
jscode <- '
shinyjs.init = function() {
$(".nav").on("click", ".disabled", function (e) {
e.preventDefault();
return false;
});
}
'
css <- '
.disabled {
background: #eee !important;
cursor: default !important;
color: black !important;
}
'
shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jscode, functions = "init"),
tags$style(css),
checkboxInput("foo", "Disable tab2", FALSE),
tabsetPanel(
id = "navbar",
tabPanel(title = "tab1",
value = "tab1",
h1("Tab 1")
),
tabPanel(title = "tab2",
value = "tab2",
h1("Tab 2")
),
tabPanel(title = "tab3",
value = "tab3",
h1("Tab 3")
)
)
),
server = function(input, output) {
observe({
toggleClass(condition = input$foo,
class = "disabled",
selector = "#navbar li a[data-value=tab2]")
})
}
)
Edit I didn't fully read the question when I posted my answer, I just saw that you wanted a way to disable a tab and that was my answer. Your specific usecase (creating a tab only to show the name of a user) is a bit strange, but I suppose this will still work...
I would like to keep my previous answer in existence because it may be useful for someone in the future who wants to know how to disable a tab.
But for this specific problem, disabling the tab is not the correct approach. It makes more sense to simply add text to the tab (as Valter pointed out in a comment). If you look at the documentation for bootstrap, it says you can add text into the navbar by adding an html element with class navbar-text. I experimented with the HTML a little bit to figure out exactly where this needs to be done, and created a little function that will wrap around navbarPage() to allow you to add text to it.
Here's an example:
library(shiny)
navbarPageWithText <- function(..., text) {
navbar <- navbarPage(...)
textEl <- tags$p(class = "navbar-text", text)
navbar[[3]][[1]]$children[[1]] <- htmltools::tagAppendChild(
navbar[[3]][[1]]$children[[1]], textEl)
navbar
}
ui <- navbarPageWithText(
"Test app",
tabPanel("tab1", "tab 1"),
tabPanel("tab2", "tab 2"),
text = "User: Dean"
)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)