I've written an R shiny application and am styling it before I complete it. I've written a small amount of HTML and want to change things such as the background colour using CSS.
After consulting online I found I needed to seperate my css using the class argument, however when I specify a class for each page, it brings back no CSS at all.
Below is a shortened version of my R shiny application. Any help would be greatly appreciated.
library(shiny)
setwd("C:\\Users\\FRSAWG\\Desktop\\Application\\Shiny")
user <- shinyUI(navbarPage("",
tabPanel("Home Page",
div(class="one",
div(tags$style("#one body{background-color:blue;color:white;font-family:Arial}"),
div(HTML("<h1><b><center>Home Page</center></b></h1>"))))),
tabPanel("Glossary",
div(class="two",
div(tags$style("#two body{background-color:red;color:white;font-family:Arial}"),
div(HTML("<h1><b><center>Glossary</center></b></h1>")))))
))
serv <- shinyServer(function(input, output) {})
shinyApp(user, serv)
For reference I've designated one and two the class names for each of the pages.
UPDATE: Using the package shinyjs by Dean Attali (link), I wrote a helper function that you can call from R to create and run a jQuery function to modify the CSS element of a given object (or selector, in general) based on input from R syntax. You can use this to modify the CSS for your <body> when the tab changes.
This solves the problem with my previous suggestion - now there's no need to toggle the class of the body, which was sometimes causing flickering when for a split second all of the style classes for <body> were toggled off.
Here's the working example:
library(shiny)
library(shinyjs)
## Modify the CSS style of a given selector
modifyStyle <- function(selector, ...) {
values <- as.list(substitute(list(...)))[-1L]
parameters <- names(values)
args <- Map(function(p, v) paste0("'", p,"': '", v,"'"), parameters, values)
jsc <- paste0("$('",selector,"').css({", paste(args, collapse = ", "),"});")
shinyjs::runjs(code = jsc)
}
# UI for the app
user <- shinyUI(
navbarPage(title = "", id = "navtab",
header = div(useShinyjs()),
tabPanel("Home Page",
div(HTML("<h1><b><center>Home Page</center></b></h1>")),
"More text."
),
tabPanel("Glossary",
div(HTML("<h1><b><center>Glossary</center></b></h1>")),
"More text."
)
)
)
# Server for the app
serv <- shinyServer(function(input, output, session) {
observeEvent(input$navtab, {
currentTab <- input$navtab # Name of the current tab
if (currentTab == "Home Page") {
modifyStyle("body", background = "blue", color = "white", 'font-family' = "Arial")
}
if (currentTab == "Glossary") {
modifyStyle("body", background = "red", color = "white", 'font-family' = "Arial")
}
})
})
shinyApp(user, serv)
I'm new to CSS myself, but it seems your problem can be fixed by just altering the CSS tags slightly. Changing the #one to .one and removing the body preceding the brackets will make the CSS style get applied to the divs of class one.
Using the selector #one would be changing the CSS style of a div whose id, not class, is one. Here's a link to a guide on w3shools.com explaining the use of different selectors in CSS syntax.
Some other notes:
You could also use a tags$head to organize your style tags in
one place, instead of spreading them around the code. (This is down to personal preference, though.)
You can pass a class argument to tabPanel to set its CSS class - this removes the need for the inner div to set the class.
Modified example code:
library(shiny)
user <- shinyUI(navbarPage(
tags$head(
tags$style(HTML(".one {background-color: blue; color: white; font-family: Arial}")),
tags$style(HTML(".two {background-color: red; color: white; font-family: Arial}"))
),
tabPanel("Home Page", class = "one",
div(HTML("<h1><b><center>Home Page</center></b></h1>")),
"More text."
),
tabPanel("Glossary", class = "two",
div(HTML("<h1><b><center>Glossary</center></b></h1>")),
"More text."
)
))
serv <- shinyServer(function(input, output) {})
shinyApp(user, serv)
Like I mentioned, I'm new to CSS, so I'm not 100% sure if this is the output you are looking for, though.
EDIT2: Here's a solution using the package shinyjs to update the class of the <body> when the selected tab changes. (Note that in order to use the functions from shinyjs, you need to include useShinyjs() in your ui.)
The idea is to make navbarPage return the name of the tab that's currently active in input$navtab by setting its id to navtab. Then we can use the toggleClass function from the package shinyjs to change the class of the <body> dynamically, and thus have the appropriate CSS styling applied.
It's not perfect, since the class change only happens after the server gets notified that the tab has changed, which sometimes causes the background to flash before changing. It can get a bit annoying. I suspect a better solution would be to use javascript to change the <body> class when clicking the link to change the tab, but I couldn't figure out how to do that with Shiny.
Here's the code:
library(shiny)
library(shinyjs)
user <- shinyUI(
navbarPage(title = "", id = "navtab",
header = tags$head(
useShinyjs(),
tags$style(HTML(".one {background: blue; color: white; font-family: Arial}")),
tags$style(HTML(".two {background: red; color: white; font-family: Arial}"))
),
tabPanel("Home Page",
div(HTML("<h1><b><center>Home Page</center></b></h1>")),
"More text."
),
tabPanel("Glossary",
div(HTML("<h1><b><center>Glossary</center></b></h1>")),
"More text."
)
)
)
serv <- shinyServer(function(input, output, session) {
observeEvent(input$navtab, {
shinyjs::toggleClass(selector = "body", class = "one",
condition = (input$navtab == "Home Page"))
shinyjs::toggleClass(selector = "body", class = "two",
condition = (input$navtab == "Glossary"))
})
})
shinyApp(user, serv)
Related
My question is in regards to
Shiny: Add Popover to Column Name in Datatable, the package spsComps for using tooltips, when I remove the tooltip which is defined in the mainPanel, the tooltip on the datatable column also does not work anymore.
library(shiny)
library(spsComps)
library(DT)
library(dplyr)
# define the question button in a button since we need to uses multiple times
infoBtn <- function(id) {
actionButton(id,
label = "",
icon = icon("question"),
style = "info",
size = "extra-small",
class='btn action-button btn-info btn-xs shiny-bound-input'
)
}
ui <- fluidPage(
titlePanel('Making a Popover Work in DataTable'),
mainPanel(
fluidRow(dataTableOutput('myTable'))
)
)
server <- function(input, output, session) {
output$myTable <- DT::renderDataTable({
# construct the title and convert to text
hp_text <- tags$span(
"hp",
infoBtn('notWorking') %>%
bsPopover(title = "This one does not work",
content = "I'd like to give information about hp: it means horsepower. I want a popover, because my real example has lot's of text.",
placement = "top",
trigger = "hover")
) %>%
as.character()
# use !! and := to inject variable as text
datatable(mtcars %>% rename(!!hp_text:=hp),
rownames=TRUE,
selection='none',
escape=FALSE)
})
}
shinyApp(ui = ui, server = server)
However, when once a tooltip is displayed once in the UI, then it also works for the datatable (from #lz100)
library(shiny)
library(spsComps)
library(DT)
library(dplyr)
# define the question button in a button since we need to uses multiple times
infoBtn <- function(id) {
actionButton(id,
label = "",
icon = icon("question"),
style = "info",
size = "extra-small",
class='btn action-button btn-info btn-xs shiny-bound-input'
)
}
ui <- fluidPage(
titlePanel('Making a Popover Work in DataTable'),
mainPanel(
fluidRow(
#popover button
infoBtn('workingPop') %>%
bsPopover(title = "This Popover Works",
content = "It works very well",
placement = "right",
trigger = "hover"
)
),
fluidRow(dataTableOutput('myTable'))
)
)
server <- function(input, output, session) {
output$myTable <- DT::renderDataTable({
# construct the title and convert to text
hp_text <- tags$span(
"hp",
infoBtn('notWorking') %>%
bsPopover(title = "This one does not work",
content = "I'd like to give information about hp: it means horsepower. I want a popover, because my real example has lot's of text.",
placement = "top",
trigger = "hover")
) %>%
as.character()
# use !! and := to inject variable as text
datatable(mtcars %>% rename(!!hp_text:=hp),
rownames=TRUE,
selection='none',
escape=FALSE)
})
}
shinyApp(ui = ui, server = server)
Is this a bug? Or is there something I am missing?
Change this on your UI:
mainPanel(
fluidRow(dataTableOutput('myTable')),
spsDepend("pop-tip")
)
So here, we add spsDepend("pop-tip"). This means loading the dependent Javascript library when app starts. In therory, -v-, the dependency would be automatically added, users do not need to know this. However, in this case, you are using the renderDataTable function. This package does not know how to handle htmltools::htmlDependency, which is the mechanism how usually developers add JS dependencies for shiny apps.
In your case, if you only use it once in the renderDataTable, we need to manually add the dependency in UI by spsDepend. But like your second case, if it has been used at least once in the UI, the dependency is there, you don't need to worry.
You can see the question mark for the button is not working either. The same problem. renderDataTable does not know how to add the dependency for actionButton. So in general, I wouldn't call it a bug, but a feature DT package doesn't support yet.
For the question mark, even if is not a problem caused by spsComps, but we do have a solution from spsComps, adding the icon library:
mainPanel(
fluidRow(dataTableOutput('myTable')),
spsDepend("pop-tip"),
spsDepend("font-awesome")
)
I have a shiny application that has a functionnality to translate its text between several languages, by using some RenderText and an ActionButton to toggle between languages.
Here is my app:
library(shiny)
trads = list(text3=list("text3 in language 1", "text in other language"),
titl3=list("widget label in language 1", "widget label in other language"))
ui <- fluidPage(
actionButton("language",label="language", icon=icon("flag")),
htmlOutput("text3", container = tags$h3),
sliderInput("slider1", label=h2("slider1"), 0, 10, 5)
)
server <- function(input, output, session) {
tr <- function(text){sapply(text, function(s) trads[[s]][[input$language%%2+1]], USE.NAMES=FALSE)}
output$text3 = renderText({tr("text3")})
observeEvent(input$language, {
updateSliderInput(session, "slider1", label=tr("titl3"))
})
}
shinyApp(ui, server)
It works fine except that my slider label was formatted initially with a html tag h3(), and when I use updatesliderinput I loose this tag and it returns to plain text. I tried adding the tag in the translation with paste0, or different syntax with eval but it prints in text the result of the paste instead of running it or gives an error.
Any ideas to translate while keepping the format? Thanks
Note: I have the same problem with one text containing a URL link..
it really seams you have found a bug in updateSliderInput here. It can only handle pure strings and no HTML tags. As a work around would I recommend you to add something like this to the beginning of your UI
tags$head(
tags$style(
'label[for = "slider1"] {
color: red;
font-size: 20px;
}'
)
)
but change the css to what ever you like (maybe copy the css rules for the h2 tag) and then always only pass a string to the label parameter. This way the styling always stays the same.
my complete code
library(shiny)
trads = list(text3=list("text3 in language 1", "text in other language"),
titl3=list("widget label in language 1", "widget label in other language"))
ui <- fluidPage(
tags$head(
tags$style(
'label[for = "slider1"] {
color: red;
font-size: 20px;
}'
)
),
actionButton("language",label="language", icon=icon("flag")),
htmlOutput("text3", container = tags$h3),
sliderInput("slider1", label="slider1", 0, 10, 5)
)
server <- function(input, output, session) {
tr <- function(text){sapply(text, function(s) trads[[s]][[input$language%%2+1]], USE.NAMES=FALSE)}
output$text3 = renderText({tr("text3")})
observeEvent(input$language, {
updateSliderInput(session, "slider1", label=tr("titl3"))
})
}
shinyApp(ui, server)
hope this helps!
I want to put multiple links within a dropdown menu in the header panel, but now I can only create it with a flat horizonal layout through tags$li, while I want a vertical grouped dropdown menu.
A minimal repeatable code is as below, I means I want to put the linkA and linkB under grouplinkAB, and users can open one of them in a new window. It may be achieved with dropdownMenu(type='notifications',...) as in the code, but I do not know where to put the group name of "grouplinkAB", and which can not open a new window when clicking on the link, also I have to hide the text "You have 2 notifications", so I want to achieve it with tags$li and tags$ul, but I have little knowledge on HTML, any help will be appreciated.
library(shinydashboard)
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
dashboardPage(
dashboardHeader(title='Reporting Dashboard',
tags$li(class="dropdown",tags$a("grouplinkAB",href="http://stackoverflow.com/", target="_blank")),
tags$li(class="dropdown",tags$a("linkA",href="http://stackoverflow.com/", target="_blank")),
tags$li(class="dropdown",tags$a("linkB",href="http://stackoverflow.com/", target="_blank")),
dropdownMenu(type='notifications',
notificationItem(text='linkA',href="http://stackoverflow.com/"),
notificationItem(text='linkB',href="http://stackoverflow.com/")
)
),
dashboardSidebar(),
dashboardBody()
)
),
server = function(input, output){}
), launch.browser = TRUE
)
Ok, I saw a similar request about a year ago, but didn't look much deeper. This time I tried to get your code to work and couldn't then I looked at the dropdownMenu code and saw it simply wasn't setup to handle this, but could be modified to do so fairly easily.
I choose not to do that though, instead I created a new version of dropdownMenu specialized to do just this.
Here is the code:
library(shinydashboard)
dropdownHack <- function (...,badgeStatus = NULL, .list = NULL,menuname=NULL)
{
if (!is.null(badgeStatus)){
shinydashboard:::validateStatus(badgeStatus)
}
items <- c(list(...), .list)
lapply(items, shinydashboard:::tagAssert, type = "li")
dropdownClass <- paste0("dropdown ", "text-menu")
numItems <- length(items)
if (is.null(badgeStatus)) {
badge <- NULL
}
else {
badge <- span(class = paste0("label label-", badgeStatus), numItems)
}
tags$li(class = dropdownClass, a( href="#", class="dropdown-toggle",
`data-toggle`="dropdown", menuname, badge),
tags$ul(class = "dropdown-menu", items )
)
}
menuitemHack <- function(text,href){
notificationItem(text=text,href=href,icon=shiny::icon("rocket") )
}
runApp(
shinyApp(
ui = shinyUI(
dashboardPage(
dashboardHeader(title='Reporting Dashboard',
dropdownHack(menuname="GroupAB",
menuitemHack(text='linkA',href="http://stackoverflow.com/"),
menuitemHack(text='linkB',href="http://stackoverflow.com/")
),
dropdownMenu(type='notifications',
notificationItem(text='linkA',href="http://stackoverflow.com/"),
notificationItem(text='linkB',href="http://stackoverflow.com/")
)
),
dashboardSidebar(),
dashboardBody()
)
),
server = function(input, output){}
), launch.browser = TRUE
)
And here is the result:
Notes:
It needs an icon, you can select any fontAwesome or Glyphicons, there is probably a blank one there somewhere if you want to have nothing.
I imagine it will break if the ShinyDashboard structure changes much, so keep that in mind.
Maybe the next version will support this option as well, it would just be a few lines of extra code.
I was suggested using insertUI here and found that it is a great feature. The following code allows to generate control widgets for a single or multiple elements using insertUI, but struck on incorporating removeUI related part. Tried jQuery options to remove inserted UI elements but did not work out. I found the following from Shiny dynamic UI, i.e., Note that, if you are inserting multiple elements in one call, you must wrap them in either a tagList() or a tags$div() (the latter option has the advantage that you can give it an id to make it easier to reference or remove it later on). Also, comments here gave some clues, i.e., tags$div(id="sepal.width.div", sliderInput("sepal.width.slider", ...)), but my lack of HTML/CSS knowledge stops me going forward. I'm looking at (a) wrapping multiple widget element(s) with tags$div() assigning a unique id for each variable, which will be used in removeUI; (b) calling multiple elements via removeUI.
varnames <- names(iris[,1:4]) # names
varinit <- apply(iris[,1:4],2,median) # initival value used in slider
varmin <- apply(iris[,1:4],2,min) # min.
varmax <- apply(iris[,1:4],2,max) # max.
ListofSelVars <<- vector(mode="character")
# control widgets for all elements
allControls <- lapply(setNames(varnames, varnames), function(x) {
sliderInput(x, x, varmin[x], varmax[x], c(varmin[x], varinit[x]),
round = -2)
})
ui <- navbarPage(
tabPanel("Plot",
sidebarLayout(
sidebarPanel(
checkboxGroupInput("ConditioningVariables", "Conditioning variables (choose one or more):",
varnames,inline = TRUE),
# add an action button
actionButton("add", "Update UI elements")
),
mainPanel()
)
)
)
server <- function(input, output, session) {
observeEvent(input$add, {
insertUI(
selector ='#add',
where = "afterEnd",
ui = allControls[setdiff(input$ConditioningVariables,ListofSelVars)]
)
## removeUI related goes, here
## removeUI(selector=paste0())
## setdiff(ListofSelVars,input$ConditioningVariables) gives elements to be removed
## Global variable, keep track of elements that are selected
ListofSelVars <<- input$ConditioningVariables
})
}
shinyApp(ui, server)
Here is the working code. The main issue is with the names here, i.e. Sepal.Width. I wrapped each slider with a div with id like div.Sepal.Width so that it is easier to remove. removeUI requires a jQuery selector, so it appears that something like #div.Sepal.Width would work, except that it does not, because . is itself a jQuery selector that means class, so we need to double escape the .. Of course you can also remove the . when you first create the divs, thus avoiding the trouble...
varnames <- names(iris[,1:4]) # names
varinit <- apply(iris[,1:4],2,median) # initival value used in slider
varmin <- apply(iris[,1:4],2,min) # min.
varmax <- apply(iris[,1:4],2,max) # max.
ListofSelVars <<- vector(mode="character")
# control widgets for all elements
allControls <- lapply(setNames(varnames, varnames), function(x) {
tags$div(id=paste0("div.",x), sliderInput(x, x, varmin[x], varmax[x], c(varmin[x], varinit[x]),
round = -2))
})
ui <- fluidPage(
titlePanel("Dynamic sliders"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("ConditioningVariables", "Conditioning variables (choose one or more):",
varnames,inline = TRUE),
# add an action button
actionButton("add", "Update UI elements")
),
mainPanel(
uiOutput("plot_out")
)
)
)
server <- function(input, output, session) {
observeEvent(input$add, {
insertUI(
selector ='#add',
where = "afterEnd",
ui = allControls[setdiff(input$ConditioningVariables,ListofSelVars)]
)
ListofRemoval <- setdiff(ListofSelVars,input$ConditioningVariables)
for (item in ListofRemoval) {
item = gsub(".", "\\.", item, fixed=TRUE)
item = paste0("#div\\.", item)
removeUI(item)
}
ListofSelVars <<- input$ConditioningVariables
})
}
shinyApp(ui, server)
I'm trying to style a table in a Shiny app using the tableHTML package in R.
When I use the tableHTML() function in R it produces exactly what I want. I use the add_css_column to align the text in the column to the centre. However when I use it in a Shiny app the headers end up left aligned and the rows centre aligned. Any ideas how I can fix this?
output$viewers_website_top <- renderUI({
tableHTML(website_index, rownames = FALSE, widths=c(200,200)) %>%
add_css_column(css = list("text-align", "center"),
column_names = names(website_index))
})
This is a common issue with bootstrap 3 unfortunately. Whenever you use shiny it loads up a bootstrap 3 css (immediately) which makes it difficult to overwrite.
As for the solution to this using add_css_header would probably solve this one. add_css_header would change the th tag of the HTML table to the one you like (whereas add_css_header would change the td tags below the headers):
output$viewers_website_top <- renderUI({
tableHTML(website_index, rownames = FALSE, widths=c(200,200)) %>%
add_css_header(css = list("text-align", "center"),
headers = 1:ncol(website_index))
})
Another thing you can do is to add a separate css file with shiny::includeCSS. There is more info here and here on how to use includeCSS.
In the css file you need to write:
.table_website_index th {
text-align: center;
}
And that should do it!
P.S. table_website_index is the class the package assigns to the table which you can also change with the class argument.
P.S.2 I am the developer - thanks for using the package :)