Related
I'm trying to create a map of Europe with grid cells coloured based on the number of records within a cell. Here I attach an image as illustrative of the desired output (see Fig 1 of https://doi.org/10.3897/phytokeys.74.9723).
In order to produce this image I have developed a minimal reproducible example with random points distributed across Europe. I have been able to produce a similar figure with levelplot but I'm particulary interested in doing this with ggplot as it will allow further customising. Is it possible to do produce a similar figure with ggplot? And if so, any advice of what path should I follow?
Note: The size of the grids/cells is irrelevant at the moment but I'll adjust it depending on point density. All of them have to be the same size as in the first example and they only will differ on the pattern of colour.
#Load libraries
library(rgdal) #v1.5-28
library(rgeos) #v.0.5-9
library(ggplot2) # 3.3.5
library(rworldmap) #plot worldmap v.1.3-6
library(dplyr) #v.1.0.7
#Create dataframe of coordinates that fall in Europe
coord <- data.frame(cbind(runif(1000,-15,45),runif(1000,30,75)))
colnames(coord) <- c("long","lat")
#Exlude ocean points following this post
URL <- "http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/physical/ne_110m_ocean.zip"
fil <- basename(URL)
if (!file.exists(fil)) download.file(URL, fil)
fils <- unzip(fil)
oceans <- readOGR(grep("shp$", fils, value=TRUE), "ne_110m_ocean",
stringsAsFactors=FALSE, verbose=FALSE)
europe_coord <- data.frame(long = coord$long,
lat = coord$lat)
coordinates(europe_coord) <- ~long+lat
proj4string(europe_coord) <- CRS(proj4string(oceans))
ocean_points <- over(europe_coord, oceans)
#Add ocean points to dataset
coord$ocean <- ocean_points$featurecla
#Exlude ocean points
europe_land <- coord %>% filter(is.na(ocean))
#Load worldmap
world <- map_data("world")
#Plot europe spatial data
ggplot() + geom_map(data = world, map = world,
aes(long, lat, map_id = region), color = "white",
fill = "lightgray", size = 0.1) +
geom_point(data = europe_land,aes(long, lat),
alpha = 0.7, size = 0.05) + ylim(0,70) +
coord_sf(xlim = c(-15, 45), ylim = c(30, 75), expand = FALSE)
I'm looking to create some proximity maps using R, which show how far areas are from certain points. I can't find any examples in R code, but I've found an output which is the sort of thing I want:
It doesn't necessarily have to have all the labelling/internal boundaries wizardry, but I'd like it to stop at the sea border (thinking of using the rgeos function gintersection - see here).
I've tried doing a density plot as 'heatmaps' (this would be a pretty good solution/alternative) and putting a shapefile over the top (following this suggestion, but they're not lining up and I can't do a gintersection, probably because there's not a coordinate system attached to the density plot.
I used your question to play a little with new libraries...
Get a UK map and define random points
library(raster)
library(sf)
library(ggplot2)
library(dplyr)
library(tidyr)
library(forcats)
library(purrr)
# Get UK map
GBR <- getData(name = "GADM", country = "GBR", level = 1)
GBR_sf <- st_as_sf(GBR)
# Define 3 points on the UK map
pts <- matrix(c(-0.4966766, -2.0772529, -3.8437793,
51.91829, 52.86147, 56.73899), ncol = 2)
# Project in mercator to allow buffer with distances
pts_sf <- st_sfc(st_multipoint(pts), crs = 4326) %>%
st_sf() %>%
st_transform(27700)
ggplot() +
geom_sf(data = GBR_sf) +
geom_sf(data = pts_sf, colour = "red")
Calculate buffer areas
We create a list of multipolygons for each buffer distance. The point dataset must be in projected coordinates (here mercator) as buffer distance is in the scale of the coordinates system.
# Define distances to buffer
dists <- seq(5000, 150000, length.out = 5)
# Create buffer areas with each distances
pts_buf <- purrr::map(dists, ~st_buffer(pts_sf, .)) %>%
do.call("rbind", .) %>%
st_cast() %>%
mutate(
distmax = dists,
dist = glue::glue("<{dists/1000} km"))
# Plot: alpha allows to see overlapping polygons
ggplot() +
geom_sf(data = GBR_sf) +
geom_sf(data = pts_buf, fill = "red",
colour = NA, alpha = 0.1)
Remove overlapping
Buffer areas are overlapping. On the figure above, the more intense red color is due to multiple overlapping layers of transparent red. Let's remove the overlapping. We need to remove from larger areas, the buffer with the lower size. I then need to add again the smallest area to the list.
# Remove part of polygons overlapping smaller buffer
pts_holes <- purrr::map2(tail(1:nrow(pts_buf),-1),
head(1:nrow(pts_buf),-1),
~st_difference(pts_buf[.x,], pts_buf[.y,])) %>%
do.call("rbind", .) %>%
st_cast() %>%
select(-distmax.1, -dist.1)
# Add smallest polygon
pts_holes_tot <- pts_holes %>%
rbind(filter(pts_buf, distmax == min(dists))) %>%
arrange(distmax) %>%
mutate(dist = forcats::fct_reorder(dist, distmax))
# Plot and define color according to dist
ggplot() +
geom_sf(data = GBR_sf) +
geom_sf(data = pts_holes_tot,
aes(fill = dist),
colour = NA) +
scale_fill_brewer(direction = 2)
Remove areas in the sea
If you want to find proximity area on terrestrial parts only, we need to remove buffer areas that are in the sea. Intersection is computed between multipolygons with the same projection. I previously realize an union of the UK map.
# Remove part of polygons in the sea
# Union and projection of UK map
GBR_sf_merc <- st_transform(st_union(GBR_sf), 27700)
pts_holes_uk <- st_intersection(pts_holes_tot,
GBR_sf_merc)
ggplot() +
geom_sf(data = GBR_sf) +
geom_sf(data = pts_holes_uk,
aes(fill = dist),
colour = NA) +
scale_fill_brewer(direction = 2)
And here is the final proximity map using sf, ggplot2 and a few other libraries...
Based on Sébastien's example, a more old-fashioned approach:
library(raster)
GBR <- getData(name = "GADM", country = "GBR", level = 1)
pts <- matrix(c(-0.4966766, -2.0772529, -3.8437793, 51.91829, 52.86147, 56.73899), ncol = 2)
r <- raster(GBR, res=1/12)
d <- distanceFromPoints(r, pts)
m <- mask(d, GBR)
plot(m)
I made static heatmaps with the library(ggmap) and the stat_density2d() function. Looking to recreate this in a shiny app on a dynamic leaflet map, I found addHeatmap(). However, the resulting images are dissimilar, with the ggmap version seemingly offering the correct result.
GGMAP
LEAFLET
What is causing this difference?
To run both of the below reproducible examples, you can download some data (csv file) I put here.
https://drive.google.com/drive/folders/0B8_GTHBuoKSRR1VIRmhOUTJKYU0?usp=sharing
Note that the leaflet result differs with zoom level, but never matches the ggmap result (e.g. in terms location of maximum heat).
This is the ggmap code.
library(ggmap)
data <- read.csv("DATA.csv", sep=";")
data <- subset(data, !is.na(CrdLatDeg))
xmin <- min(data$CrdLonDeg)
xmax <- max(data$CrdLonDeg)
ymin <- min(data$CrdLatDeg)
ymax <- max(data$CrdLatDeg)
lon <- c(xmin,xmax)
lat <- c(ymin,ymax)
map <- get_map(location = c(lon = mean(lon), lat = mean(lat)), zoom = 17,
maptype = "satellite", source = "google")
ggmap(map) +
labs(x="longitude", y="latitude") +
stat_density2d(data=data, aes(x=CrdLonDeg, y=CrdLatDeg, alpha= ..level.., fill= ..level..), colour=FALSE,
geom="polygon", bins=100) +
scale_fill_gradientn(colours=c(rev(rainbow(100, start=0, end=.7)))) + scale_alpha(range=c(0,.8)) +
guides(alpha=FALSE,fill=FALSE)
This is the leaflet code.
library(leaflet.extras)
data <- read.csv("DATA.csv", sep=";")
data <- subset(data, !is.na(CrdLatDeg))
leaflet(data) %>%
addTiles(group="OSM") %>%
addHeatmap(group="heat", lng=~CrdLonDeg, lat=~CrdLatDeg, max=.6, blur = 60)
The images look different because the algorithms are different.
stat_density2d() extrapolates a probability density function from the discrete data.
Leaflet implementation of heatmaps rely on libraries like simpleheat, heatmap.js or webgl-heatmap. These heatmaps do not rely on probability density. (I'm not fully sure which of these is used by r-leaflet's addHeatmap).
Instead, these heatmaps work by drawing a blurred circle for each point, raising the value of each pixel by an amount directly proportional to the intensity of the point (constant in your case), and inversely proportional to the distance between the point and the circle. Every data point is shown in the heatmap as a circle. You can see this by playing with your mouse cursor in the heatmap.js webpage, or by looking at this lone point in the top-right of your image:
Think of a heatmap like a visualization of the function
f(pixel) = ∑ ( max( 0, radius - distance(pixel, point) ) · intensity(point) )
One can tweak the radius and intensity of heatmaps, but the result will never be the same as a statistical density estimation.
I've found this answer over at GIS, and I've attempted to create a function and applied it to this case. I haven't figured out how to finetune the colour gradient scheme as of yet, but it seems like a good first start otherwise:
library(leaflet)
library(rlang)
addHeatMap <- function(data, lon, lat, intensity, show.legend, ...) {
df <- data.table::as.data.table(data)
df_expanded <- dplyr::slice(df, rep(1:dplyr::n(), times = !! enquo(intensity)))
lon_var <- dplyr::pull(df_expanded, !! enquo(lon))
lat_var <- dplyr::pull(df_expanded, !! enquo(lat))
lon_bw <- MASS::bandwidth.nrd(lon_var)
lat_bw <- MASS::bandwidth.nrd(lat_var)
lon_lat_df <- dplyr::select(df_expanded, !! enquo(lon), !! enquo(lat))
kde <- KernSmooth::bkde2D(lon_lat_df, bandwidth = c(lon_bw, lat_bw))
CL <- contourLines(kde$x1 , kde$x2 , kde$fhat)
LEVS <- as.factor(sapply(CL, `[[`, "level"))
NLEV <- nlevels(LEVS)
pgons <- lapply(1:length(CL), function(i)
sp::Polygons(list(sp::Polygon(cbind(CL[[i]]$x, CL[[i]]$y))), ID = i))
spgons <- sp::SpatialPolygons(pgons)
if (show.legend) {
leaflet::addPolygons(data = spgons, color = heat.colors(NLEV, NULL)[LEVS], stroke = FALSE, ...) %>%
leaflet::addLegend(colors = heat.colors(NLEV, NULL)[LEVS], labels = LEVS)
} else {
leaflet::addPolygons(data = spgons, color = heat.colors(NLEV, NULL)[LEVS], stroke = FALSE, ...)
}
}
mydata <- read.csv("DATA.csv", sep=";")
mydata <- subset(mydata, !is.na(CrdLatDeg))
leaflet() %>%
addTiles(group = "OSM") %>%
addHeatMap(data = mydata, lon = CrdLonDeg, lat = CrdLatDeg, intensity = FsmIdf, show.legend = TRUE)
Both use a different algorithm. You need to tweak the radius and blur arguments of addHeatmap and the h argument of stat_density2d to get somewhat similar results.
I want to plot a map with a raster overlaying a GoogleMaps base map in ggplot2. Therefore, I used get_map() and insert_raster() like this:
library(ggplot2)
library(ggmap)
bm <- ggmap(get_map(location = "Bangkok", maptype = "hybrid"))
bm + inset_raster(as.raster(r), xmin = r#extent[1], xmax = r#extent[2],
ymin = r#extent[3], ymax = r#extent[4])
Is there any possibility to set a alpha and change the fill color?
The result looks like this:
Even Faster without fortify:
read the original post below for further information
From this blog entry I found that we can use spatial polygons directly in ggplot::geom_polygon()
r <- raster(system.file("external/test.grd", package="raster"))
# just to make it reproducible with ggmap we have to transform to wgs84
r <- projectRaster(r, crs = CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"))
rtp <- rasterToPolygons(r)
bm <- ggmap(get_map(location = bbox(rtp), maptype = "hybrid", zoom = 13))
bm +
geom_polygon(data = rtp,
aes(x = long, y = lat, group = group,
fill = rep(rtp$test, each = 5)),
size = 0,
alpha = 0.5) +
scale_fill_gradientn("RasterValues", colors = topo.colors(255))
How to tackle plotting SPEED if you just need to visualize something
As described below, such plotting might become very slow with large numbers of pixels. Therefore, you might consider to reduce the number of pixels (which in most cases does not really decrease the amount of information in the map) before converting it to polygons. Therefore, raster::aggregate can be used to reduce the number of pixels to a reasonable amount.
The example shows how the number of pixels is decreased by an order of 4 (i.e. 2 * 2, horizontally * vertically). For further information see ?raster::aggregate.
r <- aggregate(r, fact = 2)
# afterwards continue with rasterToPolygons(r)...
Original Post:
After a while, I found a way to solve this problem. Converting the raster to polygons! This idea then basically was implemented after Marc Needham's blog post.
Yet, there is one drawback: ggplot gets really slow with large numbers of polygons, which you will inevitably face. However, you can speed things up by plotting into a png() (or other) device.
Here is a code example:
library(raster)
library(ggplot2)
library(ggmap)
r <- raster(....) # any raster you want to plot
rtp <- rasterToPolygons(r)
rtp#data$id <- 1:nrow(rtp#data) # add id column for join
rtpFort <- fortify(rtp, data = rtp#data)
rtpFortMer <- merge(rtpFort, rtp#data, by.x = 'id', by.y = 'id') # join data
bm <- ggmap(get_map(location = "Shanghai", maptype = "hybrid", zoom = 10))
bm + geom_polygon(data = rtpFortMer,
aes(x = long, y = lat, group = group, fill = layer),
alpha = 0.5,
size = 0) + ## size = 0 to remove the polygon outlines
scale_fill_gradientn(colours = topo.colors(255))
This results in something like this:
just been looking into this myself. The issue i encountered was trying to overlay a ggmap output with a raster was the following error:
Error: geom_raster only works with Cartesian coordinates.
the work around to this issue is to use coord_cartesian() as follows:
library(ggplot2)
library(ggmap)
bm <- ggmap(get_map(location = "Bangkok", maptype = "hybrid"))
bm <- bm + geom_raster(...) # insert your raster here
bm <- bm + coord_cartesian()
plot(bm)
I am not sure where your raster r is coming from. for this to work simply convert your raster r into a data frame and add the data according to the geom_raster() instructions, ensure the coordinates are in lat/long (i.e. same as the map).
To answer your question, through geom_raster() you can manipulate alpha and fill.
Hope this helps.
btw this work around was originally raised at this link:
https://groups.google.com/forum/embed/#!topic/ggplot2/nqzBX22MeAQ
I am overlaying a world map from the maps package onto a ggplot2 raster geometry. However, this raster is not centered on the prime meridian (0 deg), but on 180 deg (roughly the Bering Sea and the Pacific). The following code gets the map and recenters the map on 180 degree:
require(maps)
world_map = data.frame(map(plot=FALSE)[c("x","y")])
names(world_map) = c("lon","lat")
world_map = within(world_map, {
lon = ifelse(lon < 0, lon + 360, lon)
})
ggplot(aes(x = lon, y = lat), data = world_map) + geom_path()
which yields the following output:
Quite obviously there are the lines draw between polygons that are on one end or the other of the prime meridian. My current solution is to replace points close to the prime meridian by NA, replacing the within call above by:
world_map = within(world_map, {
lon = ifelse(lon < 0, lon + 360, lon)
lon = ifelse((lon < 1) | (lon > 359), NA, lon)
})
ggplot(aes(x = lon, y = lat), data = world_map) + geom_path()
Which leads to the correct image. I now have a number of question:
There must be a better way of centering the map on another meridian. I tried using the orientation parameter in map, but setting this to orientation = c(0,180,0) did not yield the correct result, in fact it did not change anything to the result object (all.equal yielded TRUE).
Getting rid of the horizontal stripes should be possible without deleting some of the polygons. It might be that solving point 1. also solves this point.
This may be somewhat tricky but you can do by:
mp1 <- fortify(map(fill=TRUE, plot=FALSE))
mp2 <- mp1
mp2$long <- mp2$long + 360
mp2$group <- mp2$group + max(mp2$group) + 1
mp <- rbind(mp1, mp2)
ggplot(aes(x = long, y = lat, group = group), data = mp) +
geom_path() +
scale_x_continuous(limits = c(0, 360))
By this setup you can easily set the center (i.e., limits):
ggplot(aes(x = long, y = lat, group = group), data = mp) +
geom_path() +
scale_x_continuous(limits = c(-100, 260))
UPDATED
Here I put some explanations:
The whole data looks like:
ggplot(aes(x = long, y = lat, group = group), data = mp) + geom_path()
but by scale_x_continuous(limits = c(0, 360)), you can crop a subset of the region from 0 to 360 longitude.
And in geom_path, the data of same group are connected. So if mp2$group <- mp2$group + max(mp2$group) + 1 is absent, it looks like:
Here's a different approach. It works by:
Converting the world map from the maps package into a SpatialLines object with a geographical (lat-long) CRS.
Projecting the SpatialLines map into the Plate Carée (aka Equidistant Cylindrical) projection centered on the Prime Meridian. (This projection is very similar to a geographical mapping).
Cutting in two segments that would otherwise be clipped by left and right edges of the map. (This is done using topological functions from the rgeos package.)
Reprojecting to a Plate Carée projection centered on the desired meridian (lon_0 in terminology taken from the PROJ_4 program used by spTransform() in the rgdal package).
Identifying (and removing) any remaining 'streaks'. I automated this by searching for lines that cross g.e. two of three widely separated meridians. (This also uses topological functions from the rgeos package.)
This is obviously a lot of work, but leaves one with maps that are minimally truncated, and can be easily reprojected using spTransform(). To overlay these on top of raster images with base or lattice graphics, I first reproject the rasters, also using spTransform(). If you need them, grid lines and labels can likewise be projected to match the SpatialLines map.
library(sp)
library(maps)
library(maptools) ## map2SpatialLines(), pruneMap()
library(rgdal) ## CRS(), spTransform()
library(rgeos) ## readWKT(), gIntersects(), gBuffer(), gDifference()
## Convert a "maps" map to a "SpatialLines" map
makeSLmap <- function() {
llCRS <- CRS("+proj=longlat +ellps=WGS84")
wrld <- map("world", interior = FALSE, plot=FALSE,
xlim = c(-179, 179), ylim = c(-89, 89))
wrld_p <- pruneMap(wrld, xlim = c(-179, 179))
map2SpatialLines(wrld_p, proj4string = llCRS)
}
## Clip SpatialLines neatly along the antipodal meridian
sliceAtAntipodes <- function(SLmap, lon_0) {
## Preliminaries
long_180 <- (lon_0 %% 360) - 180
llCRS <- CRS("+proj=longlat +ellps=WGS84") ## CRS of 'maps' objects
eqcCRS <- CRS("+proj=eqc")
## Reproject the map into Equidistant Cylindrical/Plate Caree projection
SLmap <- spTransform(SLmap, eqcCRS)
## Make a narrow SpatialPolygon along the meridian opposite lon_0
L <- Lines(Line(cbind(long_180, c(-89, 89))), ID="cutter")
SL <- SpatialLines(list(L), proj4string = llCRS)
SP <- gBuffer(spTransform(SL, eqcCRS), 10, byid = TRUE)
## Use it to clip any SpatialLines segments that it crosses
ii <- which(gIntersects(SLmap, SP, byid=TRUE))
# Replace offending lines with split versions
# (but skip when there are no intersections (as, e.g., when lon_0 = 0))
if(length(ii)) {
SPii <- gDifference(SLmap[ii], SP, byid=TRUE)
SLmap <- rbind(SLmap[-ii], SPii)
}
return(SLmap)
}
## re-center, and clean up remaining streaks
recenterAndClean <- function(SLmap, lon_0) {
llCRS <- CRS("+proj=longlat +ellps=WGS84") ## map package's CRS
newCRS <- CRS(paste("+proj=eqc +lon_0=", lon_0, sep=""))
## Recenter
SLmap <- spTransform(SLmap, newCRS)
## identify remaining 'scratch-lines' by searching for lines that
## cross 2 of 3 lines of longitude, spaced 120 degrees apart
v1 <-spTransform(readWKT("LINESTRING(-62 -89, -62 89)", p4s=llCRS), newCRS)
v2 <-spTransform(readWKT("LINESTRING(58 -89, 58 89)", p4s=llCRS), newCRS)
v3 <-spTransform(readWKT("LINESTRING(178 -89, 178 89)", p4s=llCRS), newCRS)
ii <- which((gIntersects(v1, SLmap, byid=TRUE) +
gIntersects(v2, SLmap, byid=TRUE) +
gIntersects(v3, SLmap, byid=TRUE)) >= 2)
SLmap[-ii]
}
## Put it all together:
Recenter <- function(lon_0 = -100, grid=FALSE, ...) {
SLmap <- makeSLmap()
SLmap2 <- sliceAtAntipodes(SLmap, lon_0)
recenterAndClean(SLmap2, lon_0)
}
## Try it out
par(mfrow=c(2,2), mar=rep(1, 4))
plot(Recenter(-90), col="grey40"); box() ## Centered on 90w
plot(Recenter(0), col="grey40"); box() ## Centered on prime meridian
plot(Recenter(90), col="grey40"); box() ## Centered on 90e
plot(Recenter(180), col="grey40"); box() ## Centered on International Date Line
This should work:
wm <- map.wrap(map(projection="rectangular", parameter=0, orientation=c(90,0,180), plot=FALSE))
world_map <- data.frame(wm[c("x","y")])
names(world_map) <- c("lon","lat")
The map.wrap cuts the lines going across the map. It can be used via an option to map(wrap=TRUE), but that only works when plot=TRUE.
One remaining annoyance is that at this point, lat/lon are in rad, not degrees:
world_map$lon <- world_map$lon * 180/pi + 180
world_map$lat <- world_map$lat * 180/pi
ggplot(aes(x = lon, y = lat), data = world_map) + geom_path()