Is there a way to entirely disable dragging and/or zooming in gvisMap, and remove the zoom control also? I have looked at options under google.com developers docs referenced in the help for gvisMap(options) but can't see this control.
Broadening the scope of the question to include alternative packages, I note that plotGoogleMaps() in R package plotGoogleMaps has an option draggable=FALSE, but there is no corresponding parameter to disable zoom, and rendering it in shiny is not so simple as renderGvis(). I had a quick look at RgoogleMaps package also.
Background: I particularly want a google satellite map for the transition to street view, I set the map bounds from a zoom/drag enabled leaflet map, so enabling zoom/drag on the google satellite view is redundant/confusing. Disabling these capabilities is a detail that would improve the UX.
[edit] This revised example is a bit longer but shows in full the functionality I am referring to. It works fine apart from some niggles such as I don't know why the fudge factors are needed, and I don't know how to turn off the markers in the google map - but these are outside the scope of my question. The specific subject of my question however is: can I disable drag and zoom on the google map, just like I do in leafletOptions(zoomControl = FALSE, dragging = F)? If I had a supplementary question, it would be something like 'how do I reduce the proliferation of google mapping packages?' - but that is not a valid question for this forum. That said, I'd welcome any broader steer on how to simplify this.
library(shiny)
library(leaflet)
library(googleVis)
library(RgoogleMaps)
ui <- fluidPage(fluidPage(fluidRow(
h5('control map - use only this one to drag and zoom'),
column(6, leafletOutput('controlmap'), offset = 0)
,
h5("google map - drop 'peg man' to get street view"),
column(6, htmlOutput('gmap'), offset = 0)
)
,
fluidRow(
h5('choropleth - where the colour-coded data is displayed'),
column(6, leafletOutput('fitmap'), offset = 0)
)))
server <- function(input, output) {
latlongR <- reactive({
if (is.null(input$controlmap_bounds)) {
data.frame(
Lat = c(51.52, 51.51),
Long = c(-.106, -.096),
Tip = as.character(1:2)
)
} else {
data.frame(
Lat = c(
input$controlmap_bounds$north,
input$controlmap_bounds$south
),
Long = c(
input$controlmap_bounds$east,
input$controlmap_bounds$west
),
Tip = as.character(1:2)
)
}
})
boundR <- reactive({
fudgezoom <- .7 #fudge - unsure why neeed
x0 <- latlongR()
d1 <- abs(diff(x0[, 1]))
d2 <- abs(diff(x0[, 2]))
m1 <- mean(x0[, 1])
m2 <- mean(x0[, 2])
x1 <- c(m1 + fudgezoom * d1 / 2, m1 - fudgezoom * d1 / 2)
x2 <- c(m2 + fudgezoom * d2 / 2, m2 - fudgezoom * d2 / 2)
x3 <- cbind(x0, LatLong = paste0(x1, ':', x2))
x3
})
output$controlmap <- renderLeaflet({
leaflet(width = 500, height = 400) %>%
addProviderTiles('OpenStreetMap') %>%
setView(lng = -0.106831,
lat = 51.515328,
zoom = 15)
})
output$fitmap <- renderLeaflet({
x1 <- latlongR()
fudgefit <- .5 #this fudge depends on layout and maybe other variables
x2 <-
RgoogleMaps::MaxZoom(
latrange = fudgefit * x1$Lat,
lonrange = fudgefit * x1$Long,
size = c(500, 400)
)
leaflet(
width = 500,
height = 400,
options = leafletOptions(zoomControl = FALSE, dragging = F)
) %>%
addProviderTiles('CartoDB.Positron') %>%
fitBounds(
lng1 = x1$Long[1],
lat1 = x1$Lat[1],
lng2 = x1$Long[2],
lat2 = x1$Lat[2]
) %>%
setView(zoom = x2,
lat = mean(x1$Lat),
lng = mean(x1$Long))
})
output$gmap <- renderGvis({
x3 <- boundR()
gvisMap(
x3,
"LatLong" ,
tipvar = "Tip",
options = list(
showTip = F,
icons = NULL,
useZoomControl = F,
useMapTypeControl = F
)
)
})
}
shinyApp(ui = ui, server = server)
Related
So I'm working on a Shiny dashboard, which I deployed on an AWS EC2 instance. It behaves exactly the same both locally and online save for one detail: the labels on the right hand side do not behave properly!
Here is the online version of the Plotly Sankey diagram in question:
Here is what I see locally when I run the app through RStudio.
There's absolutely no difference among any files. I don't see why the rendering of the labels should differ on both versions, but anyway, here's the relevant part of the code inside server.R:
# gender_sankey
nodes <- c('Hombres', 'Mujeres', unique(gender_df$UltimoGradoEstudios))
nodes <- nodes[c(1,2,4,3,5,7,12,10,8,6,11,9)]
gender_df$count <- 1
hom_stud <- aggregate(count ~ UltimoGradoEstudios, FUN = sum,
data = gender_df[gender_df$hom == 1,])
muj_stud <- aggregate(count ~ UltimoGradoEstudios, FUN = sum,
data = gender_df[gender_df$muj == 1,])
# Setting the sources and targets
hom_stud$src <- 0
muj_stud$src <- 1
hom_stud$tgt <- c(2,4,3,11,5,8,6,9,7)
muj_stud$tgt <- c(2,4,3,11,5,8,10,6,9,7)
# Setting the positions for the nodes
node_x <- c(0,0,1,1,1,1,1,1,1,1,1,1)
node_y <- c(0,1,-10:-1) # NOTE: Probably one of the fishy parts (2/2)
colors <- c('#C7FFA9','#E4A9FF','#2424FF','#2477FF','#248EFF','#249FFF',
'#24B3FF','#24C7FF','#24DEFF','#24F8FF','#24FFF8','#24FFEE')
# NOTE: Probably one of the fishy parts (1/2)
# Button to select/de-select all
observe({
if (input$selectall_sankey > 0) {
if (input$selectall_sankey %% 2 == 0){
updateCheckboxGroupInput(session = session,
inputId = "schoolSelect",
choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
),
selected = c(choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
))
)
} else {
updateCheckboxGroupInput(session = session,
inputId = "schoolSelect",
choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
),
selected = c())
}}
})
# Plot
output$gender_sankey <- renderPlotly({
hom_stud <- hom_stud[hom_stud$UltimoGradoEstudios %in% input$schoolSelect,]
muj_stud <- muj_stud[muj_stud$UltimoGradoEstudios %in% input$schoolSelect,]
node_x <- c(node_x[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
node_y <- c(node_y[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
colors <- c(colors[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
fig <- plot_ly(
type = "sankey",
orientation = "h",
arrangement = 'snap',
node = list(
label = nodes,
color = colors,
x = node_x,
y = node_y,
pad = 15,
thickness = 20,
line = list(
color = "black",
width = 0.5
)
),
link = list(
source = c(hom_stud$src, muj_stud$src),
target = c(hom_stud$tgt, muj_stud$tgt),
value = c(hom_stud$count, muj_stud$count)
)
)
fig <- fig %>% layout(
font = list(
size = 10
)
) %>% config(modeBarButtons = list(list('toImage'), list('resetScale2d')), displaylogo = F)
})
Packages used: shiny, shinydashboard, shinythemes and plotly (same versions both locally and on server). dplyr, magrittr, and ggplot2 are on the same version as well.
R version in my computer is 4.0.2, R version in the server is 3.6.3
It's not the cleanest implementation, specially on the button part, but it works perfectly locally! Note that I marked the sketchy practices I used, and where the problem could lie. Basically the default node order wasn't cutting it because the position on the right hand side itself contains information (Doctorado > Maestría > Licenciatura> ...), so I kind of forced a different order for the nodes through node_x and node_y. The thing is, the implementation works locally! What could be the reason for it not to work online?
I am developing a shiny app which steps through time by each hour and shows the precipitation on a mapdeck map. I read in the weather data for the entire day and using reactivity filtering the data for the hour and plotting them as scatterplot using mapdeck_update to update the data. The color scale changes whenever the map updates based on the range of data in that hour. What I want is a static color scale based on the data range for the day. Is it possible?
I have tried using manual colors but for some reason they are not working
library(mapdeck)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
wx_map <- mapdeck(data=NULL,token = Sys.getenv("MAPBOX_API_TOKEN"),style = 'mapbox://styles/mapbox/dark-v9',zoom = 6, location = c(-97,24.5))
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(data=wx_dt,lon = "Center.Longitude",lat = "Center.Latitude",radius = 15000,fill_colour = "vil_int_36",legend = TRUE,layer_id = "wxlyr",update_view = FALSE,focus_layer=FALSE)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
Notice how the range of color scale in the legend changes but the color of the dots stay almost the same. I want the color to represent the min-max of the entire data set (not just the hour) so that I can see change in intensity while stepping through each hour. Thank you.
Good question; you're right you need to create a manual legend so it remains static, otherwise it will update each time the values in the plot update.
The manual legend needs to use the same colours as the map. The map gets coloured by library(colourvalues). So you can use this to make the colours outside of the map, then use the results as the manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
Now this js_legend object is in the correct JSON format for the map to render it as a legend
js_legend
# {"fill_colour":{"colour":["#440154FF","#3B528BFF","#21908CFF","#5DC963FF","#FDE725FF"],"variable":["20.00","23.50","27.00","30.50","34.00"],"colourType":["fill_colour"],"type":["category"],"title":[""],"css":[""]}}
Here it is in your shiny
library(mapdeck)
library(shiny)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
## create a manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
### --------------------------------
wx_map <- mapdeck(
style = 'mapbox://styles/mapbox/dark-v9'
, zoom = 6
, location = c(-97,24.5)
)
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(
data = wx_dt
, lon = "Center.Longitude"
, lat = "Center.Latitude"
, radius = 15000
, fill_colour = "vil_int_36"
, legend = js_legend
, layer_id = "wxlyr"
, update_view = FALSE
, focus_layer = FALSE
)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
I'm having trouble using columns from data originating in wide format as dynamic inputs to a Shiny map app.
In the app I'm hoping to be able to:
select a parameter of point data (sample data below: 16 locations, 6 parameters) in a drop down type menu and adjust the symbol size to represent the selected parameter's absolute values with a slider (to help visualize positive and negative differences from zero)
with any parameter selected, retain ability to see all parameters (the columns) in mapview's popup feature (mapview turns the columns into rows for the popup). It seems a filtered long format data.frame would be missing data from the popup/viewing perspective
retain the (non absolute) original value on the mouseover hover label (eg the -7.3 in the image)
In addition to having those features, I don't know if/where I need to set reactive wrapper(s)? Or, maybe I could do everything more easily with another map-centric library (even though mapview is awesome for many things)?
My attempts are commented out below - the UI works as intended except without drop down selectability - the app is limited to only one working dropdown parameter with mapview(df["param1"] and cex = param1 * input$cex.
Here's the reproducible app.r:
library(tidyverse)
library(sf)
library(shiny)
library(shinydashboard)
library(leaflet)
library(mapview)
## sample earthquake data ##
set.seed(6)
lat <- rnorm(16,-34, 9)
lon <- rnorm(16,-67,.3)
param1 <- rnorm(16, 10, 40) %>% round(1)
param2 <- rnorm(16, 25, 3) %>% round(1)
param3 <- rnorm(16, -18, 10) %>% round(1)
param4 <- rnorm(16, -200, 93) %>% round(1)
param5 <- rnorm(16, 0.1, .09) %>% round(1)
param6 <- rnorm(16, 417, 33) %>% round(1)
df <- data.frame(lat, lon, param1, param2, param3, param4, param5,
param6)
df <- st_as_sf(df, coords = c("lon", "lat"), crs = 4326)
paramchoices <- colnames(df) %>% .[.!="geometry"]
colorpal = mapviewPalette("mapviewSpectralColors")
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput("cex", "Symbol Size",
min = 0.000001, max = 10, value = 1, step = 0.000001
),
selectizeInput(
"parameter", "Earthquake Parameter", choices = paramchoices,
selected = c("param1"),
multiple = FALSE)
),
dashboardBody(
tags$style(type = "text/css", "#mapplot {height: calc(100vh - 80px) !important;}"),
leafletOutput("mapplot")
)
)
server <- function(input, output) {
# df <- reactive ({
# df %>% mutate(selectedparameter = input$parameter,
# selectedparameter_abs = abs(selectedparameter))
# })
output$mapplot <- renderLeaflet({
m <- mapview(df["param1"], #mouseover column
#m <- mapview(df["selectedparameter"],
cex = param1 * input$cex, #marker size column
#cex = df$selectedparameter_abs * input$cex,
col.regions = colorpal(100),
alpha.regions = 0.3,
legend = TRUE,
popup = popupTable(df),
layer.name = "selectedparam[unit]")
m#map
}
)}
shinyApp(ui, server)
more info related to the absolute value part - Point color and symbol size based on different variables in mapview
thank you.
I want to implement drill down heat map of USA.
Something like : Highchart link
But I want to display my own data in the given drill down heat map in
R + shiny.
I am unable to understand how to get my data to work with the given example. I was able to implement the given example on R shiny but I don't know how to get my own data for states and county .
I have data in excel format which I want to show on the maps.
I am relatively new to JS and CSS , I think the challenge is in this only.
I have no knowledge of AJAX , and if it can be implemented without it then it would be great.
Someone suggested me to use JSON file to import my own data , but I cannot do it.
There is now an R package "leafdown" available on github, which provides drilldown functionality. It can be found here: https://hoga-it.github.io/leafdown/index.html.
A basic example:
devtools::install_github("hoga-it/leafdown")
library(leafdown)
library(leaflet)
library(shiny)
library(dplyr)
library(shinyjs)
ger1 <- raster::getData(country = "Germany", level = 1)
ger2 <- raster::getData(country = "Germany", level = 2)
ger2#data[c(76, 99, 136, 226), "NAME_2"] <- c(
"Fürth (Kreisfreie Stadt)",
"München (Kreisfreie Stadt)",
"Osnabrück (Kreisfreie Stadt)",
"Würzburg (Kreisfreie Stadt)"
)
spdfs_list <- list(ger1, ger2)
ui <- shiny::fluidPage(
tags$style(HTML(".leaflet-container {background: #ffffff;}")),
useShinyjs(),
actionButton("drill_down", "Drill Down"),
actionButton("drill_up", "Drill Up"),
leafletOutput("leafdown", height = 600),
)
# Little helper function for hover labels
create_labels <- function(data, map_level) {
labels <- sprintf(
"<strong>%s</strong><br/>%g € per capita</sup>",
data[, paste0("NAME_", map_level)], data$GDP_2014
)
labels %>% lapply(htmltools::HTML)
}
server <- function(input, output) {
my_leafdown <- Leafdown$new(spdfs_list, "leafdown", input)
update_leafdown <- reactiveVal(0)
observeEvent(input$drill_down, {
my_leafdown$drill_down()
update_leafdown(update_leafdown() + 1)
})
observeEvent(input$drill_up, {
my_leafdown$drill_up()
update_leafdown(update_leafdown() + 1)
})
output$leafdown <- renderLeaflet({
update_leafdown()
meta_data <- my_leafdown$curr_data
curr_map_level <- my_leafdown$curr_map_level
if (curr_map_level == 1) {
data <- meta_data %>% left_join(gdp_2014_federal_states, by = c("NAME_1" = "Federal_State"))
} else {
data <- meta_data %>% left_join(gdp_2014_admin_districts, by = c("NAME_2" = "Admin_District"))
}
my_leafdown$add_data(data)
labels <- create_labels(data, curr_map_level)
my_leafdown$draw_leafdown(
fillColor = ~ colorNumeric("Blues", GDP_2014)(GDP_2014),
weight = 2, fillOpacity = 0.8, color = "grey", label = labels,
highlight = highlightOptions(weight = 5, color = "#666", fillOpacity = 0.7)
) %>%
addLegend("topright",
pal = colorNumeric("Blues", data$GDP_2014),
values = data$GDP_2014,
title = "GDP per capita (2014)",
labFormat = labelFormat(suffix = "€"),
opacity = 1
)
})
}
shinyApp(ui, server)
Is it possible with leaflet.js to create drill-down functionality, i.e. similar to http://jvectormap.com/examples/drill-down/? I imagine there is some plugin that would make this possible. If so, could you point me to an example or provide basic code?
I've done some searching on Google and the leaflet documentation, e.g. http://leafletjs.com/reference.html and http://leafletjs.com/plugins.html, but cannot find anything.
Edit: I found this useful post: https://github.com/rstudio/leaflet/issues/41. I'm using the leaflet package in R provided by RStudio. I've got a drill-down choropleth from country to state with an info control. It still needs a ton of work, though. Anyone who cares to help, see https://github.com/efh0888/leafletDrilldown. The README has all the info you'll need. You can also see a live app at https://efh0888.shinyapps.io/leafletDrilldown. Thanks!
See the Choropleth example for how to do the click⇢fit bounds technique with Leaflet.
There is now an R package "leafdown" available on github, which provides drilldown functionality. It can be found here: https://hoga-it.github.io/leafdown/index.html.
A basic example:
devtools::install_github("hoga-it/leafdown")
library(leafdown)
library(leaflet)
library(shiny)
library(dplyr)
library(shinyjs)
ger1 <- raster::getData(country = "Germany", level = 1)
ger2 <- raster::getData(country = "Germany", level = 2)
ger2#data[c(76, 99, 136, 226), "NAME_2"] <- c(
"Fürth (Kreisfreie Stadt)",
"München (Kreisfreie Stadt)",
"Osnabrück (Kreisfreie Stadt)",
"Würzburg (Kreisfreie Stadt)"
)
spdfs_list <- list(ger1, ger2)
ui <- shiny::fluidPage(
tags$style(HTML(".leaflet-container {background: #ffffff;}")),
useShinyjs(),
actionButton("drill_down", "Drill Down"),
actionButton("drill_up", "Drill Up"),
leafletOutput("leafdown", height = 600),
)
# Little helper function for hover labels
create_labels <- function(data, map_level) {
labels <- sprintf(
"<strong>%s</strong><br/>%g € per capita</sup>",
data[, paste0("NAME_", map_level)], data$GDP_2014
)
labels %>% lapply(htmltools::HTML)
}
server <- function(input, output) {
my_leafdown <- Leafdown$new(spdfs_list, "leafdown", input)
update_leafdown <- reactiveVal(0)
observeEvent(input$drill_down, {
my_leafdown$drill_down()
update_leafdown(update_leafdown() + 1)
})
observeEvent(input$drill_up, {
my_leafdown$drill_up()
update_leafdown(update_leafdown() + 1)
})
output$leafdown <- renderLeaflet({
update_leafdown()
meta_data <- my_leafdown$curr_data
curr_map_level <- my_leafdown$curr_map_level
if (curr_map_level == 1) {
data <- meta_data %>% left_join(gdp_2014_federal_states, by = c("NAME_1" = "Federal_State"))
} else {
data <- meta_data %>% left_join(gdp_2014_admin_districts, by = c("NAME_2" = "Admin_District"))
}
my_leafdown$add_data(data)
labels <- create_labels(data, curr_map_level)
my_leafdown$draw_leafdown(
fillColor = ~ colorNumeric("Blues", GDP_2014)(GDP_2014),
weight = 2, fillOpacity = 0.8, color = "grey", label = labels,
highlight = highlightOptions(weight = 5, color = "#666", fillOpacity = 0.7)
) %>%
addLegend("topright",
pal = colorNumeric("Blues", data$GDP_2014),
values = data$GDP_2014,
title = "GDP per capita (2014)",
labFormat = labelFormat(suffix = "€"),
opacity = 1
)
})
}
shinyApp(ui, server)