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
Related
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.
library(shinydashboard)
library(shiny)
library(dplyr)
trtall <- rbind(rep("A",100),rep("B",100), rep("C",100))
trt <- sample(trtall,80)
agecat.temp <- c(rep("18-40",100), rep("> 40", 100))
agecat <- sample(agecat.temp, 80)
sex <- sample(rbind(rep("M",100),rep("F",100)),80)
race <- sample(rbind(rep("Asian",50),rep("Hispanic",50),rep("Other",50)),80)
df <- data.frame(trt, agecat, sex, race)
body <- dashboardBody(
fluidRow(box(width=12,collapsed=F, collapsible = T, title="Filters", solidHeader = T,status="primary",
box(width=5, height="220px", status="primary",
fluidRow(column(6,uiOutput("uivr1")),
column(6,uiOutput("uivl1")))))))
ui <- dashboardPage(
dashboardHeader(disable = T),
dashboardSidebar(disable = T),
body, skin = "green"
)
server = function(input, output) {
reacui1 <- reactiveVal()
observeEvent(input$vr1,{
reacui1(as.list(df %>% distinct(!!input$vr1) %>% arrange(!!input$vr1)))
})
output$uivr1 <- renderUI(varSelectInput(width = "200px", "vr1",NULL,df))
output$uivl1 <- renderUI(selectInput("vl1",width="200px",multiple=T,NULL,choices=reacui1()))
}
shinyApp(ui,server)
Hi,
I am dynamically trying to create UI in shiny app. The logic works fine until I collapse the box in shiny dashboard.
I did following steps and got unexpected results.
I select 'trt' in "vr1" and choose "A" from "vl1".
I collapsed the box.
Then un-collapsed the box.
I select 'agecat' in "vr1" - now I still see various treatments (A,B,C) but not distinct age categories (18-40, >40) in "vl1"
Can you please help.
The problem comes from the fact that the shown event is not passed down to the elements which are in a box inside the collapsed box.
Compare this to this slightly changed example:
body <- dashboardBody(
fluidRow(
box(width = 12, collapsed = FALSE, collapsible = TRUE,
title = "Filters", solidHeader = TRUE, status = "primary",
# box(width=5, height="220px", status="primary",
fluidRow(column(6, uiOutput("uivr1")),
column(6, uiOutput("uivl1"))
# )
)
)
)
)
and you see that in this case the second input is properly updated.
You can also use your example, go to the JS console and type $('.box').trigger('shown') and you will see that the select input is suddenly updated.
That means the problem is, that shiny still believes that the inputs are hidden and because hidden inputs are not updated you observe this behavior.
But this tells us how we can fix it:
Workaround is to switch off the suspendWhenHidden property. Add this to your server:
session$onFlushed(function() {
outputOptions(output, "uivl1", suspendWhenHidden = FALSE)
})
This is however, just fixing the symptom and not solving the issue.
Another approach would be to make sure the shown.bs.collapse event is also triggered at the box inside the box. For this we can listen to the shown.bs.collapse event and once received, wait a bit (800ms) such that the box is fully visible and then inform all shiny-bound-output children that they should be shown:
js <- "$(() => $('body').on('shown.bs.collapse', '.box', function(evt) {
setTimeout(function(){
$(evt.target).find('.shiny-bound-output').trigger('shown.bs.collapse');
}, 800);
}))"
body <- dashboardBody(
tags$head(tags$script(HTML(js))),
fluidRow(
box(width = 12, collapsed = FALSE, collapsible = TRUE,
title = "Filters", solidHeader = TRUE, status = "primary",
box(width = 5, height = "220px", status = "primary",
fluidRow(column(6, uiOutput("uivr1")),
column(6, uiOutput("uivl1"))
)
)
)
)
)
This is, BTW, already reported as bug: https://github.com/rstudio/shinydashboard/issues/234
I am building a shiny dashboard and plan to use SliderInput to animate a set of exisiting pngs. To do so, in the UI I have:
tabItem(tabName = 'Image',
fluidRow(
box(title = "", status="primary",solidHeader = F,width = 9,
uiOutput("animate_img"),
tags$style(type="text/css", "recalculating { opacity: 1.0 !important; }") # NOT WORKING
),
box(
title = "Options", status="info",solidHeader = TRUE,width = 3,
sliderInput("dates_img",
"Dates:",
min = as.Date("2017-01-01","%Y-%m-%d"),
max = as.Date("2018-12-31","%Y-%m-%d"),
value=as.Date("2017-01-01"),
timeFormat="%Y-%m-%d",
animate=animationOptions(interval=1000, loop = TRUE))
)
)
)
and in the server I have:
output$animate_img <- renderUI({
y <- year(input$dates_img)
d <- yday(input$dates_img)
filename <- sprintf("img_%d_%d.png",d,y)
tags$img(src = filename, width="100%")
})
While this code works to display the images, when I use the "play" button on the sliderInput to animate the images, there is flickering as each image loads. I would like to have a smooth animation if possible.
As suggested here, I have tried adding tags$style(type="text/css", "recalculating { opacity: 1.0 !important; }") to the UI, but this does not work.
Any recommendations for how to prevent the images from flickering as the animation plays? Thank you!
I was able to get it to work without any flickering by simply adjusting how the CSS is included in the rendered HTML. I used shinyjs::inlineCSS in my example, but the same could be done via sourcing an external stylesheet .css file with tags$head and tags$script or via includeCSS, etc. The key is to have the CSS loaded into the full HTML document's head (can verify via browser DevTools):
library(shiny)
library(shinydashboard)
library(shinyjs)
library(lubridate)
ui <- fluidPage(
shinyjs::inlineCSS(
"recalculating { opacity: 1.0 !important; }"
),
fluidRow(
box(title = "",
status = "primary",
solidHeader = F,
width = 9,
uiOutput("animate_img")
),
box(
title = "Options",
status = "info",
solidHeader = TRUE,
width = 3,
sliderInput("dates_img",
"Dates:",
min = as.Date("2017-01-01","%Y-%m-%d"),
max = as.Date("2018-12-31","%Y-%m-%d"),
value = as.Date("2017-01-01"),
timeFormat = "%Y-%m-%d",
animate = animationOptions(interval = 1000, loop = TRUE))
)
)
)
server <- function(input, output) {
output$animate_img <- renderUI({
y <- year(input$dates_img)
d <- yday(input$dates_img)
filename <- sprintf("img_%d_%d.png",d,y)
tags$img(src = filename, width="100%")
})
}
shinyApp(ui = ui, server = server)
Just make sure that your image files are placed directly in the www folder and it should work.
Thanks,
Jimmy
Currently, I have a shiny app built with the following UI structure.
tabsetPanel(tabPanel("Tab1"),
tabPanel("Tab2"),
tabPanel("Tab3"),
tabPanel("Tab4")
However, I would like to change the look and feel of the navigation bars. I would like to center the tabs in the middle of the page as opposed to having them left-aligned (This post is not reproducible and does not seem sustainable). Then insert a triangle in between each tab panel to show a "story line" to indicated content from tab1, 2, etc. is informing and influencing the rest of the dashboard. Then also have the tab highlighted each time the tab changes (green color below). I inserted a quick screenshot of the general UI format I am going for. I couldn't find much online of people trying to do this. Anything to put me in the right direction would be great! Much appreciated! The below is not a hard guidance or request, but just a general style.
You can mimic a layout like this using shinyWidgets::radioGroupButtons (and get reasonably close). Note that you still might need HTML/CSS customization of the buttons and arrows between them. This post might be a good resource: Create a Button with right triangle/pointer
library(shiny)
library(shinyWidgets)
ui <- fluidPage(titlePanel("Hack with shinyWidgets::radioGroupButtons"),
mainPanel(
fluidRow(
column(width = 3, "some space"),
column(
width = 9,
align = "center",
radioGroupButtons(
inputId = "item",
label = "",
status = "success",
size = "lg",
direction = "horizontal",
justified = FALSE,
width = "100%",
individual = TRUE,
checkIcon = list(
"yes" = icon("check"),
"yes" = icon("check"),
"yes" = icon("check"),
"yes" = icon("check")
),
choiceNames = as.list(names(iris)[1:4]),
choiceValues = as.list(1:4)
)
)
),
tags$hr(),
column(width = 3, "some space"),
column(
width = 9,
align = "center",
textOutput("text"),
wellPanel(dataTableOutput("out"))
)
))
server <- function(input, output) {
out_tbl <- reactive({
x <- iris[,c(5, as.numeric(input$item))]
return(x)
})
output$out <- renderDataTable({
out_tbl()
},options = list(pageLength = 5)
)
output$text <- renderText({paste("Contents for tab", input$item)})
}
shinyApp(ui, server)
A screen shot of the layout:
I can't get a leaflet map to render in my shiny app, although the code works by itself outside of shiny. I do not get any errors so I am stuck, any help is appreciated.
Sample Data:
cleanbuffalo <- data.frame(name = c("queen","toni","pepper"),
longitude = c(31.8,32,33),
latitude = c(-24,-25,-26))
Shiny UI:
vars <- c(
"Pepper" = "pepper",
"Queen" = "queen",
"Toni" = "toni"
)
shinyUI(navbarPage("Buffalo Migration", id ="nav",
tabPanel("Interactive Map",
div(class="outer",
leafletOutput("map", width = "100%", height = "100%"),
#Panel Selection
absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE,
draggable = TRUE, top = 60, left = "auto", right = 20, bottom = "auto",
width = 330, height = "auto",
h2("Buffalo Migration"),
#Buffalo Group selection
checkboxGroupInput(
"checkGroup", label = h3("Select Buffalo to Follow"),
choices = vars,
selected = 1)
)
)
)
)
)
Shiny Server:
library(shiny)
library(dplyr)
library(leaflet)
library(scales)
library(lattice)
shinyServer(function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>% addTiles() %>% setView(lng = 31.88, lat = -25.02, zoom=1)
})
It doesn't work because of the height parameter in leafletOutput. Strangely, if you specify it in % the map doesn't show up, but if you use "px" (or a number which will be coerced to a string and have "px" appended) it does work fine.
leafletOutput("map", width = "75%", height = "500px") yields:
I don't know why this happens but if you wanted to specify the height of the leafletOutput in % you could wrap it into a div and give it the appropriate height.
By default the width is set to 100% and the height to 400px. So, you don't have to specify these parameters - I would do it only if I wanted to change the size of the output.
leafletOutput(outputId, width = "100%", height = 400)