How to add polygon to 3D Map in r rayshader? - r

I am new to geo spatial data and just manage to plot in small bits & pieces by looking at few articles on web.
I am trying to plot polygon boundaries on the 3D plot which I have built using rayshader package but facing issues with displaying polygon boundaries on top.
Shape file used is 2011_Dist.shp which can be downloaded from Shapefile Github link
Code I have tried:
library(tidyverse)
library(sf)
library(elevatr)
library(raster)
library(rayshader)
library(osmdata)
# read districts shape file
ind_distirct_shp <- sf::st_read("local path/2011_Dist.shp")
ind_distirct_shp
# filter State
delhi_district_shp <- ind_distirct_shp %>%
sf::st_as_sf() %>%
filter(ST_NM %in% c("NCT of Delhi"))
# this shows the polygon boundaries that I need on top of map
plot(delhi_district_shp)
# download elevation data for State Delhi
delhi_raster <- elevatr::get_elev_raster(delhi_district_shp, z = 10, clip = "location")
# convert to matrix
delhi_mat <- raster_to_matrix(delhi_raster)
# 3D plot using Rayshader
delhi_mat %>%
height_shade(texture = grDevices::colorRampPalette(c("#9a133d","orange","red","purple"
))(256)) %>%
plot_3d(heightmap = delhi_mat,
windowsize = c(800,800), # c(800*wr,800*hr)
solid = FALSE,
zscale = 1,
phi = 90,
zoom = .6,
theta = 0,
shadowcolor = "grey50",
linewidth = 6,
background = "white",
solidlinecolor = "#013b39")
Issue: Now when I try to Modify this to add polygon lines it doesn't work.
polygon_layer = generate_polygon_overlay(delhi_district_shp, extent = extent(delhi_raster),
heightmap = delhi_mat) # , palette="grey30"
polygon_layer
delhi_mat %>%
height_shade(texture = grDevices::colorRampPalette(c("#9a133d","orange","red","purple"
))(256)) %>%
add_overlay(polygon_layer) %>%
plot_3d(heightmap = delhi_mat,
windowsize = c(800,800), # c(800*wr,800*hr)
solid = FALSE,
zscale = 1,
phi = 90,
zoom = .6,
theta = 0,
shadowcolor = "grey50",
linewidth = 6,
background = "white",
solidlinecolor = "#013b39")
It should have been polygon lines on top of the Orange 3D map but it didn't work as I expected.
I also tried with Rayshder's tyler website example https://www.tylermw.com/adding-open-street-map-data-to-rayshader-maps-in-r/
library(osmdata)
osm_bbox = c(extent(delhi_raster)[3],extent(delhi_raster)[1],extent(delhi_raster)[4],extent(delhi_raster)[2])
osm_bbox
raster_polygon_boundary <- osmdata::opq(osm_bbox) %>%
add_osm_feature("highway") %>% # "admin_level"
osmdata_sf()
raster_polygon_boundary
Output:
Object of class 'osmdata' with:
$bbox : 76.8425681832661,28.4030759258059,77.347719586084,28.8793200072187
$overpass_call : The call submitted to the overpass API
$meta : metadata including timestamp and version numbers
$osm_points : 'sf' Simple Features Collection with 0 points
$osm_lines : NULL
$osm_polygons : 'sf' Simple Features Collection with 0 polygons
$osm_multilines : NULL
$osm_multipolygons : NULL
I am getting 0 polygons & lines above so I wont't be able to add any polygon on top of 3D plot.
How can I fix this. Appreciate any help.

Adding alphalayer to add_overlay(polygon_layer,alphalayer = .6) helped even though it worked but still transparency is not working perfectly. It is causing some whiteness in the plot. If anyone else has better answer or way to improve it then please feel free to share.
delhi_mat %>%
height_shade(texture = grDevices::colorRampPalette(c("#9a133d","orange","red","purple"
))(256)) %>%
add_overlay(polygon_layer,alphalayer = .6) %>%
add_overlay(generate_label_overlay(delhi_district_shp, extent = extent(delhi_raster),
text_size = 5, point_size = 1,
halo_color = "white",halo_expand = 5,
seed=1,
heightmap = delhi_mat, data_label_column = "DISTRICT")) %>%
plot_3d(heightmap = delhi_mat,
windowsize = c(800,800), # c(800*wr,800*hr)
solid = FALSE,
zscale = .7,
phi = 90,
zoom = .6,
theta = 0,
shadowcolor = "grey50",
linewidth = 6,
background = "white",
solidlinecolor = "#013b39")

Related

Animated 3D scatterplot and save it as gif in R

I want to plot a animated 3D scatterplot and save it as gif. I followed the code provided by the R Graph Gallery example: https://www.r-graph-gallery.com/3-r-animated-cube.html.
library(rgl)
library(magick)
options(rgl.printRglwidget = TRUE)
# Let's use the iris dataset
# iris
# This is ugly
colors <- c("royalblue1", "darkcyan", "oldlace")
iris$color <- colors[ as.numeric( as.factor(iris$Species) ) ]
# Static chart
plot3d( iris[,1], iris[,2], iris[,3], col = iris$color, type = "s", radius = .2 )
# We can indicate the axis and the rotation velocity
play3d( spin3d( axis = c(0, 0, 1), rpm = 20,dev = cur3d()),startTime = 0, duration = 10 )
# Save like gif
movie3d(
movie="3dAnimatedScatterplot",
spin3d( axis = c(0, 0, 1), rpm = 20,dev = cur3d()),
startTime = 0,
duration = 10,
dir = ".",
type = "gif",
clean = T,
fps=10,
convert=T
)
plot3d was successed output a 3d scatter plot.
Static 3d scatter plot
But the final output: 3dAnimatedScatterplot.gif,just a black image
3dAnimatedScatterplot.gif
when I set clean=F, all frame images are black. So, I guess the play3d() was not working.
Can anyone provide any help to me ? Thanks a lot !
Most likely snapshot3d isn't working for you. Try it with the option webshot = FALSE instead of the default webshot = TRUE. That uses a different mechanism for saving the image.

Missing data/ 0 value for Chl-a on 180 degree meridian (Oceanmap)

My first querstion here, fantastic community.
I have a slight issue projecting some chl-a data across the 180 meridian (Fiji), using Oceanmap package. I can do this in GIS but would like to be able to produce these results in R. Please see below for code and images. Basically when I project a larger frame of the area I want to display the data projects perfectly, however when I zoom in closer to Fiji which is really what I want, I get a white line (0 value I assume) across the 180 meridian. Is this a coordinate projection issue and the stitching now working at such resolution?
library(oceanmap)
library(ncdf4)
library(raster)
library(viridis)
chl.win <- ('~/Desktop/A20200812020172.L3m_SNSP_CHL_chlor_a_4km.nc')
chl.dat <- nc_open(chl.win)
chl.dat.raster <- nc2raster(chl.dat, "chlor_a", lonname="lon", latname="lat", date=T)
chl.flip <- flip(chl.dat.raster, "y")
chl.360 <- shift(raster::rotate(shift(chl.flip, 180)), 180)
chl.360.crop = raster::crop(chl.360, extent(c(176, 183, -19.8, -15.5)))
vpal <- viridis(100, alpha = 1, begin = 0, end = 1, option = "mako")
v(chl.360.crop, cbpos = "r", pal = "jet", zlim = c(0,1), cb.xlab = expression("Chlorophyll-a (mg m"^-3*")"),
bwd = 0, grid = F, replace.na = F, Save = T, plotname = "First_Quarter_2020", fileformat = "png", width = 12,
height = 6)
Image showing white line on 180 meridian

How do I map county-level data as a heatmap using FIPS codes (interactively?) in R

I am hoping to create an interactive map that will allow me to create a plot where users can change the year and variable plotted. I've seen the package tmap be used, so I'm imagining something like that, but I'd also take advice for a static map, or another approach to an interactive one. My data is much, much, richer than this, but looks something like:
example <- data.frame(fips = rep(as.numeric(c("37001", "37003", "37005", "37007", "37009", "37011", "37013", "37015", "37017", "37019"), 4)),
year = c(rep(1990, 10), rep(1991, 10), rep(1992, 10), rep(1993, 10)),
life = sample(1:100, 40, replace=TRUE),
income = sample(8000:1000000, 40, replace=TRUE),
pop = sample(80000:1000000, 40, replace=TRUE))
I'd like my output to be a map of ONLY the counties contained in my dataset (in my case, I have all the counties in North Carolina, so I don't want a map of the whole USA), that would show a heatmap of selected variables of interest (in this sample data, year, life, income, and pop. Ideally I'd like one plot with two dropdown-type menus that allow you to select what year you want to view, and which variable you want to see. A static map where I (rather than the user) defines year and variable would be helpful if you don't know how to do the interactive thing.
I've tried the following (taken from here), but it's static, which is not my ideal, and also appears to be trying to map the whole USA, so the part that's actually contained in my data (North Carolina) is very small.
library(maps)
library(ggmap)
library(mapproj)
data(county.fips)
colors = c("#F1EEF6", "#D4B9DA", "#C994C7", "#DF65B0", "#DD1C77",
"#980043")
example$colorBuckets <- as.numeric(cut(example$life, c(0, 20, 40, 60, 80,
90, 100)))
colorsmatched <- example$colorBuckets[match(county.fips$fips, example$fips)]
map("county", col = colors[colorsmatched], fill = TRUE, resolution = 0,
lty = 0, projection = "polyconic")
Here's almost the whole solution. I had hoped some package would allow mapping to be done by fips code alone, but haven't found one yet. You have to download shapefiles and merge them by fips code. This code does everything I wanted above except allow you to also filter by year. I've asking that question here, so hopefully someone will answer there.
# get shapefiles (download shapefiles [here][1] : http://www2.census.gov/geo/tiger/GENZ2014/shp/cb_2014_us_county_5m.zip )
usgeo <- st_read("~/cb_2014_us_county_5m/cb_2014_us_county_5m.shp") %>%
mutate(fips = as.numeric(paste0(STATEFP, COUNTYFP)))
### alternatively, this code *should* allow you download data ###
### directly, but somethings slightly wrong. I'd love to know what. ####
# temp <- tempfile()
# download.file("http://www2.census.gov/geo/tiger/GENZ2014/shp/cb_2014_us_county_5m.zip",temp)
# data <- st_read(unz(temp, "cb_2014_us_county_5m.shp"))
# unlink(temp)
########################################################
# create fake data
example <- data.frame(fips = rep(as.numeric(c("37001", "37003", "37005", "37007", "37009", "37011", "37013", "37015", "37017", "37019"), 4)),
year = c(rep(1990, 10), rep(1991, 10), rep(1992, 10), rep(1993, 10)),
life = sample(1:100, 40, replace=TRUE),
income = sample(8000:1000000, 40, replace=TRUE),
pop = sample(80000:1000000, 40, replace=TRUE))
# join fake data with shapefiles
example <- st_as_sf(example %>%
left_join(usgeo))
# drop layers (not sure why, but won't work without this)
example$geometry <- st_zm(example$geometry, drop = T, what = "ZM")
# filter for a single year (which I don't want to have to do)
example <- example %>% filter(year == 1993)
# change projection
example <- sf::st_transform(example, "+proj=longlat +datum=WGS84")
# create popups
incomepopup <- paste0("County: ", example$NAME, ", avg income = $", example$income)
poppopup <- paste0("County: ", example$NAME, ", avg pop = ", example$pop)
yearpopup <- paste0("County: ", example$NAME, ", avg year = ", example$year)
lifepopup <- paste0("County: ", example$NAME, ", avg life expectancy = ", example$life)
# create color palettes
yearPalette <- colorNumeric(palette = "Blues", domain=example$year)
lifePalette <- colorNumeric(palette = "Purples", domain=example$life)
incomePalette <- colorNumeric(palette = "Reds", domain=example$income)
popPalette <- colorNumeric(palette = "Oranges", domain=example$pop)
# create map
leaflet(example) %>%
addProviderTiles("CartoDB.Positron") %>%
addPolygons(stroke=FALSE,
smoothFactor = 0.2,
fillOpacity = .8,
popup = poppopup,
color = ~popPalette(example$pop),
group = "pop"
) %>%
addPolygons(stroke=FALSE,
smoothFactor = 0.2,
fillOpacity = .8,
popup = yearpopup,
color = ~yearPalette(example$year),
group = "year"
) %>%
addPolygons(stroke=FALSE,
smoothFactor = 0.2,
fillOpacity = .8,
popup = lifepopup,
color = ~lifePalette(example$life),
group = "life"
) %>%
addPolygons(stroke=FALSE,
smoothFactor = 0.2,
fillOpacity = .8,
popup = incomepopup,
color = ~incomePalette(example$income),
group = "income"
) %>%
addLayersControl(
baseGroups=c("income", "year", "life", "pop"),
position = "bottomleft",
options = layersControlOptions(collapsed = FALSE)
)
I'm still looking for a way to add a "year" filter that would be another interactive radio-button box to filter the data by different years.

label for overlapping polygons in R leaflet

I need to label several overlapping polygons, but only the label of the biggest one is shown. However when I tested with some simulated data the labels were shown correctly. I compared the data in two cases carefully but cannot find the difference caused the problem.
Here is a minimal example of simulated overlapping polygons:
library(leaflet)
library(sp)
poly_a <- data.frame(lng = c(0, 0.5, 2, 3),
lat = c(0, 4, 4, 0))
poly_b <- data.frame(lng = c(1, 1.5, 1.8),
lat = c(2, 3, 2))
pgons = list(
Polygons(list(Polygon(poly_a)), ID="1"),
Polygons(list(Polygon(poly_b)), ID="2")
)
poly_dat <- data.frame(name = as.factor(c("a", "b")))
rownames(poly_dat) <- c("1", "2")
spgons = SpatialPolygons(pgons)
spgonsdf = SpatialPolygonsDataFrame(spgons, poly_dat, TRUE)
leaflet() %>% addPolygons(data = spgonsdf, label = ~name
# ,
# highlightOptions = highlightOptions(
# color = "red", weight = 2,bringToFront = TRUE)
)
It's working properly:
However it didn't work with my data.
https://github.com/rstudio/leaflet/files/1430888/Gabs.zip
You can drag the zip into this site and use the i button to see it's correctly labeled
library(rgdal)
# download Gabs.zip and extract files to Gabs folder
hr_shape_gabs <- readOGR(dsn = 'Gabs', layer = 'Gabs - OU anisotropic')
hr_shape_gabs_pro <- spTransform(hr_shape_gabs,
CRS("+proj=longlat +datum=WGS84 +no_defs"))
leaflet(hr_shape_gabs_pro) %>%
addTiles() %>%
addPolygons(weight = 1, label = ~name)
Only the biggest polygon label is shown:
The data in both case are SpatialPolygonsDataFrame, the data slot have proper polygon names.
Change the order of polygons in hr_shape_gabs: polygon in position 3 should be the smaller one.
library(leaflet)
library(sp)
library(rgdal)
hr_shape_gabs <- readOGR(dsn = 'Gabs - OU anisotropic.shp',
layer = 'Gabs - OU anisotropic')
# Change the position of the smaller and wider polygons
# Position 1 = wider polygon, position 3 = smaller polygon
pol3 <- hr_shape_gabs#polygons[[3]]
hr_shape_gabs#polygons[[3]] <- hr_shape_gabs#polygons[[1]]
hr_shape_gabs#polygons[[1]] <- pol3
hr_shape_gabs$name <- rev(hr_shape_gabs$name)
hr_shape_gabs_pro <- spTransform(hr_shape_gabs,
CRS("+proj=longlat +datum=WGS84 +no_defs"))
leaflet() %>%
addTiles() %>%
addPolygons(data= hr_shape_gabs_pro, weight = 1, label = ~name)
Here's a scalable solution in sf for many layers, based on this answer.
The idea is to order the polygons by decreasing size, such that the smallest polygons plot last.
library(sf)
library(dplyr)
# calculate area of spatial polygons sf object
poly_df$area <- st_area(poly_df)
poly_df <- arrange(poly_df, -area)
# view with labels in leaflet to see that small polygons plot on top
leaflet(poly_df) %>% addTiles() %>% addPolygons(label = ~id)
Apologies for the lack of reproducibility. This is more of a concept answer.

R Leaflet choroplete map with timeslider?

I got time related data (7 years) displayed in a choropleth map, using R and Leaflet-for-R-package. Therefore use a kmz-file for geometry and csv data for attributes. So far I tried it with data for 2 years, using this tutorial:
http://journocode.com/2016/01/28/your-first-choropleth-map/
Following the example, I used my data instead of the given one in the tutorial. Everything worked fine. But longterm, I want to add all my
7 years data, therefore it would be useful to replace the radio button-based layer control by a (time)slider - changing the overlays according to the year.
In a comparable case here on stackoverflow, someone worked with geojson-files as geometry in order to use the timeslider plugin for Leaflet:
Leaflet slider group by year
So do I need to change my geom data into geojson as well?
And do so, how I link my csv-data to geojson and will R be able to cover all?
I hope you might have some suggestions...
https://github.com/Pippo87/R-leaflet-choropleth
Here is my R-script:
library(rgdal)
berlin <- readOGR("LOR-Planungsraeume.kml","LOR_Planungsraum", encoding="utf-8")
plot(berlin)
Auslaender2007 <- read.csv("LOR_Auslaender_2007.csv", encoding="latin1", sep=",", dec=".")
Auslaender2008 <- read.csv("LOR_Auslaender_2008.csv", encoding="latin1", sep=",", dec=".")
library(leaflet)
palette <- colorBin(c('#fef0d9',
'#fdd49e',
'#fdbb84',
'#fc8d59',
'#e34a33',
'#b30000'),
Auslaender2008$ANTEIL, bins = 6, pretty=TRUE, alpha = TRUE)
popup2007 <- paste0("<strong>Auslaender 2007</strong></span>",
"<br><strong>LOR </strong></span>",
Auslaender2007$LORNAME,
"<br><strong> Relativer Auslaenderanteil </strong></span>",
Auslaender2007$ANTEIL
,"<br><strong>Absoluter Auslaenderanteil</strong></span>",
Auslaender2007$AUSLAENDER)
popup2008 <- paste0("<strong>Auslaender 2007</strong></span>",
"<br><strong>LOR </strong></span>",
Auslaender2008$LORNAME,
"<br><strong> Relativer Auslaenderanteil </strong></span>",
Auslaender2008$ANTEIL
,"<br><strong>Absoluter Auslaenderanteil</strong></span>",
Auslaender2008$AUSLAENDER)
mymap <- leaflet() %>%
addProviderTiles("Esri.WorldGrayCanvas", options = tileOptions(minZoom=10, maxZoom=16)) %>%
addPolygons(data = berlin,
fillColor = ~palette(Auslaender2007$ANTEIL),
fillOpacity = 1,
color = "darkgrey",
weight = 1.5,
group="<span style='font-size: 11pt'><strong>2007</strong></span>")%>%
addPolygons(data = berlin,
fillColor = ~palette(Auslaender2008$ANTEIL),
fillOpacity = 1,
color = "darkgrey",
weight = 1.5,
popup = popup2008,
group="<span style='font-size: 11pt'><strong>2008</strong></span>")%>%
addLayersControl(
baseGroups = c("<span style='font-size: 11pt'><strong>2007</strong></span>", "<span style='font-size: 11pt'><strong>2008</strong></span>"),
options = layersControlOptions(collapsed = FALSE))%>%
addLegend(position = 'topleft', pal = palette, values = Auslaender2008$ANTEIL, opacity = 1, title = "Relativer<br>Auslaenderanteil")
print(mymap)

Resources