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))))))
}
Related
I have a big shiny app. I will put here a smaller version with no outputs, just inputs. For now I have some inputs in a tab - Net Production. I have a second tab - Home - where I display all my selected inputs in a table. The Save action button creates a file called File (today's date).csv in a chosen directory ('My Directory') with all the selected inputs. What I need is to make the Load button change the inputs saved on the csv file. Basically what I want is to every different user have the option of loading the dashboard with his last saved inputs. If you know a better (and free) way to do this, feel free to share.
This is my reproducible app:
library(shiny)
library(shinydashboard)
library(dplyr)
library(purrr)
library(rlang)
library(stringr)
library(DT)
library(r2d3)
library(ggplot2)
library(data.table)
library(highcharter)
library(shinymanager)
library(RColorBrewer)
library(tidyr)
library(dashboardthemes)
library(readxl)
library(scales)
library(plotly)
library(quantmod)
library(lubridate)
library(shinyWidgets)
library(shinydashboardPlus)
library(shinyjs)
library(waiter)
library(fresh)
library(zoo)
library(magrittr)
header <- dashboardHeader(title = 'Dash',
dropdownMenuOutput('Notifications')
)
dashSidebar <- dashboardSidebar(minified = T, collapsed = T, width = 215,
sidebarMenu(
menuItem(text = "Net Production",
tabName = "GraphsTab",
icon= icon('dollar-sign', lib = 'font-awesome'),
badgeLabel = label_date, badgeColor = 'olive'
),
menuItem(text = "Home",
tabName = "HomeTab",
icon = icon("bar-chart-o")
),
menuItem(
text = "File Explore",
tabName = "FileExplore",
icon= icon("file-text")
)
)
)
dashBody <- dashboardBody(
shinyDashboardThemeDIY(
### General
appFontFamily = "Arial" #Application font.
,appFontColor = '#000000' #Application font colour.
,primaryFontColor = '#FFEC8B' #Primary status highlight font colour.
,infoFontColor = '#FFEC8B' #Info status highlight font colour.
,successFontColor = '#FFEC8B' #Success status highlight font colour.
,warningFontColor = '#FFEC8B' #Warning status highlight font colour.
,dangerFontColor = '#FFEC8B' #Danger status highlight font colour.
,bodyBackColor = '#ECF0F5' #Main page background colour. --- Cor de Fundo --- igual a input: buttonBackColor
### header
,logoBackColor = '#EE7942' #Logo background colour.
,headerButtonBackColor = '#EE7942' #Sidebar toggle button background colour.
,headerButtonIconColor = '#FFFFFF' #Sidebar toggle button icon colour.
,headerButtonBackColorHover = '#EB7337' #Sidebar toggle button background colour: hovered.
,headerButtonIconColorHover = '#FFFFFF' #Sidebar toggle button icon colour: hovered.
,headerBackColor = '#EE7942' #Top header background colour.
,headerBoxShadowColor = "" #Top header shadow colour.
,headerBoxShadowSize = "0px 0px 0px" #Top header shadow size.
### sidebar
,sidebarBackColor = '#2F4F4F' #Sidebar background colour.
,sidebarPadding = 0 #Sidebar inner padding.
,sidebarMenuBackColor = "inherit" #Sidebar menu background colour.
,sidebarMenuPadding = 0 #Sidebar menu inner padding.
,sidebarMenuBorderRadius = 0 #Sidebar menu shape radius.
,sidebarShadowRadius = "" #Sidebar shadow radius.
,sidebarShadowColor = "0px 0px 0px" #Sidebar shadow colour.
,sidebarUserTextColor = '#FFEC8B' #Sidebar userbox text colour.
,sidebarSearchBackColor = '#FFFFFF' #Sidebar searchbox background colour.
,sidebarSearchIconColor = '#212529' #Sidebar searchbox icon colour.
,sidebarSearchBorderColor = '#DCDCDC' # Sidebar searchbox border line colour.
,sidebarTabTextColor = '#E0FFFF' #Sidebar tab font colour.
,sidebarTabTextSize = 14 #Sidebar tab font size.
,sidebarTabBorderStyle = "none" #Sidebar tab border line style.
,sidebarTabBorderColor = "none" #Sidebar tab border line colour.
,sidebarTabBorderWidth = 0 #Sidebar tab border line width.
,sidebarTabBackColorSelected = '#244040' #Sidebar tab background colour: selected.
,sidebarTabTextColorSelected = '#FFFFFF' #Sidebar tab font colour: selected.
,sidebarTabRadiusSelected = "0px" #Sidebar tab shape radius: selected.
,sidebarTabBackColorHover = '#244040' #Sidebar tab background colour: hovered.
,sidebarTabTextColorHover = '#FFFFFF' #Sidebar tab font colour: hovered.
,sidebarTabBorderStyleHover = "none" #Sidebar tab border line style: hovered.
,sidebarTabBorderColorHover = "none" #Sidebar tab border line colour: hovered.
,sidebarTabBorderWidthHover = 0 #Sidebar tab border line width: hovered.
,sidebarTabRadiusHover = "0px" #Sidebar tab shape radius: hovered.
### boxes
,boxBackColor = '#FFFFFF' #Box background colour.
,boxBorderRadius = 5 #Box shape radius.
,boxShadowSize = "0px 0px 0px" #String. Box shadow size.
,boxShadowColor = "" #String. Box shadow colour.
,boxTitleSize = 19 #Numeric. Box title font size.
,boxDefaultColor = '#FFEC8B' #String. Box default highlight colour.
,boxPrimaryColor = '#FFEC8B' #String. Box primary highlight colour.
,boxInfoColor = '#FFEC8B' #String. Box info highlight colour.
,boxSuccessColor = '#FFEC8B' #String. Box success highlight colour.
,boxWarningColor = '#FFEC8B' #String. Box warning highlight colour.
,boxDangerColor = '#FFEC8B' #String. Box danger highlight colour.
,tabBoxTabColor = '#FFFFFF' #String. Tab box tab background colour.
,tabBoxTabTextSize = 14 #Numeric. Tab box tab font size.
,tabBoxTabTextColor = '#212529' #String. Tab box tab font colour.
,tabBoxTabTextColorSelected = '#212529' #String. Tab box tab font colour: selected
,tabBoxBackColor = '#FFFFFF' #String. Tab box body background colour.
,tabBoxHighlightColor = '#EE7942' #String. Tab box highlight colour.
,tabBoxBorderRadius = 5 #Numeric. Tab box shape radius.
### inputs
,buttonBackColor = '#ECF0F5' #String. Button background colour. --- Igual a cor de fundo ---
,buttonTextColor = '#212529' #String. Button font colour.
,buttonBorderColor = '#D3D3D3' #String. Button border line colour.
,buttonBorderRadius = 5 #Numeric. Button shape radius.
,buttonBackColorHover = '#DCDCDC' #String. Button background colour: hovered.
,buttonTextColorHover = '#212529' #String. Button font colour: hovered.
,buttonBorderColorHover = '#808080' #String. Button border line colour: hovered.
,textboxBackColor = '#FFFFFF' #String. Textbox background colour.
,textboxBorderColor = '#D3D3D3' #String. Textbox border line colour.
,textboxBorderRadius = 5 #Numeric. Textbox shape radius.
,textboxBackColorSelect = '#DCDCDC' #String. Textbox background colour: selected.
,textboxBorderColorSelect = '#808080' #String. Textbox border line colour: selected.
### tables
,tableBackColor = '#FFFFFF' #String. Table background colour.
,tableBorderColor = '#ECF0F1' #String. Table border line colour.
,tableBorderTopSize = 1 #Numeric. Table header line size.
,tableBorderRowSize = 1 #Numeric. Table row separator line size.
),
tags$style(
'
#media (min-width: 768px){
.sidebar-mini.sidebar-collapse .main-header .logo {
width: 230px;
}
.sidebar-mini.sidebar-collapse .main-header .navbar {
margin-left: 230px;
}
}'
),
tabItems(
tabItem("GraphsTab",
# h1("BPI"),
fluidRow(
column(2,
box(id = "Datas_box", width = NULL, solidHeader = FALSE, status = NULL,title = NULL, style = "position:relative;width:100%;height:0;padding-bottom:40%;",
dateRangeInput(
inputId = "DateRange",
label= "Select dates",
format= "dd/mm/yyyy",
# start = paste0(year(today()),"/01/01"),
start = '2022/01/01'
),
actionButton(
inputId = 'action_1',
label = '1m'
),
actionButton(
inputId = 'action_2',
label = '3m'
),
actionButton(
inputId = 'action_3',
label = '6m'
),
actionButton(
inputId = 'action_4',
label = '1y'
),
actionButton(
inputId = 'action_5',
label = 'YTD'
)
),
tags$head(tags$style('#Datas_box .box-header{ display: none}'))
),
column(2,
box(id = "Gup_box", width = NULL, solidHeader = FALSE, status = NULL, style = "position:relative;width:100%;height:0;padding-bottom:40%;",
pickerInput(inputId = "PickerGrupos",
label= "Groups",
choices= c("Dom","I","L","P","VP",'Cl','Pen'),
options = pickerOptions(
`actions-box` = TRUE),
multiple = T,
width = '100%',
selected = c("Dom","I","L","P","VP",'Cl','Pen')
),
prettySwitch(inputId = "Stacked_Switch",
label = "NP Stacked",
status = "default",
fill = TRUE
),
tags$head(tags$style('#Gup_box .box-header{ display: none}')),
tags$style(".bs-placeholder {color: #212529 !important;}")
)
),
column(2,
box(id = "Fnd_box", width = NULL, solidHeader = FALSE, status = NULL, style = "position:relative;width:100%;height:0;padding-bottom:40%;",
prettySwitch(inputId = "Union_Switch",
label = "Groups or Profiles",
status = "default",
fill = TRUE
),
tags$head(tags$style('#Fnd_box .box-header{ display: none}'))
)
),
column(3,
box(id = 'Perfis_box', width = NULL, solidHeader = FALSE, status = NULL, style = "position:relative;width:100%;height:0;padding-bottom:26%;",
pickerInput(inputId = 'PickerPerfis',
label = "Profiles",
choices = c('A','D','M','D','I','Outros'),
options = pickerOptions(
`actions-box` = TRUE),
# style = "btn-primary"
multiple = T
),
tags$head(tags$style('#Perfis_box .box-header{ display: none}'))
)
),
column(3,
box(id = "View_box", width = NULL, solidHeader = FALSE, status = NULL, style = "position:relative;width:100%;height:0;padding-bottom:26%;",
prettyRadioButtons (inputId = "DatesView",
label = "Select view",
choices = c("Days", "Weeks","Months","Years"),
inline = T,
shape = c("curve"),
fill = TRUE,
status = "danger"
)
),
tags$head(tags$style('#View_box .box-header{ display: none}'))
)
)
),
tabItem(tabName = "HomeTab",
fluidRow(
column(2, offset = 5,
box(id = 'User_box', width = NULL, solidHeader = FALSE, status = NULL,
textInput("name", "Name", ""),
actionButton(inputId = 'load_button', label = 'Load', icon = NULL, width = NULL),
actionButton(inputId = 'save_button', label = 'Save', icon = NULL, width = NULL)
),
tags$head(tags$style('#User_box .box-header{ display: none}'))
)
),
fluidRow(
h1("All inputs"),
tableOutput("show_inputs")
)
)
))
ui <- shinydashboardPlus::dashboardPage(title = 'Dash',
header,
dashSidebar,
dashBody
)
server <- function(input, output){
saveData <- function(data) {
outputDir <- 'My Directory'
fileName <- paste("File ",as.character(Sys.Date()),".csv",sep = "")
# Write the file to the local system
write.csv(
x = data,
file = file.path(outputDir, fileName),
row.names = FALSE, quote = TRUE
)
}
loadData <- function() {
# Read all the files into a list
files <- list.files(outputDir, full.names = TRUE)
data <- lapply(files, read.csv, stringsAsFactors = FALSE)
# Concatenate all data together into one data.frame
data <- do.call(rbind, data)
data
}
#----------------------------------------------------------------------------#
# Output: Inputs
#----------------------------------------------------------------------------#
AllInputs <- reactive({
myvalues <- NULL
newvalues <- NULL
for(i in 1:length(names(input))){
newvalues <- paste(names(input)[i], input[[names(input)[i]]], sep=":")
myvalues <- append(myvalues, newvalues)
}
myvalues
})
output$show_inputs <- renderTable({
AllInputs()
})
observeEvent(input$save_button, {
saveData(AllInputs())
})
}
shinyApp(ui = ui, server = server)
For sharing the dashboard I use the following code in a play_dashboard.R file:
#!/usr/bin/Rscript
rm(list=ls())
library(shiny)
library(shinydashboard)
library(profvis)
#options("encoding" = "UTF-8")
## working paths
setwd("My directory")
runApp(host="0.0.0.0",port=82)
#runApp(host="85.88.128.214",port=49152)
With the following bat button:
#echo off
title esg_dash
"C:\Program Files\R\R-4.0.1\bin\Rscript.exe" -e "source('My Directory/play_dashboard.R')"
title Command Prompt
pause
I have an application which uses box::dropdownMenu to render a dropdown menu which the user will use to set plot options. I'm able to implement this functionality without any issue, but I would like to do two additional things.
Is it possible to:
(1) Hide the arrow to the right of the cog-icon?
(2) On the dropdown menu, is it possible to keep the text left-alligned, but have the radio buttons be right aligned?
Current State:
Desired End Result:
Code:
library(shiny)
library(shinyWidgets)
library(shinydashboardPlus)
ui <- fluidPage(
box(
title = "Box Title",
dropdownMenu = dropdown(
width = "200px",
icon = icon("gear"),
materialSwitch(inputId = "Id079", label = "Color:"),
materialSwitch(inputId = "Id079", label = "Display Goal:"),
),
textOutput("text")
)
)
server <- function(input, output, session) {
output$text <- renderText("Hello World!")
}
shinyApp(ui, server)
To remove the arrow, one should change style to something other than the default. You can use fill or bordered for example.
shinyWidgets::dropdown(
width = "200px",
style = "fill",
icon = icon("cog"),
materialSwitch(inputId = "Id079", label = "Color:"),
# Change IDs to unique IDs otherwise it won't work
materialSwitch(inputId = "Id080", label = "Display Goal:"),
)
For the alignment, you can play around with the .label-default elements (attrinutes?)
ui <- fluidPage(
# Need to play with the margin-left part
tags$head(tags$style(HTML(".label-default{
margin-left: 50px;}
"))),
shinyWidgets::dropdown(
width = "300px",
style = "fill",
icon = icon("cog"),
materialSwitch(inputId = "Id079", label = "Color:"),
materialSwitch(inputId = "Id080", label = "Display Goal:"),
),
textOutput("text")
)
The problem with this is that it is not easy to uniformly change the margins for non-equal labels.
I stumbled upon this wierd interaction between collapsed boxes within boxes and plots:
In the the first instance of this, in the minimal working example below, on the left side, expanding the box pushes the plot over the edge of the box, while in the second instance on the right side, it does not.
Also, uncommenting the code of the action button somehow remedies this somehow.
Can someone explain to me why this is happening and how to solve the issue?
I am aware that I could just use the layout to the right, but I would really like to understand this behavior.
Thanks in advance!
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
fluidPage(
box(width = 12,
title = "Some Title",
collapsible = TRUE,
solidHeader = TRUE,
status = "danger",
box(widht = 12,
title = "Some Sub Title",
collapsible = TRUE,
solidHeader = TRUE,
box(
width = 12,
title = "Details 1",
collapsible = TRUE,
solidHeader = TRUE,
collapsed = TRUE,
status = "info",
tableOutput("Placeholder_Table_1")
),
#actionButton(inputId = "Action_1",
# label = "Does nothing"
#),
plotOutput("Placeholder_Plot_1")
),
box(widht = 12,
title = "Sub Title 2",
collapsible = TRUE,
solidHeader = TRUE,
plotOutput("Placeholder_Plot_2"),
box(
width = 12,
title = "Details 2",
collapsible = TRUE,
solidHeader = TRUE,
collapsed = TRUE,
status = "info",
tableOutput("Placeholder_Table_2")
)
)
)
)
)
)
server <- function(input, output) {
output$Placeholder_Table_1 <- renderTable(
tibble('Variable 1' = "X",
'Variable 2' = "Y",
'Variable 3' = "Z"
)
)
output$Placeholder_Table_2 <- renderTable(
tibble('Variable 1' = "X",
'Variable 2' = "Y",
'Variable 3' = "Z"
)
)
output$Placeholder_Plot_1 <- renderPlot(
ggplot(data = mtcars) +
labs(title = "Placeholder Plot 1")
)
output$Placeholder_Plot_2 <- renderPlot(
ggplot(data = mtcars) +
labs(title = "Placeholder Plot 2")
)
}
shinyApp(ui, server)
The problem is not the plot, it comes from the box.
First thing you need to know is box is actually using .col-xxx classes from bootstrap and these classes have a CSS float: left;. It will cause itself has 0 height of the parent div. Read this: CSS: Floating divs have 0 height.
However, what you see is it takes some spaces on the UI, so what you see the height is box + plot, but in the parent div height calculation, it's just the plot.
To fix, very easy, wrap your box with fluidrow, .row has a CSS display: table which solves the problem.
fluidRow(box(
width = 12,
title = "Details 1",
collapsible = TRUE,
solidHeader = TRUE,
collapsed = TRUE,
status = "info",
tableOutput("Placeholder_Table_1")
)),
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) {
}
)
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