A dynamically resizing shiny textAreaInput box? - r

I am trying to make a textAreaInput box in shiny that spans 100% of my webpage and resizes when the browser is min/maximised. I can make a simple textInput with this behavior by supplying the argument width = 100%. Supplying the same argument to textAreaInput does not produce the same behavior even though width has the same description on the textInput and textAreaInput man pages. Is this desired behavour or a bug?
A minimal working example -
library(shiny)
shinyApp(
#UI
ui = fluidPage(
fluidRow(
column(12,
textAreaInput("big_box", "Big box", value = "", width = '100%', rows = 5, resize = "both")
)
),
fluidRow(
column(12,
textInput("long_box", "Long box", value = "", width = '100%')
)
)
),
#Server
server = function(input, output) {
}
)
Example output -
Cheers

A simpler workaround is to set the height and width parameters to the parent element, using shiny::tagAppendAttributes function.
For example:
textAreaInput("big_box", "Big box", value = "", rows = 5, resize = "both") %>%
shiny::tagAppendAttributes(style = 'width: 100%;')

Or you could just override the css by using a header tag within your ui function e.g:
tags$style(HTML("
.shiny-input-container:not(.shiny-input-container-inline) {
width: 100%;
}"))

textAreaInput was recently added to Shiny in version 14, it seems that it is a bug cause by the class shiny-input-container. In shiny.css we can find:
/* Limit the width of inputs in the general case. */
.shiny-input-container:not(.shiny-input-container-inline) {
width: 300px;
max-width: 100%;
}
The simplest workaround is to create a new function based on the original without the class shiny-input-container. Below is the new function.
library(shiny)
#based on Shiny textAreaInput
textAreaInput2 <- function (inputId, label, value = "", width = NULL, height = NULL,
cols = NULL, rows = NULL, placeholder = NULL, resize = NULL)
{
value <- restoreInput(id = inputId, default = value)
if (!is.null(resize)) {
resize <- match.arg(resize, c("both", "none", "vertical",
"horizontal"))
}
style <- paste("max-width: 100%;", if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"), if (!is.null(height))
paste0("height: ", validateCssUnit(height), ";"), if (!is.null(resize))
paste0("resize: ", resize, ";"))
if (length(style) == 0)
style <- NULL
div(class = "form-group",
tags$label(label, `for` = inputId), tags$textarea(id = inputId,
class = "form-control", placeholder = placeholder, style = style,
rows = rows, cols = cols, value))
}
shinyApp(
#UI
ui = fluidPage(
fluidRow(
column(12,
textAreaInput2("big_box2", "Big box", value = "", width = '100%', rows = 5, resize = "both")
)
),
fluidRow(
column(12,
textInput("long_box", "Long box", value = "", width = '100%')
)
)
),
#Server
server = function(input, output) {
}
)

Related

thumbnail_label overlays other items with large content R Shiny

I am trying to create a shiny app which displays thumbnail-labels, each thumbnail-label item contains an image, label, button, and content (which are all text inputs).
The problem is when text in content exceeds text size in other thumbnails, this thumbnail enlarges and overlays the place for other thumbnails, distorting the whole page.
Is there a way I can fix each the thumbnail size regardless the content size? for example, by setting the extra text to hidden when exceeding a certain character limit and making it only available on hover? Other approaches are also welcome.
As you can see in the solution below, I've tried adding a limit to the content size in tags$style but it didn't work. Also, I tried adding a vertical layout but it doesn't solve the problem it only limits it to this vertical layout instead of overlaying other thumbnails but still the page looks distorted.
library(shiny)
library(shinyBS)
library(shinyLP)
library(shiny)
library(shinyWidgets)
library(magrittr)
library(googlesheets4)
library(png)
library(DT)
library(bslib)
# Define UI for application that draws a histogram
ui <- fluidPage(
tags$style("content { font-size:80%; font-family:Times New Roman; margin-bottom:
20px; length: 500}"),
div(style="padding: 1px 0px; width: '100%'",
titlePanel(
title="", windowTitle="Data Portal"
)
),
navbarPage(title=div(img(src="Rlogo.png", width = 35), "Data Portal"),
inverse = F,
collapsible = T,
tabPanel("Welcome Page", icon = icon("home"),
jumbotron("Welcome to Our Portal!",
"Welcome to our portal.",
buttonLabel = "Start your tour"),
),
tabPanel("Our Team", icon = icon("users"),
jumbotron("Meet Our Team!", "Meet our team.",
button = FALSE),
hr(),
fluidRow(
verticalLayout(fluid = FALSE,
fluidRow(column(4, thumbnail_label(image = 'user.png', label = 'Name 1',
content = HTML('This is meeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee'),
button_link = 'http://getbootstrap.com/', button_label = 'See profile')),
column(4, thumbnail_label(image = 'user.png', label = 'Name 2',
content = HTML('This is me'),
button_link = 'http://getbootstrap.com/', button_label = 'See Profile')),
column(4, thumbnail_label(image = 'user.png', label = 'Name 3',
content = HTML('This is me'),
button_link = 'http://getbootstrap.com/', button_label = 'See Profile'))
)),
verticalLayout(fluid = FALSE,
fluidRow(column(4, thumbnail_label(image = 'user.png', label = 'Name 3',
content = 'background ',
button_link = 'http://getbootstrap.com/', button_label = 'See Profile')),
column(4, thumbnail_label(image = 'user.png', label = 'Name 3',
content = 'background ',
button_link = 'http://getbootstrap.com/', button_label = 'See Profile')),
column(4, thumbnail_label(image = 'user.png', label = 'Name 3',
content = 'background ',
button_link = 'http://getbootstrap.com/', button_label = 'See Profile')),
)),
))
)
) # end of fluid page
# Define server logic required to draw a histogram
server <- function(input, output) {
}
# Run the application
shinyApp(ui = ui, server = server)
Found a way of doing it> I created my own thumbnail function and added attributes to the content part of it using tagAppendAttributes and putting the needed attributes as (style) argument. Also here I used render UI to input the image as I needed to get images as urls from a googlesheet, i.e images not in www directory. Otherwise you can just use the img(src=image) as usual.
my_thumbnail_label <- function(image_url, label, content, button_link, button_label, height = 100, sec_label = NULL ){
tags$style(HTML('
.one-long-line {
width: 300px;
height: 100px;
white-space:nowrap;
overflow:hidden;
text-overflow:ellipsis;
}
.one-long-line:hover {
overflow:visible;
}'))
# take image url and render an image ui
image_ui <- renderUI({
tags$img(src = image_url,
align = "center", style = "width: 100%; height: 100%;")
})
# create the div to be displayed
div(class = "row",
div(class = "col-sm-14 col-md-12",
div(class = "thumbnail",style = "height: '200px';",
image_ui,
div(class = "caption", h3(label)%>%
tagAppendAttributes(style= 'width: "100%" ;height: 30px;overflow: hidden;text-overflow: ellipsis;'), h4(sec_label),
#div(class = "one-long-line", content),
p(content)%>%
tagAppendAttributes(style= paste0('width: "100%" ;overflow: hidden;text-overflow: ellipsis;height:',height, 'px;')),
p(a(href = button_link, class = 'btn btn-primary', role = 'button', button_label))))))
}

How I can center the header columns on reactable (r-package)?

Hi and thanks for reading me
I am working on some tables with the "reactable" package in r, but I would like to center only the headings of each column. For example:
library(reactable)
reactable(iris,
defaultColDef = colDef(
header = function(value) gsub(".", " ", value, fixed = TRUE),
cell = function(value) format(value, nsmall = 1),
align = "center",
minWidth = 70,
headerStyle = list(background = "#12a09a")
))
Apparently the option colDef(align = "center") centers the entire column, but is there an option to only center the title?
i assume that you are using this tables in an R markdown document or a shiny app. In both you can override the css in order to left align the table text or let the default table and center the title.
In the first case you just need to add this line .rt-align-center{text-align: left;}.
In shiny you just need to add that to your custom css or use the style tag to add it inline like the example below:
library(shiny)
library(reactable)
ui <- fluidPage(
# inline style tag to define table row text alignment
tags$style(HTML(".rt-align-center {text-align: left;}")),
titlePanel("Iris react table"),
sidebarLayout(
sidebarPanel(
helpText("Nothing to see here")
),
mainPanel(
reactableOutput("table")
)
)
)
server <- function(input, output) {
output$table <- renderReactable({
reactable(iris,
defaultColDef = colDef(
header = function(value) gsub(".", " ", value, fixed = TRUE),
cell = function(value) format(value, nsmall = 1),
align = "center",
minWidth = 70,
headerStyle = list(background = "#12a09a")
))
})
}
shinyApp(ui = ui, server = server)
If you are working with an Rmarkdown document just add it to the html in the style tag like this:
<style> .rt-align-center {text-align: left;} </style>
and the result:

R Shiny Sortable CSS: Apply different class to labels within the same bucket_list

I am trying to maintain the colour of a given label (e.g "Blue" = blue colour; "Green" = green colour) regardless of the bucekt_list in which it resides. However, I have only been able to modify the CSS for a given bucket_list rather than to individual labels themselves. Therefore, the labels do not maintain their respective colours when dragged into a different bucket_list currently.
library(shiny)
library(sortable)
ui <- fluidPage(
tags$style( HTML(".green-sortable .rank-list-item {
background-color: #53C1BE;
}"),
HTML(".blue-sortable .rank-list-item {
background-color: #4080C9;
}")),
fluidRow(column(6, uiOutput("example1")),
column(6, uiOutput("example2")))
)
server <- function(input, output, session) {
output$example1 <- renderUI({
bucket_list(
header = NULL,
group_name = "colours",
orientation = "horizontal",
class = c("default-sortable", "green-sortable"),
add_rank_list(
text = " ",
input_id = "green",
labels = "Green"
))
})
output$example2 <- renderUI({
bucket_list(
header = NULL,
group_name = "colours",
orientation = "horizontal",
class = c("default-sortable", "blue-sortable"),
add_rank_list(
text = " ",
input_id = "blue",
labels = "Blue"
))
})
}
shinyApp(ui, server)
How could this be modified to as to have the blue and green labels remain blue and green in colour, respectively, regardless of the bucket_list into which they have been dragged?
You need to define the element via a html tag (wrapped in a list) rather than a pure character. In the latter case, sortable will style the elemnt for you and you would need to go through some JS pain, to re-style it. Hence, it is easier to control the element yourself.
However, since your element is still placed in an outer <div> with some styling (most notably a padding) you need some extra css to get to a similiar look and feel.
library(shiny)
library(sortable)
ui <- fluidPage(
tags$style( HTML("#green {
background-color: #53C1BE;
}
.default-sortable .rank-list-container .rank-list-item {
padding: 0;
}
.rank-list-item > div {
line-height:42px;
}
#blue {
background-color: #4080C9;
}")),
fluidRow(column(6, uiOutput("example1")),
column(6, uiOutput("example2")))
)
server <- function(input, output, session) {
output$example1 <- renderUI({
bucket_list(
header = NULL,
group_name = "colours",
orientation = "horizontal",
class = c("default-sortable", "green-sortable"),
add_rank_list(
text = " ",
input_id = "green",
labels = list(div("Green", id = "green")) ## define your element yourself
))
})
output$example2 <- renderUI({
bucket_list(
header = NULL,
group_name = "colours",
orientation = "horizontal",
class = c("default-sortable", "blue-sortable"),
add_rank_list(
text = " ",
input_id = "blue",
labels = list(div("Blue", id = "blue")) ## define your element yourself
))
})
}
shinyApp(ui, server)

Changing base layers in Leaflet for R without loosing the overlay

I am trying to change the base layer in my Shiny App in a programatic way.
Since I don't want to use the LayerControl of 'Leaflet' and rather want to have all the controls in one panel. I decided to use shinyjs and go with the toggleState for a button to switch forth and back between two base layers.
At the moment I am in the phase to figure out the principles of changing the base layer, and since there can be only one base layer visible it seem like I have to remove the tiles of the initially loaded base layer.
Doing so I can change the base layer at display, but at the same time the base layer is changed I am loosing the overlay. How can I avoid that?
When using the button again I can see in the flicker that the overlay is still there, but not on top of the base layer anymore.
Here an example:
library(shiny)
library(leaflet)
library(shinydashboard)
# Definition of Sidebar elements
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Maps", tabName = "maps", icon = icon("globe"),
menuSubItem(
HTML(paste("Diffuse kilder NH", tags$sub("3"), sep = "")),
tabName = "map_dif_nh3", icon = icon("map-o"), selected = TRUE
)
)
)
)
# Definition of body elements
body <- dashboardBody(
tabItems(
tabItem(tabName = "map_dif_nh3",
box(
width = 12,
div(style = "height: calc(100vh - 80px);",
leafletOutput(
"m_dif_nh3", width = "100%", height = "100%"
),
absolutePanel(id = "nh3_panel", class = "panel panel-default",
fixed = TRUE, style = "opacity: 0.87",
top = 80, left = "auto", right = 50, bottom = "auto",
width = 285, height = "auto",
fluidRow(
column(width = 10, offset = 1,
actionButton(inputId = 'btn_bgr_nh3', label = "", icon = icon("globe", class = "fa-lg"))
)
)
)
)
)
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Mixed layout"),
sidebar,
body
)
server <- function(input, output) {
init_lat <- 56.085935208960585
init_lon <- 10.29481415546154
init_zoom <- 7
output$m_dif_nh3 <- renderLeaflet({
leaflet(height = "100%") %>%
addProviderTiles("Stamen.Toner", layerId = 'mb_osm', group = "base") %>%
setView(init_lon, init_lat, init_zoom) %>%
addWMSTiles(
"http://gis.au.dk/geoserver_test/PRTR/gwc/service/wms",
layers = "PRTR:prtr_nh3_2014",
layerId = "nh3_2014",
group = "overlay",
options = WMSTileOptions(format = "image/png",
transparent = TRUE, opacity = 0.8
)
)
})
observeEvent(
input$btn_bgr_nh3, {
leafletProxy("m_dif_nh3") %>%
addProviderTiles("Esri.WorldImagery", layerId = 'mb_pic', group = 'base')
leafletProxy("m_dif_nh3") %>%
removeTiles(layerId = 'mb_osm')
}
)
}
shinyApp(ui, server)
I think what you can do is reset the value of ID the action button to 0 after clicking the button. Therefore, every time you toggle the ID value will be replaced by 0. It worked for me. Hope it work for you as well.
In Leaflet JS (I don't know about R), if myTileLayer is already part of your base layers, then myTileLayer.addTo(map) does the switching job. It doesn't add on top; and you don't need to remove the current layer. The overlay remains unaffected.
Ref: https://stackoverflow.com/a/33762133/4355695

Navbar/Tabset with reactive Panel number but NOT rendering everything

This question might seem to be a duplicate, but let me explain why it's not.
I want to create a shiny navbarPage that has fixed elements and a reactive number of tabPanels, that reacts to other input elements. There are many questions about how to create reactive tabsetPanels/navbarPages but they mostly aim for what it has to look like. The most common answer (and the answer i don't seek) is to render the whole navbarPage with updated set of tabPanels. I am aware of that concept and I used it in the code below.
Here is what I want my app to look like:
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
uiOutput("navPage")
)
),
server = function(input, output, session){
MemoryValue1 <- 1
MemoryValue2 <- 1
makeReactiveBinding("MemoryValue1")
observeEvent(input$button, {
output[[paste0("plot_", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
observeEvent(input$insidepanels, {
MemoryValue1 <<- input$insidepanels
})
observeEvent(input$number, {
MemoryValue2 <<- input$number
})
output$navPage <- renderUI({
OutsidePanel1 <- tabPanel("Outside1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = isolate(MemoryValue1), step = 1, min = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 1, step = isolate(MemoryValue2), min = 1),
actionButton("button", label = "Add Output-Element")
)
OutsidePanel2 <- tabPanel("Ouside2", "Outside 2")
InsidePanels <- lapply(1:MemoryValue1, function(x){tabPanel(paste0("Inside", x), plotOutput(paste0("plot_", x)))})
do.call(navbarPage, list("Nav", OutsidePanel1, OutsidePanel2, do.call(navbarMenu, c("Menu", InsidePanels))))
})
}
)
)
As you might have seen, it takes a lot of effort to store your input values if they are inside other panels and will be re-rendered = reset all the time. I find this solution to be illegible and slow, because of unnecessary rendering. It also interrupts the user who is clicking through values of input$insidepanels.
What I want the app to be like is that the Outside Panels are fixed and dont re-render. The main problem is that inside shiny, navbarPage on rendering distributes HTML elements to two different locations. Inside the navigation panel and to the body as tab content. That means a-posteori added elements will not be properly embedded.
So far, I have tried to create the navbarPage with custom tags and have dynamic output alter only parts of it. That works pretty well with the navigation panel, but not with tab contents. The reason is that all tabs (their div containers) are listed one after another and as soon as I want to inject multiple at once, I am offthrown by htmlOutput, since it (seemingly) has to have a container and cannot just deliver plain HTML. Thus, all custom tabs are not recongnized properly.
Here my code so far:
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation",
tags$div(class = "container",
tags$div(class = "navbar-header",
tags$span(class = "navbar-brand", "Nav")
),
tags$ul(class = "nav navbar-nav",
tags$li(
tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
),
tags$li(
tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
),
tags$li(class = "dropdown",
tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
htmlOutput("dropdownmenu", container = tags$ul, class = "dropdown-menu")
)
)
)
),
tags$div(class = "container-fluid",
tags$div(class = "tab-content", id = "tabContent",
tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 1, step = 1, min = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 1, step = 1, min = 1),
actionButton("button", label = "Add Output-Element")
),
tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2"),
htmlOutput("tabcontents")
)
)
)
),
server = function(input, output, session){
observeEvent(input$button, {
output[[paste0("plot_", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
output$dropdownmenu <- renderUI({
lapply(1:input$insidepanels, function(x){tags$li(tags$a(href = paste0("#tab-menu-", x), "data-toggle" = "tab", "data-value" = paste0("Inside", x), paste("Inside", x)))})
})
output$tabcontents <- renderUI({
tagList(
lapply(1:input$insidepanels, function(x){div(class = "tab-pane", "data-value" = paste("Inside", x), id = paste0("tab-menu-", x), plotOutput(paste0("plot_", x)))})
)
})
}
)
)
Note: I also tried to create HTML with JavaScript-Chunks that is triggered from inside server. This works for simple tab content, but I want my tabPanels to still have shiny output elements. I don't see how I can fit that in with JavaScript. That is why I included the plotOutput content in my code.
Thanks to anybody who can help solve this issue!
Finally came up with an own answer. I hope this can be a useful reference to others who try to understand shiny reactiveness. The answer is JavaScript for custom elements (rebuilding standard shiny elements) and using Shiny.unbindAll() / Shiny.bindAll() to achieve the reactivity.
Code:
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
tags$script('
Shiny.addCustomMessageHandler("createTab",
function(nr){
Shiny.unbindAll();
var dropdownContainer = document.getElementById("dropdown-menu");
var liNode = document.createElement("li");
liNode.setAttribute("id", "dropdown-element-" + nr);
var aNode = document.createElement("a");
aNode.setAttribute("href", "#tab-menu-" + nr);
aNode.setAttribute("data-toggle", "tab");
aNode.setAttribute("data-value", "Inside" + nr);
var textNode = document.createTextNode("Inside " + nr);
aNode.appendChild(textNode);
liNode.appendChild(aNode);
dropdownContainer.appendChild(liNode);
var tabContainer = document.getElementById("tabContent");
var tabNode = document.createElement("div");
tabNode.setAttribute("id", "tab-menu-" + nr);
tabNode.setAttribute("class", "tab-pane");
tabNode.setAttribute("data-value", "Inside" + nr);
var plotNode = document.createElement("div");
plotNode.setAttribute("id", "plot-" + nr);
plotNode.setAttribute("class", "shiny-plot-output");
plotNode.setAttribute("style", "width: 100% ; height: 400px");
tabNode.appendChild(document.createTextNode("Content Inside " + nr));
tabNode.appendChild(plotNode);
tabContainer.appendChild(tabNode);
Shiny.bindAll();
}
);
Shiny.addCustomMessageHandler("deleteTab",
function(nr){
var dropmenuElement = document.getElementById("dropdown-element-" + nr);
dropmenuElement.parentNode.removeChild(dropmenuElement);
var tabElement = document.getElementById("tab-menu-" + nr);
tabElement.parentNode.removeChild(tabElement);
}
);
'),
tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation",
tags$div(class = "container",
tags$div(class = "navbar-header",
tags$span(class = "navbar-brand", "Nav")
),
tags$ul(class = "nav navbar-nav",
tags$li(
tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
),
tags$li(
tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
),
tags$li(class = "dropdown",
tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
tags$ul(id = "dropdown-menu", class = "dropdown-menu")
)
)
)
),
tags$div(class = "container-fluid",
tags$div(class = "tab-content", id = "tabContent",
tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 0, step = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 0, step = 1),
actionButton("button", label = "Add Output-Element")
),
tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2")
)
)
)
),
server = function(input, output, session){
allOpenTabs <- NULL
observeEvent(input$insidepanels, {
if(!is.na(input$insidepanels)){
localList <- 0:input$insidepanels
lapply(setdiff(localList, allOpenTabs), function(x){
session$sendCustomMessage(type = "createTab", message = x)
})
lapply(setdiff(allOpenTabs, localList), function(x){
session$sendCustomMessage(type = "deleteTab", message = x)
})
allOpenTabs <<- localList
}
})
observeEvent(input$button, {
output[[paste0("plot-", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
}
), launch.browser = TRUE
)
It is basically adding the HTML Elements "by hand" and linking them to shiny listeners.

Resources