I have a basic R shiny app that I would like to build a light/ dark mode switch for. I think if I can just get it working for the table tab it should be fine to do for the rest. I am aware that shinyjs is the best way to go about it but I can't seem to find the code anywhere.
library(dplyr)
library(shiny)
library(shinythemes)
ui <- fluidPage(theme = shinytheme("slate"),
tags$head(tags$style(HTML(
"
.dataTables_length label,
.dataTables_filter label,
.dataTables_info {
color: white!important;
}
.paginate_button {
background: white!important;
}
thead {
color: white;
}
"))),
mainPanel(tabsetPanel(
type = "tabs",
tabPanel(
title = "Table",
icon = icon("table"),
tags$br(),
DT::DTOutput("table")
)
)))
server <- function(input, output) {
output$table <- DT::renderDT({
iris
})
}
shinyApp(ui = ui, server = server)
EDITED: see notes at the end
If you want to use bootstrap themes, it's possible to do this using a checkbox input and a javascript event that adds/removes <link> elements (i.e., the html element that loads the bootstrap css theme). I switched the shinytheme to darkly as there's a corresponding light theme (flatly). I removed the css that you defined in tags$head as that will be added/removed based on the theme toggle. (see full example below)
Even though this works, there are likely performance issues. Be aware that each time the theme is changed, the file is fetched and reloaded into the browser. There are also style differences between themes, this may cause content to be reorganized or moved slightly when new theme is applied (this may be disruptive for the user). If you were to choose this approach, I would recommend finding a well-designed light and dark theme combo.
Alternatively, you can select a basic bootstrap theme and define your own css themes. You can use a toggle (like this example) or the media query prefers-color-scheme. Then the shinyjs class functions, you can toggle themes from the R server. This approach is often recommended, but does take a bit longer to develop and validate.
Using the bootstrap approach, here's how you could switch themes.
app.R
In the ui, I created a checkbox input and placed it as the last element (for example purposes).
checkboxInput(
inputId = "themeToggle",
label = icon("sun")
)
JS
To switch the bootstrap themes, I defined the html dependency paths defined by the shinythemes package. You can find these in your R package library (library/shinythemes/).
const themes = {
dark: 'shinythemes/css/darkly.min.css',
light: 'shinythemes/css/flatly.min.css'
}
To load a new theme, the paths need to be rendered as an html element. We will also need a function that removes an existing css theme. The easiest way to do that is to select the element that has a matching href as defined in the themes variable.
// create new <link>
function newLink(theme) {
let el = document.createElement('link');
el.setAttribute('rel', 'stylesheet');
el.setAttribute('text', 'text/css');
el.setAttribute('href', theme);
return el;
}
// remove <link> by matching the href attribute
function removeLink(theme) {
let el = document.querySelector(`link[href='${theme}']`)
return el.parentNode.removeChild(el);
}
I also removed the styles defined in the tags$head and created a new <style> element in js.
// css themes (originally defined in tags$head)
const extraDarkThemeCSS = ".dataTables_length label, .dataTables_filter label, .dataTables_info { color: white!important;} .paginate_button { background: white!important;} thead { color: white;}"
// create new <style> and append css
const extraDarkThemeElement = document.createElement("style");
extraDarkThemeElement.appendChild(document.createTextNode(extraDarkThemeCSS));
// add element to <head>
head.appendChild(extraDarkThemeElement);
Lastly, I created an event and attached it to the checkbox input. In this example, checked = 'light' and unchecked = 'dark'.
toggle.addEventListener('input', function(event) {
// if checked, switch to light theme
if (toggle.checked) {
removeLink(themes.dark);
head.removeChild(extraDarkThemeElement);
head.appendChild(lightTheme);
} else {
// else add darktheme
removeLink(themes.light);
head.appendChild(extraDarkThemeElement)
head.appendChild(darkTheme);
}
})
Here's the full app.R file.
library(dplyr)
library(shiny)
library(shinythemes)
ui <- fluidPage(
theme = shinytheme("darkly"),
mainPanel(
tabsetPanel(
type = "tabs",
tabPanel(
title = "Table",
icon = icon("table"),
tags$br(),
DT::DTOutput("table")
)
),
checkboxInput(
inputId = "themeToggle",
label = icon("sun")
)
),
tags$script(
"
// define css theme filepaths
const themes = {
dark: 'shinythemes/css/darkly.min.css',
light: 'shinythemes/css/flatly.min.css'
}
// function that creates a new link element
function newLink(theme) {
let el = document.createElement('link');
el.setAttribute('rel', 'stylesheet');
el.setAttribute('text', 'text/css');
el.setAttribute('href', theme);
return el;
}
// function that remove <link> of current theme by href
function removeLink(theme) {
let el = document.querySelector(`link[href='${theme}']`)
return el.parentNode.removeChild(el);
}
// define vars
const darkTheme = newLink(themes.dark);
const lightTheme = newLink(themes.light);
const head = document.getElementsByTagName('head')[0];
const toggle = document.getElementById('themeToggle');
// define extra css and add as default
const extraDarkThemeCSS = '.dataTables_length label, .dataTables_filter label, .dataTables_info { color: white!important;} .paginate_button { background: white!important;} thead { color: white;}'
const extraDarkThemeElement = document.createElement('style');
extraDarkThemeElement.appendChild(document.createTextNode(extraDarkThemeCSS));
head.appendChild(extraDarkThemeElement);
// define event - checked === 'light'
toggle.addEventListener('input', function(event) {
// if checked, switch to light theme
if (toggle.checked) {
removeLink(themes.dark);
head.removeChild(extraDarkThemeElement);
head.appendChild(lightTheme);
} else {
// else add darktheme
removeLink(themes.light);
head.appendChild(extraDarkThemeElement)
head.appendChild(darkTheme);
}
})
"
)
)
server <- function(input, output) {
output$table <- DT::renderDT({
iris
})
}
shinyApp(ui, server)
EDITS
In this example, I used a checkBoxInput. You can "hide" the input using the following css class. I would recommend adding a visually hidden text element to make this element accessible. The UI would be changed to the following.
checkboxInput(
inputId = "themeToggle",
label = tagList(
tags$span(class = "visually-hidden", "toggle theme"),
tags$span(class = "fa fa-sun", `aria-hidden` = "true")
)
)
Then add the css following css. You can also select and style the icon using #themeToggle + span .fa-sun
/* styles for toggle and visually hidden */
#themeToggle, .visually-hidden {
position: absolute;
width: 1px;
height: 1px;
clip: rect(0 0 0 0);
clip: rect(0, 0, 0, 0);
overflow: hidden;
}
/* styles for icon */
#themeToggle + span .fa-sun {
font-size: 16pt;
}
Here's the updated ui. (I removed the js to make the example shorter)
ui <- fluidPage(
theme = shinytheme("darkly"),
tags$head(
tags$style(
"#themeToggle,
.visually-hidden {
position: absolute;
width: 1px;
height: 1px;
clip: rect(0 0 0 0);
clip: rect(0, 0, 0, 0);
overflow: hidden;
}",
"#themeToggle + span .fa-sun {
font-size: 16pt;
}"
)
),
mainPanel(
tabsetPanel(
type = "tabs",
tabPanel(
title = "Table",
icon = icon("table"),
tags$br(),
DT::DTOutput("table")
)
),
checkboxInput(
inputId = "themeToggle",
label = tagList(
tags$span(class = "visually-hidden", "toggle theme"),
tags$span(class = "fa fa-sun", `aria-hidden` = "true")
)
)
),
tags$script("...")
)
You can dynamically switch between bootstrap themes by downloading their CSS files from here, putting them into a folder in your project and using includeCSS in a dynamically generated UI chunk:
library(dplyr)
library(shiny)
library(shinythemes)
ui <- fluidPage(
theme = shinytheme("flatly"),
uiOutput("style"),
tags$head(
tags$style(
HTML(
"
.dataTables_length label,
.dataTables_filter label,
.dataTables_info {
color: white!important;
}
.paginate_button {
background: white!important;
}
thead {
color: white;
}
"
)
)
),
mainPanel(
tabsetPanel(
type = "tabs",
tabPanel(
title = "Table",
icon = icon("table"),
tags$br(),
DT::DTOutput("table")
)
),
checkboxInput("style", "Dark theme")
)
)
server <- function(input, output) {
output$table <- DT::renderDT({
iris
})
output$style <- renderUI({
if (!is.null(input$style)) {
if (input$style) {
includeCSS("www/darkly.css")
} else {
includeCSS("www/flatly.css")
}
}
})
}
shinyApp(ui = ui, server = server)
From what I understand, this will solve the problem.
The advantage of this approach is that if you remove the checkbox and then generate it again, it will still work. Personally, I was going to use dcruvolos helpful solution in my app until I realised that I can't use it with shiny.router because as soon as you temporarily remove the checkbox from the UI, the JS code stops working (if I understand correctly).
Here is a checkbox in the form of a uiOutput that you can add or remove and it will continue working:
library(dplyr)
library(shiny)
library(shinythemes)
ui <- fluidPage(
theme = shinytheme("flatly"),
uiOutput("style"),
tags$head(
tags$style(
HTML(
"
.dataTables_length label,
.dataTables_filter label,
.dataTables_info {
color: white!important;
}
.paginate_button {
background: white!important;
}
thead {
color: white;
}
"
)
)
),
mainPanel(
tabsetPanel(
type = "tabs",
tabPanel(
title = "Table",
icon = icon("table"),
tags$br(),
DT::DTOutput("table")
)
),
uiOutput("style_checkbox")
)
)
server <- function(input, output) {
output$table <- DT::renderDT({
iris
})
current_theme <- reactiveVal(FALSE)
output$style_checkbox <- renderUI({
checkboxInput("style", "Dark theme", value = current_theme())
})
output$style <- renderUI({
if (!is.null(input$style)) {
current_theme(input$style)
if (input$style) {
includeCSS("www/darkly.css")
} else {
includeCSS("www/flatly.css")
}
}
})
}
shinyApp(ui = ui, server = server)
Related
I have an actionButton defined in the UI as uiOutput("DartSearchAdv"). I would like the button to change color when input$target_min_ab is changed. And when input$DartSearchAdv is pressed, I want the color to go back to default.
I've tried implementing the suggestion here, and the color change will work as desired, but certain outputs generated from the button press are hidden ("mainPanelDST"). I can try getting them to appear if I do show("mainPanelDST"), but then the color change doesn't take place, or the button will disappear until input$target_min_ab is interacted with again.
Below is the relevant code from the server.
global <- reactiveValues(clicked = FALSE)
# Desired style for when button is clicked
defaultColor = 'padding:10px; font-size:120%;
color: white; background-color: #3E668E;
border-color: #2C3E50'
# Desired style for when a setting is changed
updateColor = 'padding:10px; font-size:120%;
color: white; background-color: #428BCA;
border-color: #95A5A6'
# render the button
output$DartSearchAdv <- renderUI({
if (global$clicked){
actionButton("DartSearchAdv", "Update Search",
style = defaultColor)
} else {
actionButton("DartSearchAdv", "Update Search",
style = updateColor)
}
})
And here are the inputs that should change the color
# input that changes color to updateColor
observeEvent(input$target_min_ab,{
rv$target_min_ab = input$target_min_ab/100;
global$clicked = FALSE;
})
# input that changes color to default
trigger_button2 <- eventReactive(input$DartSearchAdv, {
# Do stuff in here
global$clicked = TRUE
}
Perhaps this:
library(shiny)
# Desired style for when button is clicked
defaultColor <- "padding:10px; font-size:120%;
color: white; background-color: #3E668E;
border-color: #2C3E50"
# Desired style for when a setting is changed
updateColor <- "padding:10px; font-size:120%;
color: white; background-color: #428BCA;
border-color: #95A5A6"
ui <- fluidPage(
uiOutput("DartSearchAdv"), # will be an actionButton
numericInput("target_min_ab", "Target Min Ab", 1),
actionButton("DartSearchAdv", "DartSearchAdv")
)
server <- function(input, output, session) {
global <- reactiveValues(clicked = FALSE)
rv <- reactiveValues(target_min_ab = NULL)
# render the button
output$DartSearchAdv <- renderUI({
if (global$clicked) {
actionButton("DartSearchAdv", "Update Search",
style = defaultColor
)
} else {
actionButton("DartSearchAdv", "Update Search",
style = updateColor
)
}
})
observeEvent(input$target_min_ab,
{
rv$target_min_ab <- input$target_min_ab / 100
global$clicked <- TRUE
},
ignoreInit = TRUE
)
observeEvent(input$DartSearchAdv, {
global$clicked <- FALSE
})
}
shinyApp(ui, server)
[Edit]
I tried to simplify my code as much as possible:
server.R :
server <- function(input, output, session) {
output$body_UI<-renderUI({
tabPanel("Comparison",
{
fluidPage(
fluidRow(
box(
width=12,
solidHeader=T,
title="Parameters",
status="primary",
uiOutput('date_range_UI')
)
)
)
}
)})
output$date_range_UI <-renderUI({
dateRangeInput(
"date_1",
"Period 1",
start=NULL,
end=NULL
)
})
}
ui.R:
uiHeader <- dashboardHeader(title = NULL)
uiSidebar <- dashboardSidebar(sidebarMenuOutput('sidebar_UI'))
uiBody <- dashboardBody(
tags$head(
tags$style(type="text/css"
),
tags$link(rel = "stylesheet", type = "text/css", href = "style_v2.css")
),
uiOutput('body_UI')
)
dashboardPage(uiHeader,
uiSidebar,
uiBody,
skin = "black")
I think that my problem comes from the file style_v2.css :
.progress-bar, .irs-bar,.irs-bar-edge, .irs-from, .irs-to, .irs-single{
background-color:#000033;
}
.box.box-solid.box-primary>.box-header
{
background-color:#000033;
}
.box.box-solid.box-primary{
border: 1px solid #000033;
}
.box.box-primary, .nav-tabs-custom>.nav-tabs>li.active
{
border-top-color:#000033;
}
body {
background-color: #fff;
}
.content-wrapper, .right-side{
background-color:#FFFFFF;
}
.dropdown-menu{
background-color:#333;
}
This file is located in the folder 'www' which is in the same directory than server.R and ui.R.
If I delete this file, then I have no problem. But I need it and I don't know which part is causing this.
I'm trying to insert a period field using dateRangeInput (Shiny).
But I'm having problems in the display.
NB: I encounter the same problem using dateInput.
Here is an extract of server.R:
dateRangeInput(
"date_1",
"Period 1",
start=min(data$Date_processed),
end=""
)
This is completely illegible...
The issue is with this piece of code in your style_v2.css file:
.dropdown-menu {
background-color: #333;
}
#333 is the dark background you are seeing. You can either remove this or edit the hex colour to be lighter.
If that code is necessary for other dropdowns in your code you can be more specific regarding your css - let me know.
I've created some valueboxes with hyperlinks to different tabs within the app.
ui
tags$script(HTML("
var openTab = function(tabName){
$('a', $('.sidebar')).each(function() {
if(this.getAttribute('data-value') == tabName) {
this.click()
};
});
}
"))
server
output$tplot <- renderValueBox({
valueBox(
paste0(sum(rowSums(x)>0)),
tags$p(a("Total", onclick = "openTab('metrics')", href="#"),
style = "color: white;"),
icon = icon("boxes"),
color = "navy")
})
It works great, but the hyperlinks are always in a steelblue color and it limits my choice of readable colors for the valuebox.
Is there a way to change the hyperlink color? Is there a way to set the hyperlink color globally?
Hyperlinks have tag <a>. You can globally change hyperlink color by applying css to that tag. Here's minimal example -
library(shiny)
shinyApp(
ui = fluidPage(
tags$head(tags$style(HTML("a {color: red}"))),
tags$a("click here"),
br(),
tags$a("click here as well")
),
server = function(input, output, session) {
}
)
I'm creating a Shiny app in which I want to have a large (h1) formatted title and an action button right next to it, which when clicked on pops up a window with additional details and some other information. I got the button set up and working well (not included in the code). My problem is with the formatting of this line. Despite my best efforts the icon (an action button) gets pushed to a new row, even though it's in the same column as the dynamic text, and in the same h1 format as well. How could I achieve what I want?
library(shiny)
ui <- fluidRow(column(12, tags$h1(textOutput("chosen_date_fact"),
actionButton("scoping2",
label = icon("info-circle"),
style = "color: #000000; background-color: #ffffff; border-color: #ffffff"))))
server = function(input, output){
last_fact_date = '2017-07-16'
output$chosen_date_fact = renderText ({
date = as.Date(last_fact_date)
paste0('Details of', ' ', format(date,"%B"),' ', '(as of: ', date,')')
})
}
shinyApp(ui = ui, server = server)
Picture of the result: https://i.stack.imgur.com/gmhNM.jpg
Thank you in advance!
Something like this? Fore more examples visit another question i answered How to display widgets inline in shiny
library(shiny)
ui <- fluidRow(column(12, div(style="display: inline-block;",tags$h1(textOutput("chosen_date_fact"))),
actionButton("scoping2", label = icon("info-circle"), style = " color: #000000; background-color: #ffffff; border-color: #ffffff")
))
server = function(input, output){
last_fact_date = '2017-07-16'
output$chosen_date_fact = renderText ({
date = as.Date(last_fact_date)
paste0('Details of', ' ', format(date,"%B"),' ', '(as of: ', date,')')
})
}
shinyApp(ui = ui, server = server)
I am adding style tags based on the users input. Depending upon the radio button selected by the user the border colour of the selectInput changes. In the sample code below, I am setting the colour to red if user chooses the "Error" in radiobutton and I set it back to grey(default color) if user chooses "No Error".
The problem I am facing is that every time I renderUI with these tags the style tags keeps getting added to the html head. Ideally what I would like to do is that remove the style tag that I previously added. Is there a way to do that?
Following is the code that I am currently using:
library(shiny)
ui <- fluidPage(
uiOutput("Border_Arg"),
radioButtons("RBtn", "Choices", choices = c("Error", "No Error")),
selectInput("Select1", "Option1", choices = NULL)
)
server <- function(input, output){
output$Border_Arg <- renderUI({
if(input$RBtn == "Error"){
tagList(
tags$head(tags$style(HTML("#Select1 ~ .selectize-control.single .selectize-input {border: 1px solid red;}")))
)
}else if(input$RBtn == "No Error"){
#Here, instead of setting the style to default value I would like to remove the style that was previously added
tagList(
tags$head(tags$style(HTML("#Select1 ~ .selectize-control.single .selectize-input {border: 1px solid #cccccc;}")))
)
}
})
}
shinyApp(ui = ui, server = server)
What you need to do is have a CSS class that add the style you want, and then add and remove the class on the element.
We can use the shinyjs package to help with that:
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
inlineCSS(list(.error = "border: 2px solid red")),
uiOutput("Border_Arg"),
radioButtons("RBtn", "Choices", choices = c("Error", "No Error")),
selectInput("Select1", "Option1", choices = LETTERS[1:4])
)
server <- function(input, output){
output$Border_Arg <- renderUI({
if(input$RBtn == "Error"){
addCssClass(class = 'error', selector = '#Select1 ~ .selectize-control.single .selectize-input')
}else if(input$RBtn == "No Error"){
removeCssClass(class = 'error', selector = '#Select1 ~ .selectize-control.single .selectize-input')
}
})
}
shinyApp(ui = ui, server = server)