Related
I'm currently trying to make a Shiny app for Leaflet cards with simple translations. Each leaflet card has several base groups that are linked to different variables. To avoid re-rendering the leaflet maps every time the base group changes, I have adopted a function I found here which only changes the fill of the polygons.
As long as I only use one language, the app works without problems, but when multiple translations options are implemented, the app crashes. The problem seems to occur when I try to link input$map_groups to variables needed for colouring.
My code looks like this:
library(shiny)
library(shinyWidgets)
library(leaflet)
library(sf)
library(dplyr)
library(shiny.i18n)
#--- Loading Generic Shape File For Demonstration
shape <- st_read(system.file("shape/nc.shp", package = "sf"),
stringsAsFactors = FALSE) %>%
#--- Mutating Two Variables To Factors As My Map Uses Factors
mutate(One = as.factor(SID74), Two = as.factor(SID79)) %>%
#--- Keep Just This Three Variables
select(c(CNTY_ID, One, Two))
#--- Color Palette For Filling Polygons
scale.color <- colorFactor(palette = "RdYlBu", levels = seq(1:60))
#--- Loading And Rgistering Translation File
lang <- Translator$new(translation_json_path = "./translations.json")
lang$set_translation_language("gb")
language <- c("English", "Deutsch", "Français" , "Español")
#--- Naming Vector For Base Groups And Related Variables
layer_calls <- setNames(c('One', 'Two'), c("First", "Second"))
#--- A Function For Recoloring An Existing Polygon And Related JS-Code
#----- Source: https://github.com/rstudio/leaflet/issues/496#issuecomment-650122985
setShapeStyle <- function(map, data = getMapData(map), layerId, stroke = NULL, color = NULL, weight = NULL,
opacity = NULL, fill = NULL, fillColor = NULL, fillOpacity = NULL, dashArray = NULL,
smoothFactor = NULL, noClip = NULL, options = NULL){
options <- c(list(layerId = layerId),
options,
filterNULL(list(stroke = stroke, color = color, weight = weight, opacity = opacity,
fill = fill, fillColor = fillColor, fillOpacity = fillOpacity,
dashArray = dashArray, smoothFactor = smoothFactor, noClip = noClip)))
# Evaluate All Options
options <- evalFormula(options, data = data)
options <- do.call(data.frame, c(options, list(stringsAsFactors = FALSE)))
layerId <- options[[1]]
style <- options[-1] # drop layer column
leaflet::invokeMethod(map, data, "setStyle", "shape", layerId, style);
}
leafletjs <- tags$head(
tags$script(HTML(
'
window.LeafletWidget.methods.setStyle = function(category, layerId, style){
var map = this;
if (!layerId){
return;
} else if (!(typeof(layerId) === "object" && layerId.length)){ // in case a single layerid is given
layerId = [layerId];
}
//convert columnstore to row store
style = HTMLWidgets.dataframeToD3(style);
//console.log(style);
layerId.forEach(function(d,i){
var layer = map.layerManager.getLayer(category, d);
if (layer){ // or should this raise an error?
layer.setStyle(style[i]);
}
});
};
'
)))
#--- Defining UI
ui <- fluidPage(
leafletjs,
usei18n(lang),
pickerInput(inputId = 'selected_language', width = 125,
choices = c("gb", "de", "fr", "es"),
selected = lang$get_key_translation()),
leafletOutput("map")
)
#--- Defining Server Logic
server <- function(input, output, session){
output$map <- renderLeaflet({
leaflet(data = shape) %>%
#--- Initial Unfilled Polygon Map
addPolygons(layerId = ~CNTY_ID, stroke = TRUE, color = "white", weight = 1.25,
highlightOptions = highlightOptions(stroke = 5, weight = 10)) %>%
#--- Initial Layer Controls
addLayersControl(baseGroups = lang$t(names(layer_calls)))
})
#--- Filling Polygons Based On Base Layer-Variable After Translation
observe({
req(input$selected_language)
update_lang(session, input$selected_language)
leafletProxy("map", data = shape) %>%
#--- This Part Always Crashes Shiny!!!
setShapeStyle(layerId = ~CNTY_ID, fillOpacity = 1)#, fillColor = ~scale.color(get(layer_calls[lang$t(input$map_groups)])))
})
}
# Run the application
shinyApp(ui = ui, server = server)
My basic translation scheme would be provided by a JSON file which looks like this:
{
"languages": [
"gb",
"de",
"fr",
"es"
],
"translation": [
{
"gb": "First",
"de": "Erste",
"fr": "Premier",
"es": "Primera"
},
{
"gb": "Second",
"de": "Zweite",
"fr": "Deuxième",
"es": "Segundo"
}
]
}
In my One-Langue-App I can simply use , fillColor = ~scale.color(get(layer_calls[[input$map_groups]])) to trigger a recoloring after the base group has been changed. Unfortunately, I have no idea how to connect the selected base group to a call of the needed variable to trigger the recoloring. Any kind of help is greatly appreciated!
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 new here, so hopefully I did a good job putting together a good question!
What the reproducible code will produce is a map of North Carolina, broken out evenly to four geographically "even" regions. Imagine this is being used by a Sales Manager who is assigning territory to his salespeople.
What this does now: Right now, this map does the following: Allows you to select a region, which then creates two tables. The first is just a straight data dump of the accompanying features associated with that county. The second table then groups that data together to produce sums of the data for each region.
What I want this to do: Let's say the person using this wants to assign new territory. Each of those territories are assigned a color. A is red, B is blue, C is green, and D is yellow. So they select an input button for "A" and then he begins to click on counties, which turn red, and all do all the table aggregations at the bottom. Once they're done with that, they select "B", and so on. So then the table at the bottom looks like:
+-----------+--------------------+--------------------+
| Territory | Leads | Sales |
+-----------+--------------------+--------------------+
| A | selected agg value | selected agg value |
| B | selected agg value | selected agg value |
| C | selected agg value | selected agg value |
| D | selected agg value | selected agg value |
+-----------+--------------------+--------------------+
Does that make sense?
library(tigris)
library(mapview)
library(mapedit)
library(leaflet)
library(dplyr)
library(DT)
north_carolina <- counties("north carolina") %>% st_as_sf() %>% arrange(INTPTLON, INTPTLAT) %>% dplyr::select(NAMELSAD, geometry) %>% rename(county_name = NAMELSAD) %>%
mutate(territory = rep(letters[1:4], each = 25), leads = sample(100:1000, 100, replace = TRUE), sales = sample(100:1000, 100, replace = TRUE))
ui <- fluidPage(
h3("Map"),
selectModUI(id = "map_select"),
# Datatable Output
h3("Table"),
dataTableOutput(outputId = "BaseTable"),
h3("Reactive Output"),
dataTableOutput(outputId = "ReactTable")
)
server <- function(input, output) {
leafmap <- reactive({leaflet() %>%
addProviderTiles(providers$Stamen.Toner) %>%
addPolygons(data = north_carolina, fillOpacity = "red",
fillColor = "grey",
weight = 5,
opacity = 5,
color = "black") %>%
leafem::addFeatures(data=north_carolina,label = ~htmltools::htmlEscape(territory),
layerId = ~seq_len(length(st_geometry(north_carolina))))
})
selectMod <- function(input, output, session, leafmap,
styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4),
styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7))
{
print("*** custom selectMod")
output$map <- leaflet::renderLeaflet({
mapedit:::add_select_script(leafmap, styleFalse = styleFalse, styleTrue = styleTrue,
ns = session$ns(NULL))
})
id <- "mapedit"
select_evt <- paste0(id, "_selected")
df <- data.frame()
selections <- reactive({
id <- as.character(input[[select_evt]]$id)
if (length(df) == 0) {
# Initial case, first time module is called.
# Switching map, i.e. subsequent calls to the module.
# Note that input[[select_evt]] will always keep the last selection event,
# regardless of this module being called again.
df <<- data.frame(id = character(0), selected = logical(0),
stringsAsFactors = FALSE)
} else {
loc <- which(df$id == id)
if (length(loc) > 0) {
df[loc, "selected"] <<- input[[select_evt]]$selected
} else {
df[nrow(df) + 1, ] <<- c(id, input[[select_evt]]$selected)
}
}
return(df)
})
return(selections)
}
rval <- reactiveValues(
sel = reactive({}),
selectnum = NULL,
base_table = north_carolina %>%
st_set_geometry(NULL) %>%
dplyr::slice(0)
)
# Create selectMod
observeEvent(leafmap(),
rval$sel <- callModule(selectMod, "map_select", leafmap())
)
# Subset the table based on the selection
observeEvent(rval$sel(), {
# The select module returns a reactive
gs <- rval$sel()
# Filter for the county data
rval$selectnum <- as.numeric(gs[which(gs$selected == TRUE), "id"])
rval$base_table <- north_carolina %>%
st_set_geometry(NULL) %>%
dplyr::slice(rval$selectnum)
rval$react_table <- rval$base_table %>% group_by(territory) %>% summarise(leads = sum(leads), sales = sum(sales))
})
# Create a datatable
output$BaseTable <- renderDataTable({
datatable(rval$base_table, options = list(scrollX = TRUE))
})
output$ReactTable <- renderDataTable({
datatable(rval$react_table)
})
}
I am creating a Shiny dashboard with a dataframe of start longitude/latitude and end longitude/latitude cooridnated that I have plotted in R using the leaflet package:
`m=leaflet()%>%
addTiles() %>%
addMarkers(lng=(data$Start_long[i:j]), lat=(data$Start_lat[i:j]),popup="Start") %>%
addCircleMarkers(lng=(data$End_long[i:j]), lat=(data$End_lat[i:j]),popup="End",clusterOptions=markerClusterOptions())`
I was wondering if there was a way to join the start and end coordinated by public transport routes (maybe through google maps API or in-library functions or failing that, join the coordinates by a straight line?
You can use my googleway package to both get the directions/routes, and plot it on a Google map
To use Google's API you need a valid key for each API you want to use. In this case you'll want a directions key, and for plotting the map you'll want a maps javascript key
(You can generate one key and enable it for both APIs if you wish)
To call the Directions API and plot it in R, you can do
library(googleway)
api_key <- "your_directions_api_key"
map_key <- "your_maps_api_key"
## set up a data.frame of locations
## can also use 'lat/lon' coordinates as the origin/destination
df_locations <- data.frame(
origin = c("Melbourne, Australia", "Sydney, Australia")
, destination = c("Sydney, Australia", "Brisbane, Australia")
, stringsAsFactors = F
)
## loop over each pair of locations, and extract the polyline from the result
lst_directions <- apply(df_locations, 1, function(x){
res <- google_directions(
key = api_key
, origin = x[['origin']]
, destination = x[['destination']]
)
df_result <- data.frame(
origin = x[['origin']]
, destination = x[['destination']]
, route = res$routes$overview_polyline$points
)
return(df_result)
})
## convert the results to a data.frame
df_directions <- do.call(rbind, lst_directions)
## plot the map
google_map(key = map_key ) %>%
add_polylines(data = df_directions, polyline = "route")
And similarly in a Shiny app
library(shiny)
library(shinydashboard)
library(googleway)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
textInput(inputId = "origin", label = "Origin"),
textInput(inputId = "destination", label = "Destination"),
actionButton(inputId = "getRoute", label = "Get Rotue"),
google_mapOutput("myMap")
)
)
server <- function(input, output){
api_key <- "your_directions_api_key"
map_key <- "your_maps_api_key"
df_route <- eventReactive(input$getRoute,{
print("getting route")
o <- input$origin
d <- input$destination
return(data.frame(origin = o, destination = d, stringsAsFactors = F))
})
output$myMap <- renderGoogle_map({
df <- df_route()
print(df)
if(df$origin == "" | df$destination == "")
return()
res <- google_directions(
key = api_key
, origin = df$origin
, destination = df$destination
)
df_route <- data.frame(route = res$routes$overview_polyline$points)
google_map(key = map_key ) %>%
add_polylines(data = df_route, polyline = "route")
})
}
shinyApp(ui, server)
You can addPolylines() to the map.
It takes two vectors as arguments, one for the lat and one for the lng, where each row is a 'waypoint'.
It's difficult to help you without knowing the structure of your data.
MRE:
library(leaflet)
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
"))
leaflet() %>%
addTiles() %>%
addPolylines(lat = cities$Lat, lng = cities$Long)
I use "for loop" to solve such problem,just draw polylines one by one.
(sorry for my Chinese expression ^_^)
for examply :
for(i in 1:nrow(sz)){
if(i<=nrow(sz) ){
a <- as.numeric(c(sz[i,c(8,10)]));
b <- as.numeric(c(sz[i,c(9,11)]));
A <- A %>% addPolylines(a,b,group=NULL,weight = 1,color = "brown",
stroke = TRUE,fill = NULL,opacity = 0.8)}
or like a more complex one
for(j in 0:23){if(j<=23)
#j--切每小时数据
j1 <- as.character(paste(j,"点",sep=''))
sz <- sz121[sz121$h==j,]
sz_4 <- sz121[sz121$bi_state==4 &sz121$h==j ,]
sz_8 <- sz121[sz121$bi_state==8&sz121$h==j,]
#还原A
A <- leaflet(sz121) %>% amap() %>% addLabelOnlyMarkers(~s_lon,~s_lat) %>%
addLegend(title=j1,colors=NULL,labels =NULL,position="topleft")
A <- A %>%addCircleMarkers(data=sz_8,~s_lon,~s_lat,color="orange",fill=TRUE,fillColor = "red", opacity = 1,fillOpacity=0.8,
weight =1,radius = 10) %>%addCircleMarkers(data=sz_4,~s_lon,~s_lat,color="black",fill=TRUE,fillColor = "red",
opacity = 1,fillOpacity=0.8,weight =5,radius = 10 ) %>%
addCircleMarkers(data=sz_8,~e_lon,~e_lat,color="orange",fill=TRUE,fillColor = "blue", opacity = 1,fillOpacity=0.8,weight=1,radius = 10) %>%
addCircleMarkers(data=sz_4,~e_lon,~e_lat,color="black",fill=TRUE,fillColor = "blue", opacity = 1,fillOpacity=0.8,weight =5,radius = 10 )
for(i in 1:nrow(sz)){
#i--画路径
if(i<=nrow(sz) ){
a <- as.numeric(c(sz[i,c(8,10)]));
b <- as.numeric(c(sz[i,c(9,11)]));
A <- A %>% addPolylines(a,b,group=NULL,weight = 1,color = "brown",stroke = TRUE,fill = NULL,opacity = 0.8)
}
if(i==nrow(sz)){print(A)}
}
Sys.sleep(3)
}
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)