R Shiny DT render text and input without linebreaks - html

I am trying to render any kind of R Shiny input in a Shiny DT, however I would like to avoid the linebreaking. If I concatenate some text and the html tags with the shinyInput function both the text and the inputs are rendered, but a linebreak happens before and after the input.
I think that the root cause for this is the div tag, but googling it seems that adding the style="display:inline;" css code should solve it, but it doesn't, it even breaks the width definition.
do you have any idea how to get the text before, the div, and the text after on the same cell?
below some code to play with.
library(DT)
ui <- basicPage(
h2("The mtcars data"),
DT::dataTableOutput("mytable")
)
server <- function(input, output) {
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
mtcarsx <- data.frame(mtcars, newvar=
paste0(
"tex before "
,shinyInput(checkboxInput,nrow(mtcars),"mychbx",label="",value=FALSE,width=NULL),
" text after"))
output$mytable = DT::renderDataTable({
DT::datatable(mtcarsx,
escape = FALSE,
selection = 'none',
rownames = FALSE,
extensions = 'RowGroup',
options = list(searching = FALSE,
ordering = FALSE,
rowGroup = list(dataSrc=c(1)),
columnDefs = list(list(visible=FALSE, targets=c(1)))
))
})
}
shinyApp(ui, server)

You are right, you need to change the divs that wrap the checkbox element to display:inline. You say that this doesn't solve it as it breaks the width definition. Perhaps I'm missing something? I do not see a change in the widths column.
tags$style("
#mytable tr td div.form-group {
display: inline;
}
#mytable tr td div.checkbox {
display: inline;
}
#mytable tr td div.checkbox label {
padding: 0;
}
#mytable tr td div.checkbox input {
position: relative;
margin: 0;
}")
If the text that goes before and after are constant, you could use the css pseudo classes after and before to add that content.

Related

Centering Rmarkdown knitrbootstrap Report

Found this package called knitrBootstrap Which is to allow for Bootstrap style web pages when reporting in Rmarkdown.
Note: I am using the klippy, kableExtra, and knitrBootstrap
My issue is that when rendered is does not center the whole report, it is stuck to one side. And also the Title of the Document doesn't get displayed? Any suggestions to give this HTML page a more "fuller" feel? Because I can insert straight HTML code in Rmarkdown I added the HTML tag
---
output:
knitrBootstrap::bootstrap_document:
title: "Test file"
theme: united
highlight: sunburst
---
```{r}
library(kableExtra)
library(klippy)
library(knitrBootstrap)
```
```{r echo=FALSE, include=TRUE, out.width="100%"}
mpg_list <- split(mtcars$mpg, mtcars$cyl)
disp_list <- split(mtcars$disp, mtcars$cyl)
inline_plot <- data.frame(cyl = c(4, 6, 8), mpg_box = "", mpg_hist = "",
mpg_line1 = "", mpg_line2 = "",
mpg_points1 = "", mpg_points2 = "", mpg_poly = "")
inline_plot %>%
kbl(booktabs = TRUE) %>%
kable_paper(full_width = FALSE) %>%
column_spec(2, image = spec_boxplot(mpg_list)) %>%
column_spec(3, image = spec_hist(mpg_list)) %>%
column_spec(4, image = spec_plot(mpg_list, same_lim = TRUE)) %>%
column_spec(5, image = spec_plot(mpg_list, same_lim = FALSE)) %>%
column_spec(6, image = spec_plot(mpg_list, type = "p")) %>%
column_spec(7, image = spec_plot(mpg_list, disp_list, type = "p")) %>%
column_spec(8, image = spec_plot(mpg_list, polymin = 5))
```
I can't seem to find a ton of literature on the format you're using. However, I did notice that it doesn't change size when the screen size changes. It is all just set to one final size. That being said, the table thinks it is centered. In reality, it is formatted to 'fit' the contents, but the table is set to fill a space so that that outer space is centered in the body, but the table is left-aligned in that available space. On top of all that, the body is set to a max-width of 36em. That's why it looks left-aligned.
Clear as mud, I know. Sigh.
I can help make it better, but a different output format may be a better option. Almost any method I tried to make the table bigger destroyed the plots' SVG (distorted them).
This worked, but I don't know if the juice is worth the squeeze.
Add these styles between chunks and keep your code the same.
<style>
body {
max-width: 100%; // 36 em isn't working for me
}
table{
width: 924px !important;
height: auto;
}
tr {
height: 4em;
width: 924px !important; // 28 + (7*128) (for the 8 columns)
}
td {
vertical-align: middle !important;
padding-bottom: 0px !important;
}
svg {
width: 110%;
height: auto; // keep the aspect ratio
}
thead > tr *:not(:first-child) {
width: 128px; // only set here, if set to all td, it blows the svg
}
</style>
If you have any questions, let me know.
This centers, without centering, by filling the available space.

How to add a x-scroll on a division of a shiny app?

The following code should add endless number of column and a scroll bar should appear at the bottom. But the scroll bar is not working here. Please help..
library(shiny)
ui <- fluidPage(
fluidRow(
actionButton("addCol","Add New Column"),
div(style="overflow-x: auto;",
uiOutput("myUI")
)
)
)
server <- function(input, output, session) {
alld <- reactiveValues()
alld$ui <- list()
observeEvent(input$addCol,{
alld$ui[[length(alld$ui)+1]] <- verbatimTextOutput("aaa", placeholder = T)
output$myUI <- renderUI({
fluidRow(lapply(alld$ui,function(x){column(4,x)}))
})})
}
shinyApp(ui, server)
You are using Bootstrap layout (fluidPage, fluidRow, column), and the whole idea behind this kind of layout is responsivity.
The page is considered 12 width, and elements exceeding that will wrap to new rows. This is the intended behaviour of Bootstrap.
One way of solving your problem is to use flexbox.
Solution: (Disclaimer: Only works on chrome and firefox)
I made two changes to your code:
Changed the column to div with a custom CSS class called custom-column.
column(4,x) to div(class = "custom-column", x)})
Added flex-nowrap class to fluidRow.
fluidRow(class="flex-nowrap", lapply(alld$ui,function(x){div(class = "custom-column", x)}))
With these changes the layout works as you intended on chrome and firefox, but it's not working on IE or the browser within RStudio.
Full code including the CSS classes flex-nowrap and custom-column:
library(shiny)
ui <- fluidPage(
fluidRow(
tags$head(tags$style("
.flex-nowrap {
display: inline-flex;
-webkit-flex-wrap: nowrap !important;
-ms-flex-wrap: nowrap !important;
flex-wrap: nowrap !important;
flex-direction: row;
}
.custom-column {
width: 200px;
margin: 0px 10px;
}
"
)),
actionButton("addCol","Add New Column"),
div(style="overflow-x: auto;",
uiOutput("myUI")
)
)
)
server <- function(input, output, session) {
alld <- reactiveValues()
alld$ui <- list()
observeEvent(input$addCol,{
alld$ui[[length(alld$ui)+1]] <- verbatimTextOutput("aaa", placeholder = T)
output$myUI <- renderUI({
fluidRow(class="flex-nowrap", lapply(alld$ui,function(x){div(class = "custom-column", x)}))
})})
}
shinyApp(ui, server)
Output:

Shiny selectize-dropdown menu open in upward direction

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)

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!

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)