Drawing arbitrary lines on a highchart map in R (library highcharter) - r

I am drawing a highcharts map using the highcharter package in R. I added already some points (cities) and want to link them by drawing an additionnal beeline using the world map-coordinates.
I already managed to draw the beelines by first drawing the map, then hovering over the cities which shows me the plot-coordinates, and then redrawing the plot using the aforementioned plot-coordinates. (Watch out: I used the PLOT-coordinates and my goal is to use directly the WORLD MAP-coordinates.)
If you only have 1 or two cities, it's not a big deal. But if you have like 100 cities/points, it's annoying. I guess the answer will be something like here: Is it possible to include maplines in highcharter maps?.
Thank you!
Here my code:
library(highcharter)
library(tidyverse)
# cities with world coordinates
ca_cities <- data.frame(
name = c("San Diego", "Los Angeles", "San Francisco"),
lat = c(32.715736, 34.052235, 37.773972), # world-map-coordinates
lon = c(-117.161087, -118.243683, -122.431297) # world-map-coordinates
)
# path which I create AFTER the first drawing of the map as I get the
# plot-coordinates when I hover over the cities.
path <- "M669.63,-4963.70,4577.18,-709.5,5664.42,791.88"
# The goal: the path variable above should be defined using the WORLD-
# coordinates in ca_cities and not using the PLOT-coordinates.
# information for drawing the beeline
ca_lines <- data.frame(
name = "line",
path = path,
lineWidth = 2
)
# construct the map
map <- hcmap("countries/us/us-ca-all", showInLegend = FALSE) %>%
hc_add_series(data = ca_cities, type = "mappoint", name = "Cities") %>%
hc_add_series(data = ca_lines, type = "mapline", name = "Beeline", color = "blue")
map
See picture here

After several hours, I found an answer to my problem. There are maybe easier ways, but I'm going to post my version using the rgdal-package.
The idea is to convert first the world map-coordinates to the specific map's coordinate system (ESRI) and then back-transform all adjustments from highcharts:
library(highcharter)
library(tidyverse)
library(rgdal) # you also need rgdal
# cities with world coordinates
ca_cities <- data.frame(
name = c("San Diego", "Los Angeles", "San Francisco"),
lat = c(32.715736, 34.052235, 37.773972),
lon = c(-117.161087, -118.243683, -122.431297)
)
# pre-construct the map
map <- hcmap("countries/us/us-ca-all", showInLegend = FALSE)
# extract the transformation-info
trafo <- map$x$hc_opts$series[[1]]$mapData$`hc-transform`$default
# convert to coordinates
ca_cities2 <- ca_cities %>% select("lat", "lon")
coordinates(ca_cities2) <- c("lon", "lat")
# convert world geosystem WGS 84 into transformed crs
proj4string(ca_cities2) <- CRS("+init=epsg:4326") # WGS 84
ca_cities3 <- spTransform(ca_cities2, CRS(trafo$crs)) #
# re-transform coordinates according to the additionnal highcharts-parameters
image_coords_x <- (ca_cities3$lon - trafo$xoffset) * trafo$scale * trafo$jsonres + trafo$jsonmarginX
image_coords_y <- -((ca_cities3$lat - trafo$yoffset) * trafo$scale * trafo$jsonres + trafo$jsonmarginY)
# construct the path
path <- paste("M",
paste0(paste(image_coords_x, ",", sep = ""),
image_coords_y, collapse = ","),
sep = "")
# information for drawing the beeline
ca_lines <- data.frame(
name = "line",
path = path,
lineWidth = 2
)
# add series
map <- map %>%
hc_add_series(data = ca_cities, type = "mappoint", name = "Cities") %>%
hc_add_series(data = ca_lines, type = "mapline", name = "Beeline", color = "blue")
map

Related

Colour specific countries on a worldmap and adding mappoint cities

I want to design a worldmap to show from which country and which city the participants to my survey come from. I used the highcharter package.
First part is : colour the countries --> it worked well ! A scale is created from 0 to 1.
Second part is : adding the cities --> the points are created but the countries colored in blue disappeared ! The scale has changed and is now induced from cities.
I try to change the order of my code but nothing is working.
library(dplyr)
library(maps)
library(magrittr)
# I use the dataset called iso3166 from the {maps} package and rename it date
dat <- iso3166
head(dat)
# I rename the variable a3 by iso-a3
dat <- rename(dat, "iso-a3" = a3)
head(dat)
# I create a vector with the countries I want to colour
part1X_countries <- c("CHE", "FRA", "USA", "GBR", "CAN", "BRA")
dat$part1X <- ifelse(dat$`iso-a3` %in% part1X_countries, 1, 0)
head(dat)
# I add the name of cities with geographical coordinates
cities <- data.frame(
name = c("St Gallen", "Fort Lauderdale", "Paris", "Nottingham", "Winnipeg", "Chicago", "Leeds", "Montréal", "New Rochelle", "São Paulo", "Saint-Genis-Pouilly", "Canterbury"),
lat = c(47.42391, 26.122438, 48.866667, 52.950001, 49.8955, 41.881832, 53.801277, 45.5016889, 40.9232, -23.5489, 46.24356, 51.279999),
lon = c(9.37477, -80.137314, 2.333333, -1.150000, -97.1383, -87.623177, -1.548567, -73.567256, -73.7793, -46.6388, 6.02119, 1.080000))
# I create my worldmap with countries and cities
worldmap <- hcmap(
map = "custom/world-highres3", # high resolution world map
data = dat, # name of dataset
value = "part1X",
joinBy = "iso-a3",
showInLegend = FALSE, # hide legend
download_map_data = TRUE
) %>%
hc_add_series(
data = cities,
type = "mappoint",
name = "Cities"
) %>%
hc_title(text = "Representation of participants by country")```
You need to define a colorkey and add a color axis for the hcmap. The below code keeps the colors from the countries and has the name of the countries added on top as black map points.
worldmap <- hcmap(
map = "custom/world-highres3", # high resolution world map
data = dat, # name of dataset
value = "part1X",
joinBy = "iso-a3",
colorKey = "value",
showInLegend = F, # hide legend
download_map_data = TRUE) %>%
hc_colorAxis(min = min(dat$part1X),
max = max(dat$part1X)) %>%
hc_add_series(
data = cities,
type = "mappoint",
name = "Cities",
dataLabels = list(enabled = TRUE, format = '{point.name}'),
latField = "lat",
longField = "lon",
# color = "color"
valueField = "part1X"
) %>%
hc_title(text = "Representation of participants by country")
worldmap

Find the middle point between two markers in Leaflet

I would like to be able to find the centre point between two markers on a map (example below). Is there a function in leaflet or in another package that allows this? Thank you in advance
coor_zone6 <- c(3.16680, 3.16176, 42.46667, 42.46997)
matrice_coord_zone6 <- matrix(coor_zone6, nrow=2, ncol = 2)
colnames(matrice_coord_zone6) <- c("long", "lat")
matrice_coord_zone6 <- data.frame(matrice_coord_zone6)
matrice_coord_zone6$name <- c("M_1","M_3")
leaflet(matrice_coord_zone6) %>%
addMouseCoordinates(epsg = NULL, proj4string = NULL, native.crs = FALSE) %>%
addProviderTiles("Esri.WorldImagery") %>%
addMarkers(lng = ~long, lat = ~lat) %>%
addPolylines(~long, ~lat, popup = ~name)
I have not found any leaflet function that can perform this calculation, but it is not difficult to find the intermediate point between both coordinates.
You must add both longitudes and divide them by 2, you will have to do the same with both latitudes.
In your case, if I have not misunderstood, your first coordinate is (3.16680, 42.46667) and your second coordinate is (3.16176, 42.46997) so the calculation would be as follows:
(3,16680 + 3,16176) / 2 = 3,16428
(42,46667 + 42,46997) / 2 = 42,46832
So the intermediate point would be the following: (3.16428, 42.46832)

How to keep the only intersection of the spatial features & remove everything outside of a boundary?

I am trying to get rid of the spatial geometry that falls outside of the shapefile boundary I read. Is it possible to do this without manual software like Photoshop? Or me manually removing the tracts which span outside of the city's boundries. For example, I took out 14 tracts, this is there result:
I have provided all of the subset of the data and the key to test it yourself. Code script is below, and the dataset is https://github.com/THsTestingGround/SO_geoSpatial_crop_Quest.
I have done st_intersection(gainsville_df$Geomtry$x, gnv_poly$geometry) after I converted Geomtry to the sf, but I don't know what to do next to get rid of those portions.
library(sf)
library(tigris)
library(tidyverse)
library(tidycensus)
library(readr)
library(data.table)
#reading the shapefile
gnv_poly <- sf::st_read("PATH\\GIS_cgbound\\cgbound.shp") %>%
sf::st_transform(crs = 4326) %>%
sf::st_polygonize() %>%
sf::st_union()
#I have taken the "geometry" of latitude and longitude because it was corrupting my csv, but we can rebuild like so
gnv_latlon <- readr::read_csv("new_dataframe_data.csv") %>%
dplyr::select(ID,
Latitude,
Longitude,
Location) %>%
dplyr::mutate(Location = gsub(x= Location, pattern = "POINT \\(|\\)", replacement = "")) %>%
tidyr::separate(col = "Location", into = c("lon", "lat"), sep = " ") %>%
sf::st_as_sf(coords = c(4,5)) %>%
sf::st_set_crs(4326)
#then you can match the ID from gnv_latlon to
gainsville_df <- fread("new_dataframe_data.csv", drop = c("Latitude","Longitude", "Census Code"))
gainsville_df <- merge(gnv_latlon, gainsville_df, by = "ID")
#remove latitude and longitude points that fall outside of the polygon
dplyr::mutate(gainsville_df, check = as.vector(sf::st_intersects(x = gnv_latlon, y = gnv_poly, sparse = FALSE))) -> outliers_before
sf::st_filter(x= outliers_before, y= gnv_poly, predicate= st_intersects) -> gainsville_df
#Took out my census api key because of a feed back from a SO member. Please add a comment
#if you would like my census key.
#I use this function from tidycensus to retrieve the country shapfiles.
alachua <- tidycensus::get_acs(state = "FL", county = "Alachua", geography = "tract", geometry = T, variables = "B01003_001")
gainsville_df$Geomtry <- NULL
gainsville_df$Geomtry <- alachua$geometry[match(as.character(gainsville_df$`Geo ID`), alachua$GEOID)]
#gets us the first graph with bounry
ggplot() +
geom_sf(data = gainsville_df,aes(geometry= Geomtry, fill= Population), alpha= 0.2) +
coord_sf(crs = "+init=epsg:4326")+
geom_sf(data= gnv_poly) #with alpha added, we get the transparent boundary
Now I would like to get the second image without doing any future manual manipulation.
From this.....
to this, possible ?
Found this Compare spatial polygons and keep or delete common boundaries in R but the person here wanted to remove just the boundaries from one shapefile. And i tried to manipulate it to nothing.
EDIT Here is what I've tried after SymbolixAU direction, but my idx variable is number from 1:7
fl <- sf::st_read("PATH\\GIS_cgbound\\cgbound.shp") %>% sf::st_transform(crs = 4326)
gainsville_df$Geomtry <- sf::st_as_sf(gainsville_df$Geomtry) %>% sf::st_transform(crs= 4326)
#normal boundry plot
plot( fl[, "geometry"] )
# And we can make a boundary by selecting some of the goemetries and union-ing them
boundary <- fl[ gnv_poly$geometry %in% gainsville_df$Geomtry, ]
boundary <- sf::st_union( fl ) %>% sf::st_as_sf()
## So now 'boundary' represents the area you want to cut out of your total shapes
## So you can find the intersection by an appropriate method
## st_contains will tell you all the shapes from 'fl' contained within the boundary
idx <- sf::st_contains(x = boundary, y = fl)
#doesn't work, thus no way of knowing the overlaps
#plot( fl[ idx[[1]], "geometry" ] )
#several more plots which i can't make sense of
plot( fl[ st_intersection(gainsville_df$Geomtry, gnv_poly$geometry), ])
plot(gainsville_df$Geomtry) #this just plots tracts
I'm going to use library(mapdeck) to plot everything, mainly because it's a library I've developed so I'm very familiar with it. It uses Mapbox maps, so you'll need a Mapbox Token to use it.
First, get the data
library(sf)
library(data.table)
fl <- sf::st_read("~/Documents/github/SO_geoSpatial_crop_Quest/GIS_cgbound/cgbound.shp") %>% sf::st_transform(crs = 4326)
gainsville_df <- fread("~/Documents/github/SO_geoSpatial_crop_Quest/new_dataframe_data.csv")
sf_gainsville <- sf::st_as_sf(gainsville_df, wkt = "Location")
## no need to transform, because it's already in Lon / Lat (?)
sf::st_crs( sf_gainsville ) <- 4326
#install.packages("tidycensus")
library(tidycensus)
tidycensus::census_api_key("21adc0b3d6e900378af9b7910d04110cdd38cd75", install = T, overwrite = T)
alachua <- tidycensus::get_acs(state = "FL", county = "Alachua", geography = "tract", geometry = T, variables = "B01003_001")
alachua <- sf::st_transform( alachua, crs = 4326 )
This is what we're working with. I'm plotting the polygons and the boundary path
library(mapdeck)
set_token( secret::get_secret("MAPBOX") )
## this is what the polygons and the Alachua boundary looks like
mapdeck() %>%
add_polygon(
data = alachua
, fill_colour = "NAME"
) %>%
add_path(
data = fl
, stroke_width = 50
)
To start with I'm going to make a polygon of the boundary
boundary_poly <- sf::st_cast(fl, "POLYGON")
Then we can get those polygons completely within the boundary
idx <- sf::st_contains(
x = boundary_poly
, y = alachua
)
idx <- unlist( sapply( idx, `[`) )
sf_contain <- alachua[ idx, ]
mapdeck() %>%
add_polygon(
data = sf_contain
, fill_colour = "NAME"
) %>%
add_path(
data = fl
)
And those which 'touch' the boundary
idx <- sf::st_crosses(
x = fl
, y = alachua
)
idx <- unlist( idx )
sf_crosses <- alachua[ idx, ]
mapdeck() %>%
add_polygon(
data = sf_crosses
, fill_colour = "NAME"
) %>%
add_path(
data = fl
)
Those which are completely on the outside are the polygons that neither touch the boundary, nor are inside it
sf_outside <- sf::st_difference(
x = alachua
, y = sf::st_union( sf_crosses )
)
sf_outside <- sf::st_difference(
x = sf_outside
, y= sf::st_union( sf_contain )
)
mapdeck() %>%
add_polygon(
data = sf_outside
, fill_colour = "NAME"
) %>%
add_path(
data = fl
)
what we need is a way to 'cut' those which touch the boundary ( sf_crosses) so we have a 'inside' and an 'outside' section for each polygon
We need to operate on each polygon at a time and 'split' it by the lines which intersect it.
There may be a way to do this with lwgeom::st_split, but I kept getting errors
To help with this I'm using a development version of my sfheaders library
# devtools::install_github("dcooley/sfheaders")
res <- lapply( 1:nrow( sf_crosses ), function(x) {
## get the intersection of the polygon and the boundary
sf_int <- sf::st_intersection(
x = sf_crosses[x, ]
, y = fl
)
## we only need lines, not MULTILINES
sf_lines <- sfheaders::sf_cast(
sf_int, "LINESTRING"
)
## put a small buffer around the lines to make them polygons
sf_polys <- sf::st_buffer( sf_lines, dist = 0.0005 )
## Find the difference of these buffers and the polygon
sf_diff <- sf::st_difference(
sf_crosses[x, ]
, sf::st_union( sf_polys )
)
## this result is a MULTIPOLYGON, which is the original polygon from
## sf_crosses[x, ], split by the lines which cross it
sf_diff
})
## The result of this is all the polygons which touch the boundary path have been split
sf_res <- do.call(rbind, res)
so sf_res should now be all the polygons which 'touch' the path, but split where the path crosses them
mapdeck() %>%
add_polygon(
data = sf_res
, stroke_colour = "#FFFFFF"
, stroke_width = 100
) %>%
add_path(
data = fl
, stroke_colour = "#FF00FF"
)
And we can see this by zooming in
Now we can find which ones are inside and outside the path
sf_in <- sf::st_join(
x = sf_res
, y = boundary_poly
, left = FALSE
)
sf_out <- sf::st_difference(
x = sf_res
, y = sf::st_union( boundary_poly )
)
mapdeck() %>%
add_path(
data = fl
, stroke_width = 50
, stroke_colour = "#000000"
) %>%
add_polygon(
data = sf_in
, fill_colour = "NAME"
, palette = "viridis"
, layer_id = "in"
) %>%
add_polygon(
data = sf_out
, fill_colour = "NAME"
, palette = "plasma"
, layer_id = "out"
)
Now have all the objects we care about
sf_contain - all the polygons completely within the bondary
sf_in - all the polygons touching the boundary on the inside
sf_out - all the polygons touching the boundary on the outside
sf_outside - all the other polygons
mapdeck() %>%
add_path(
data = fl
, stroke_width = 50
, stroke_colour = "#000000"
) %>%
add_polygon(
data = sf_contain
, fill_colour = "NAME"
, palette = "viridis"
, layer_id = "contained_within_boundary"
) %>%
add_polygon(
data = sf_in
, fill_colour = "NAME"
, palette = "cividis"
, layer_id = "touching_boundary_inside"
) %>%
add_polygon(
data = sf_out
, fill_colour = "NAME"
, palette = "plasma"
, layer_id = "touching_boundary_outside"
) %>%
add_polygon(
data = sf_outside
, fill_colour = "NAME"
, palette = "viridis"
, layer_id = "outside_boundary"
)

Mapping Bus Routes with Leaflet in R

I recently found this shape file of NYC bus routes shape file of NYC bus routes (zip file) that I am interested in plotting with the leaflet package in R.
When I attempt to do so, some routes do not show up on the map. I can tell they're missing because I overlay the bus stop data and some do not line up with the routes.
When I read in the shape file, I notice that the spatial lines data frame that is created has nested lists, which I think leaflet is not mapping.
What do I need to do so that leaflet reads coordinates of these missing routes? Below is the code I used to produce the map with missing routes:
bus <- readOGR(dsn = path.expand("bus_route_shapefile"), layer = "bus_route_shapefile")
bus.pj <- spTransform(bus, CRS("+proj=longlat +datum=WGS84"))
bus.st <- readOGR(dsn = path.expand("bus_stop_shapefile"), layer = "bus_stop_shapefile")
bus.st.pj <- spTransform(bus.st, CRS("+proj=longlat +datum=WGS84"))
bus_map <- leaflet() %>%
setView(lng = -73.932667, lat = 40.717266, zoom = 11) %>%
addPolylines(data = bus.pj, color = "black", opacity = 1) %>%
addCircles(data=bus.st.pj#data,~stop_lon, ~stop_lat, color = "red") %>%
addTiles()
bus_map
It would be easier to help you if you provided not only bus_routes but also bus_stop (zip file). You can solve it by converting bus.pj into new SpatialLinesxxx obj where each class Lines has only one class Line. SLDF below code makes doesn't have bus.pj#data$trip_heads because of unknown.
library(dplyr); library(sp); library(leaflet)
## resolve bus.pj#lines into list(Line.objs) (Don't worry about warnings)
Line_list <- lapply(bus.pj#lines, getLinesLinesSlot) %>% unlist()
## If you want just Lines infromation, finish with this line.
SL <- sapply(1:length(Line_list), function(x) Lines(Line_list[[x]], ID = x)) %>%
SpatialLines()
## make new ids (originalID_nth)
ori_id <- getSLLinesIDSlots(bus.pj) # get original ids
LinLS <- sapply(bus.pj#lines, function(x) length(x#Lines)) # how many Line.obj does each Lines.obj has
new_id <- sapply(1:length(LinLS), function(x) paste0(x, "_", seq.int(LinLS[[x]]))) %>%
unlist()
## make a new data.frame (only route_id)
df <- data.frame(route_id = rep(bus.pj#data$route_id, times = LinLS))
rownames(df) <- new_id
## integrate Line.objs, ids and a data.frame into SpatialLinesDataFrame.obj
SLDF <- mapply(function(x, y) Lines(x, ID = y), x = Line_list, y = new_id) %>%
SpatialLines() %>% SpatialLinesDataFrame(data = df)
leaflet() %>%
setView(lng = -73.932667, lat = 40.717266, zoom = 11) %>%
addPolylines(data = SLDF, color = "black", opacity = 1, weight = 1) %>%
addCircles(data=bus.st.pj#data,~stop_lon, ~stop_lat, color = "red", weight = 0.3)

R: Maps with Time Slider?

Is there a way to implement a time slider for Leaflet or any other interactive map library in R? I have data arranged in a time series, and would like to integrate that into a "motion" map where the plot points change dynamically over time.
I was thinking of breaking my data into pieces, using subset to capture the corresponding data table for each month. But how would I move between the different data sets corresponding to different months?
As it stands now, I took the average and plotted those points, but I'd rather produce a map that integrates the time series.
Here is my code so far:
data<-read.csv("Stericycle Waste Data.csv")
library(reshape2)
library(ggplot2)
library(plyr)
library(ggmap)
names(data)<-c("ID1","ID2", "Site.Address", "Type", "City", "Province", "Category", "Density", "Nov-14", "Dec-14", "Jan-15", "Feb-15", "Mar-15", "Apr-15", "May-15", "Jun-15", "Jul-15", "Aug-15", "Sep-15", "Oct-15", "Nov-15", "Dec-15", "Jan-16")
data<-melt(data, c("ID1","ID2", "Site.Address","Type", "City", "Province", "Category", "Density"))
data<-na.omit(data)
data_grouped<-ddply(data, c("Site.Address", "Type","City", "Province", "Category", "Density", "variable"), summarise, value=sum(value))
names(data_grouped)<-c("Site.Address", "Type", "City", "Province", "Category", "Density", "Month", 'Waste.Mass')
dummy<-read.csv('locations-coordinates.csv')
geodata<-merge(data_grouped, dummy, by.x="Site.Address", by.y="Site.Address", all.y=TRUE)
library(leaflet)
d = geodata_avg$density_factor
d = factor(d)
cols <- rainbow(length(levels(d)), alpha=NULL)
geodata_avg$colors <- cols[unclass(d)]
newmap <- leaflet(data=geodata_avg) %>% addTiles() %>%
addCircleMarkers(lng = ~lon, lat = ~lat, weight = 1, radius = ~rank*1.1, color = ~colors, popup = paste("Site Address: ", geodata_avg$Site.Address, "<br>", "Category: ", geodata_avg$Category, "<br>", "Average Waste: ", geodata_avg$value))
newmap
Thanks in advance! Any guidance/insight would be greatly appreciated.
Recognizing this is a very old question, in case anyone's still wondering...
The package leaflet.extras2 has some functions that might help. Here's an example that uses some tidyverse functions, sf, and leaflet.extras2::addPlayback() to generate and animate some interesting GPS tracks near Ottawa.
library(magrittr)
library(tibble)
library(leaflet)
library(leaflet.extras2)
library(sf)
library(lubridate)
# how many test data points to create
num_points <- 100
# set up an sf object with a datetime column matching each point to a date/time
# make the GPS tracks interesting
df <- tibble::tibble(temp = (1:num_points),
lat = seq(from = 45, to = 46, length.out = num_points) + .1*sin(temp),
lon = seq(from = -75, to = -75.5, length.out = num_points) + .1*cos(temp),
datetime = seq(from = lubridate::ymd_hms("2021-09-01 8:00:00"),
to = lubridate::ymd_hms("2021-09-01 9:00:00"),
length.out = num_points)) %>%
sf::st_as_sf(coords = c("lon", "lat"), crs = "WGS84", remove = FALSE)
# create a leaflet map and add an animated marker
leaflet() %>%
addTiles() %>%
leaflet.extras2::addPlayback(data = df,
time = "datetime",
options = leaflet.extras2::playbackOptions(speed = 100))
Here is an answer that may be of help.
Alternatively, you could provide the time series of a point as a popup graph using mapview::popupGraph. It is also possible to provide interactive, htmlwidget based graphs to popupGraph

Resources