Shiny selectize-dropdown menu open in upward direction - html

In my shiny dashboard I have a couple of dropdown menus of type selectizeInput. They are located at the bottom of the page, so instead of opening the dropdown menus downward I would like to open them upward.
I did find a solution for the shinyWidgets dropdown menu called pickerInput. The solution here was to add a css tag:
.dropdown-menu{bottom: 100%; top: auto;}
However, this tag isn't working for selectizeInput. Any idea which css I have to add to my script?
Edit (answer by maartenzam with example)
library(shiny)
ui <- fluidPage(
# selectize style
tags$head(tags$style(type = "text/css", paste0(".selectize-dropdown {
bottom: 100% !important;
top:auto!important;
}}"))),
div(style='height:200px'),
selectizeInput('id', 'test', 1:10, selected = NULL, multiple = FALSE,
options = NULL)
)
server <- function(input, output, session) {
}
shinyApp(ui, server)

You can do somethink like
.selectize-dropdown {
top: -200px !important;
}

Thanks for this, very useful!
Leaving this here just in case someone is interested in changing the behaviour only for some selectizeInput's and leave the others default (just as I was):
library(shiny)
ui <- fluidPage(
tags$head(tags$style(HTML('#upwardId+ div>.selectize-dropdown{bottom: 100% !important; top:auto!important;}'))),
selectizeInput(inputId = 'downwardId', label='open downward', choices = 1:10, selected = NULL, multiple = FALSE),
div(HTML("<br><br><br><br><br>")),
selectizeInput(inputId = 'upwardId', label='open upward', choices = 1:10, selected = NULL, multiple = FALSE)
)
server <- function(input, output, session){}
shinyApp(ui, server)

You can process this in onDropdownOpen event.
$('select[multiple]').selectize({
onDropdownOpen: function($dropdown) {
$dropdown.css({
bottom: '100%',
top: ''
}).width(this.$control.outerWidth());
}
});
In my project I used data-dropdown-direction attribute to specify which element should dropdown in up direction.
In template:
<select multiple data-dropdown-direction="up"></select>
In script:
$('select[multiple]').selectize({
onDropdownOpen: function($dropdown) {
if (this.$input.data('dropdownDirection') === 'up') {
$dropdown.css({
bottom: '100%',
top: ''
}).width(this.$control.outerWidth());
}
}
});

It is possible to do this via Selectize options.
$('#selectize').selectize({
dropdownDirection: 'up',
plugins: [
'dropdown_direction'
],
});

Similar to #ismirsehregal, dropping a helpful variation on this using the new virtualSelectInput function from shinyWidgets:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
# modify virtual select css https://github.com/sa-si-dev/virtual-select/blob/master/dist/virtual-select.min.css
tags$head(tags$style(type = "text/css", paste0(".vscomp-dropbox {
position: absolute !important;
bottom: 100% !important;
top: auto !important;
}}"))),
div(style='height:200px'),
virtualSelectInput('id', 'test', 1:10, selected = NULL, multiple = TRUE,
options = NULL)
)
server <- function(input, output, session) {
}
shinyApp(ui, server)

Related

Set distance between widget and its title (text) in shiny

I have a simple shiny app which diplays three colourInput() buttons. I would to reduce the blank space between every button and its title in order to be closer to it.
#ui.r
library(shiny)
library(shinydashboard)
shinyUI( dashboardPage(
dashboardHeader(
title="Styling Download Button"
),
dashboardSidebar(
div(style="display: inline-block;vertical-align:top; width: 115px;",colourInput("rightcolor",h5("Left"), value = "#00B2EE")),
div(style="display: inline-block;vertical-align:top; width: 115px;",colourInput("overlapcolor",h5("Overlap"), value = "#7CCD7C")),
div(style="display: inline-block;vertical-align:top; width: 115px;",colourInput("leftcolor",h5("Right"), value = "#FFFACD")),
),
dashboardBody()
))
#server.r
shinyServer(function(input, output) {
})
You have to change the div elements in which the titles are displayed. One way to do this is by adding the style argument to the h5 function. If you reduce the margin to 0 pixels by adding style='margin: 0px' you get the result that you want (you can also use: margin-top, margin-bottom, etc.).
If you want to adapt other Shiny widgets you can always wrap them in a div and adapt them with the style argument (example: div(style='margin: 0px; padding: 15px;', selectInput(...))). Information on other div arguments can be found here.
Your example
library(shiny)
library(shinydashboard)
library(colourpicker)
# Create ui
ui <- shinyUI( dashboardPage(
dashboardHeader(
title="Styling Download Button"),
dashboardSidebar(
div(style="display: inline-block;vertical-align:top; width: 115px;",colourInput("rightcolor",h5("Left", style='margin: 0px;'), value = "#00B2EE")),
div(style="display: inline-block;vertical-align:top; width: 115px;",colourInput("overlapcolor",h5("Overlap", style='margin: 0px;'), value = "#7CCD7C")),
div(style="display: inline-block;vertical-align:top; width: 115px;",colourInput("leftcolor",h5("Right", style='margin: 0px;'), value = "#FFFACD"))),
dashboardBody()
))
# Create Server
server <- shinyServer(function(input, output) {})
# Run app
shinyApp(ui, server)

non-standard evaluation to update a format with updateInputSlider: bug?

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!

RenderImage from URL and clickable

I would like to figure out how to use renderImage in Shiny with online located images (URL), and make the image clickable, so that I can hang an observeEvent() to it. I can do both these things, but not together. My approach to render an URL doesn't work with clicking, and the local image version that allows clicking doesn't render URL images.
Here are the two half working versions:
I took some inspiration from here for the
Clickable
library(shiny)
ui <- fluidPage(
imageOutput("image1", click = "MyImage")
)
server <- function(input, output, session) {
setwd(Set the directory of the image in here) #### modify to test
output$image1 <- renderImage({
list(
src = "YOUR_IMAGE.png", #### modify to test
contentType = "image/png",
width = 90,
height = 78,
alt = "This is alternate text"
)}, deleteFile = FALSE)
observeEvent(input$MyImage, { print("Hey there")})
}
shinyApp(ui, server)
if I put an URL in (and remove the deleteFile = FALSE) it shows an empty square. still clickable though.
URLable by using renderUI()
library(shiny)
ui <- fluidPage(
uiOutput("image1", click = "MyImage")
)
server <- function(input, output, session) {
setwd(AppDir)
output$image1<- renderUI({
imgurl2 <- "https://www.rstudio.com/wp-content/uploads/2014/07/RStudio-Logo-Blue-Gradient.png"
tags$img(src=imgurl2, width = 200, height = 100)
})
observeEvent(input$MyImage, { print("Hey there")})
}
shinyApp(ui, server)
shows the image, but the image isn't clickable anymore.
If I change renderUI() and uiOuput() into renderImage() and imageOutput() in example 2, it throws a 'invalid file argument' error.
htmlOuput with renderText
I also tried this version that was in the other SO post, but again, not clickable. This approach is based on the answer on this link
library(shiny)
ui <- fluidPage(
htmlOutput("image1", click = "MyImage")
)
server <- function(input, output, session) {
setwd(AppDir)
imgurl2 <- "https://www.rstudio.com/wp-content/uploads/2014/07/RStudio-Logo-Blue-Gradient.png"
output$image1<- renderText({c('<img src="',imgurl2,'">')})
observeEvent(input$MyImage, { print("Hey there")})
}
shinyApp(ui, server)
I want to move away from local images because that seems to make more sense once we publish the Shiny App. So therefore really in need of a solution that allows rendering of URL images and have them being clickable. Bonus points if somebody can explain why the click = only works local files with imageOutput.
One alternative is to use the onclick function from shinyjs library. It allows you to include click events to specific html elements (targeted by id).
Here's the documentation
In your case the code would look like this:
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
uiOutput("image1", click = "MyImage")
)
server <- function(input, output, session) {
output$image1<- renderUI({
imgurl2 <- "https://www.rstudio.com/wp-content/uploads/2014/07/RStudio-Logo-Blue-Gradient.png"
div(id = "myImage",
tags$img(src = imgurl2, width = 200, height = 100)
)
})
onclick(
myImage,
{
# Do whatever you want!
print("Hey there")
}
)
}
shinyApp(ui, server)
What about transforming image from url into a ggplot as:
library(magick)
library(cowplot)
library(gtools)
library(shiny)
ui <- fluidPage(
uiOutput("myplotoutput"),
uiOutput("text")
)
server <- function(input, output, session) {
output$myplotoutput = renderUI( {
plotOutput("urlimage", click=clickOpts(id="myclick") )
} )
output$text=renderUI({
validate(
need(try(!invalid(input$myclick)), "Text will appear here")
)
textOutput("reactext")
})
output$reactext<-renderText(mytext$texto)
output$urlimage<- renderPlot({
g<- ggdraw() + draw_image("https://jeroen.github.io/images/frink.png")
g
})
mytext<-reactiveValues()
observeEvent(input$myclick, {
mytext$texto<-"Hey there"
})
}
shinyApp(ui, server)

shinydashboard header dropdown add group links

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.

CSS for each page in R Shiny

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)