I'm building an interactive map with Shiny and I'm currently trying to hide my UI elements in a dropdownButton from the shinyWidgets pkg.
My problem is that so far I can either have the dropdownButton working and having to remove the width = "100%", height = "100%" from my leafletOutput
OR
having my map as I want it and the dropdownButton being invisible.
Is there a way of having both? Thanks!
Here's a reprex:
library(shiny)
library(leaflet)
library(RColorBrewer)
library(shinyWidgets)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
dropdownButton(sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE)
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>% addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
proxy <- leafletProxy("map", data = quakes)
# Remove any existing legend, and only if the legend is
# enabled, create a new one.
proxy %>% clearControls()
if (input$legend) {
pal <- colorpal()
proxy %>% addLegend(position = "bottomright",
pal = pal, values = ~mag
)
}
})
}
shinyApp(ui, server)
Instead of setting html width and height, you can put the map in a full page container like this :
ui <- bootstrapPage(
tags$style(type = "text/css", ".map-container {position:absolute; top:0; bottom:0; right:0; left:0;}"),
tags$style(type = "text/css", "#dropdown {margin-top: 80px; margin-left: 10px;}"),
tags$div(
class = "map-container",
leafletOutput("map", width = "100%", height = "100%")
),
dropdownButton(
inputId = "dropdown",
icon = icon("gears"),
circle = FALSE,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE)
)
)
Related
I have a leaflet map which renders different polygons based off of a picker input. For some reason, leafletProxy will only render if the picker is changed, even though the observe({}) event it's wrapped inside will trigger when the app loads. Is there some way I can fix this?
The map is also slow to update when the picker is changed - is there a way for me to speed this up, just as an aside?
I've included a very simplified version of the code I'm using here. Unfortunately, the data is sensitive so I cannot share it.
library(shiny)
library(shinythemes)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(shinyWidgets)
library(leaflet)
library(tidyverse)
library(feather)
library(sf)
library(viridis)
ui <- fluidPage(
useShinyjs(),
theme = shinytheme("cerulean"),
useShinydashboard(),
tabsetPanel(
tabPanel(
"Tab 1",
pickerInput(
width = "100%",
inputId = "indicator_input",
label = "Select an indicator on the map:",
choices = list(
"Choice 1", "Choice 2", "Choice 3"
),
options = list(`style` = "btn-primary")
),
leafletOutput("example1")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
#Label object
example_labels <- reactive({
labels <- paste0(
"<strong>", "Polygon name: ", "</strong>", shapedata$polygon_name,"<br>",
"<strong>", "Indicator 1: ", "</strong>",
shapedata$indicator_1, "%", "<br>",
"<strong>", "Indicator 2: ", "</strong>",
shapedata$indicator_2, "%", "<br>"
) %>% lapply(htmltools::HTML)
return(cald_labels)
})
# Start initial leaflet render
output$example1 <- renderLeaflet({
glimpse("Loaded")
leaflet(shapedata) %>%
addProviderTiles(leaflet::providers$Esri.WorldImagery) %>%
setView(lng = 133.7751, lat = -25.2744, zoom = 4)
}) # end leaflet output
observe({
glimpse("Observe triggered")
map_pal <- colorBin(palette = mako(10),
domain = shapedata[[input$indicator_input]],
bins=10,
na.color = "grey",
reverse = TRUE)
leafletProxy(
"example1",
data = shapedata
) %>%
addPolygons(
layerId = shapedata$polygon_name,
fillColor = ~map_pal(shapedata[[input$indicator_input]]),
weight = 2,
color = "white",
fillOpacity = 0.9,
label = example_labels(),
labelOptions = labelOptions(#labels
style = list("font-weight" = "normal",
padding = "3px 3px"),
textsize = "10px",
direction = "auto")
) %>%
clearControls() %>%
addLegend(pal = map_pal,
title = "Decile",
opacity = 0.9,
values = ~shapedata[[input$indicator_input]],
labels = c(min(input$indicator_input), max(input$indicator_input)),
position = "topright")
})
}
# Run the application
shinyApp(ui = ui, server = server)
The issue was caused by the same problem, and solved by the same solution, as here.
good afternoon/night. Im trying to create a shiny app with leaflet and echarts4r, but i would like to know if it is possible to change the size of the histogram that appears to the side. Anyone have any ideas on how I could do it? Here is a screenshot to indicate the size that I would be interested in having the graphic:
SS of the app
The code of the app is the following:
library(shiny)
library(leaflet)
library(RColorBrewer)
library(htmltools)
library(echarts4r)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE),
p( iris %>%
e_charts() %>%
e_histogram(Sepal.Length, name = "histogram",breaks = "freedman-diaconis") %>%
e_tooltip(trigger = "axis") |>
e_color(color = "#753732")
)
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>% addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
) %>% addTiles("http://{s}.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png",
attribution = paste(
"© OpenStreetMap contributors",
"© CartoDB"
)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
proxy <- leafletProxy("map", data = quakes)
# Remove any existing legend, and only if the legend is
# enabled, create a new one.
proxy %>% clearControls()
if (input$legend) {
pal <- colorpal()
proxy %>% addLegend(position = "bottomright",
pal = pal, values = ~mag
)
}
})
}
shinyApp(ui, server)
Here is one option -
Take the histogram plot on server side and use echarts4rOutput in the ui where you can easily adjust height and width according to your choice.
library(shiny)
library(leaflet)
library(RColorBrewer)
library(htmltools)
library(echarts4r)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE),
echarts4rOutput('hist_plot', height = '1000px', width = '500px')
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>% addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
) %>% addTiles("http://{s}.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png",
attribution = paste(
"© OpenStreetMap contributors",
"© CartoDB"
)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
proxy <- leafletProxy("map", data = quakes)
# Remove any existing legend, and only if the legend is
# enabled, create a new one.
proxy %>% clearControls()
if (input$legend) {
pal <- colorpal()
proxy %>% addLegend(position = "bottomright",
pal = pal, values = ~mag
)
}
})
output$hist_plot <- renderEcharts4r({
iris %>%
e_charts() %>%
e_histogram(Sepal.Length, name = "histogram",breaks = "freedman-diaconis") %>%
e_tooltip(trigger = "axis") %>%
e_color(color = "#753732")
})
}
shinyApp(ui, server)
I would like to render a map based on selectInput(). I have two selectInput()s: first one product_type and second one product_name. In the second one selectInput() the drop down options should be display only relevant to first selectInput(). Based on these drill down inputs map should change dynamically.
Here is the code:
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
fluidPage(
box("",
leafletOutput("abc", width = '100%', height = 300),
height = 350, width = 12),
box("",
selectInput('vtype', label = 'Prod Type',choices = brand$prod_type),
selectInput('vname', label = 'Prod Name',choices = brand$prod_name),
width = 4),
valueBoxOutput("gr", width = 8)
)
)
))
server <- shinyServer(function(input,output,session){
a <- ship %>% select(prod_name,prod_type,LON,LAT) %>% filter(prod_type == input$vtype)
output$gr <- renderValueBox({
box(table(a))
})
output$abc <- renderLeaflet({
leaflet() %>% addProviderTiles(providers$OpenTopoMap )
%>% setView(lat = a$LAT ,lng = A$LON, zoom = 4)
})
})
shinyApp(ui,server)
The dynamically changed points in the map should be marked up. I tried but could not able to build the code.
Any help on this code would be graceful for me.
I hope my example helps. I invented a data.frame 'ship' and made everything dependent on it. That means it is used for your variable 'brand' as well as 'ship'.
I'm not sure how you envisioned the value box, so I put category and products in it.
library(shiny)
library(shinydashboard)
library(dplyr)
library(leaflet)
ship <- data.frame(
product_type = c("food","food","tool","tool","tool","accessories","accessories","lighting","lighting","lighting"),
product_name=c("eggs", "bread","clamp","hammer","screw driver", "watch" ,"sun glases","LED","bulb","briquette"),
LON=c(-61.783,2.632,47.395,20.068,44.563,17.544,-170.730,-65.167,136.189,50.562),
LAT=c(17.078 ,28.163 ,40.430 ,41.143 ,40.534 ,-12.296 ,-14.318 ,-35.377 ,-24.973 ,26.019),
stringsAsFactors = F)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(collapsed = TRUE, disable = FALSE),
dashboardBody(
# fluidPage(
box(
leafletOutput("abc", width = '100%', height = 300),
height = 350,
width = 12),
box(
selectInput('vtype', label = 'Prod Type', choices = c("< select product type>"="", ship$product_type)),
selectInput('vname', label = 'Prod Name', choices = c("< select item>"="", ship$product_name)),
width = 4),
valueBoxOutput("gr", width = 8)
#)
)
)
server <- shinyServer(function(input,output,session){
a <- reactive({
ship %>%
select(product_name, product_type, LON, LAT) %>%
filter(product_type %in% input$vtype)
})
output$gr <- renderValueBox({
valueBox( input$vtype, paste(a()$product_name, collapse=' - ') )
})
observe({
updateSelectInput(session,
inputId='vname',
choices = c("< select item>"="", a()$product_name ))
})
output$abc <- renderLeaflet({
leaflet() %>%
addProviderTiles(providers$OpenTopoMap ) %>%
setView(lng=0, lat=0, zoom = 1)
})
observe({
selection <- a() %>% filter(product_name %in% input$vname)
leafletProxy("abc") %>%
flyTo(lat = selection$LAT,
lng = selection$LON,
zoom = 4)
})
})
shinyApp(ui,server)
Please provide example data next time.
I would like to display a conditional panel in my map when I click on a circle, and this conditional panel must disappear if I click outside a circle, but it does not appear and I don't know why.
I think it's about reactive values (one more time).
If any idea, please tell me.
Thank you very much, this is a reproducible example (thanks to SymbolixAU) :
ui :
library(shiny)
library(leaflet)
ui <- fluidPage(
leafletOutput("mymap",width="100%",height="750px"),
conditionalPanel(
condition = "output.COND == '2'",
fluidRow(
absolutePanel(id = "cond_panel",
class = "panel panel-default",
fixed = TRUE,
draggable = TRUE,
top = "auto",
left = 200,
right = "auto",
bottom = 0,
width = 400,
height = 400,
fluidRow(
) # e. of fluidRow(
) # # e. of absolutePanel
) # e. of fluidRow
) # e. of conditionalPanel
) # e. of fluidPage
and the server :
server <- function(input, output){
rv <- reactiveValues()
rv$myDf <- NULL
rv$cond <- NULL
cities <- read.csv(textConnection("
City,Lat,Long,Pop
Boston,42.3601,-71.0589,645966
Hartford,41.7627,-72.6743,125017
New York City,40.7127,-74.0059,8406000
Philadelphia,39.9500,-75.1667,1553000
Pittsburgh,40.4397,-79.9764,305841
Providence,41.8236,-71.4222,177994
"))
cities$id <- 1:nrow(cities)
output$mymap <- renderLeaflet({
leaflet(cities) %>% addTiles() %>%
addCircles(lng = ~Long, lat = ~Lat, weight = 1,
radius = ~sqrt(Pop) * 30, popup = ~City, layerId = ~id)
})
observeEvent(input$mymap_click, {
print("map clicked")
rv$cond <- "1"
print(paste("Value rv$cond = ", rv$cond))
output$COND <- reactive({rv$cond})
leafletProxy("mymap")
}) # e. of observeEvent
observeEvent(input$mymap_shape_click, {
print("shape clicked")
rv$cond <- "2"
print(paste("Value rv$cond = ", rv$cond))
output$COND <- reactive({rv$cond})
leafletProxy("mymap")
}) # e. of observeEvent
} # e. of server
I'm going to propose a slightly different approach that uses library(shinyjs) to use javascript to control whether the panel is hidden or not.
In this example I've created a hidden div element (i.e., the panel will start hidden when the app opens). Then the 'div' is shown when the circle is clicked, and hidden again when the map is clicked.
This answer is inspired by #Daattali's answer here (he's the author of library(shinyjs).
library(shiny)
library(leaflet)
library(shinyjs)
ui <- fluidPage(
useShinyjs(), ## Call to use shinyJS
leafletOutput("mymap",width="100%",height="750px"),
#conditionalPanel(
#condition = "output.COND === '2'",
hidden(
div(id = "conditionalPanel",
fluidRow(
absolutePanel(id = "cond_panel",
class = "panel panel-default",
fixed = TRUE,
draggable = TRUE,
top = "auto",
left = 200,
right = "auto",
bottom = 0,
width = 400,
height = 400,
fluidRow(
) # e. of fluidRow(
) # # e. of absolutePanel
) # e. of fluidRow
)
)
# ) # e. of conditionalPanel
) # e. of fluidPage
server <- function(input, output){
rv <- reactiveValues()
rv$myDf <- NULL
rv$cond <- NULL
cities <- read.csv(textConnection("
City,Lat,Long,Pop
Boston,42.3601,-71.0589,645966
Hartford,41.7627,-72.6743,125017
New York City,40.7127,-74.0059,8406000
Philadelphia,39.9500,-75.1667,1553000
Pittsburgh,40.4397,-79.9764,305841
Providence,41.8236,-71.4222,177994
"))
cities$id <- 1:nrow(cities)
output$mymap <- renderLeaflet({
leaflet(cities) %>% addTiles() %>%
addCircles(lng = ~Long, lat = ~Lat, weight = 1,
radius = ~sqrt(Pop) * 30, popup = ~City, layerId = ~id)
})
observeEvent(input$mymap_click, {
shinyjs::hide(id = "conditionalPanel")
print("map clicked")
rv$cond <- "1"
print(paste("Value rv$cond = ", rv$cond))
output$COND <- reactive({rv$cond})
leafletProxy("mymap")
}) # e. of observeEvent
observeEvent(input$mymap_shape_click, {
shinyjs::show(id = "conditionalPanel")
print("shape clicked")
rv$cond <- "2"
print(paste("Value rv$cond = ", rv$cond))
output$COND <- reactive({rv$cond})
leafletProxy("mymap")
}) # e. of observeEvent
} # e. of server
shinyApp(ui, server)
Just use the absolutePanel inside a conditionalPanel whose condition you reset based on user input.
I'm trying to change the style / color of the heading for the slider title "Magnitudes", but I can't figure out what to do. I've tried adding things like
p {color: red} to the tags$style line, like this:
tags$style(type = "text/css", "html, body {width:100%;height:100%}", "p {color=white}"),
to no avail. Any ideas? I don't think it's something you change in the actual sliderInput function itself, but rather CSS, I just can't quite figure it out.
library(shiny)
library(leaflet)
library(RColorBrewer)
ui <- bootstrapPage(
tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
leafletOutput("map", width = "100%", height = "100%"),
absolutePanel(top = 10, right = 10,
sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
value = range(quakes$mag), step = 0.1
),
selectInput("colors", "Color Scheme",
rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
),
checkboxInput("legend", "Show legend", TRUE)
)
)
server <- function(input, output, session) {
# Reactive expression for the data subsetted to what the user selected
filteredData <- reactive({
quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
})
# This reactive expression represents the palette function,
# which changes as the user makes selections in UI.
colorpal <- reactive({
colorNumeric(input$colors, quakes$mag)
})
output$map <- renderLeaflet({
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
leaflet(quakes) %>% addTiles() %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
})
# Incremental changes to the map (in this case, replacing the
# circles when a new color is chosen) should be performed in
# an observer. Each independent set of things that can change
# should be managed in its own observer.
observe({
pal <- colorpal()
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
)
})
# Use a separate observer to recreate the legend as needed.
observe({
proxy <- leafletProxy("map", data = quakes)
# Remove any existing legend, and only if the legend is
# enabled, create a new one.
proxy %>% clearControls()
if (input$legend) {
pal <- colorpal()
proxy %>% addLegend(position = "bottomright",
pal = pal, values = ~mag
)
}
})
}
shinyApp(ui, server)
Cutting straight to the chase:
Try adding this to your ui:
tags$style(type = "text/css", 'label[for="range"] {color: white;}'),
More detail about how you might figure that out on your own:
Here's how I'd proceed.
Use runApp() to run the code you've got, producing a very nice leaflet map in your browser.
Right-click on that map and select "View Page Source" to see the source code that's producing the map.
Search that source for the string "Magnitude", to find the HTML element that codes for the title you'd like to whiten. Here's what I find when I do that:
<label class="control-label" for="range">Magnitudes</label>
From that, construct a CSS selector (here including an "attribute selector") that'll find that element, and use it to change the color. Adding this, following the first line of your call to bootstrapPage(), does the trick for me:
tags$style(type = "text/css", 'label[for="range"] {color: white;}'),
Use runApp() again to confirm that the edit worked.