I have an image, and am trying to plot the number of quadrats that appear in each tessellated region.
I have two problems here:
My tessellated image will not plot with my gw_ppp points, even with an add = TRUE argument.
I am trying to plot the number of quadrants that appear inside each tessellated region, but the image is being plotted with zeros. Also, my gw_ppp points are not being plotted along with the image.
All of the files that can be used to reproduce the error can be found and downloaded in this Google Drive folder.
Here is what I have tried:
library(pacman)
p_load(spatstat,
dplyr,
maptools,
raster,
sf,
sp,
ggplot2)
#Set workplace directory to wherever you downloaded the files from:
setwd(C:\\Users\\Documents)
#Load all data, found in the link above
gw <- read.csv("RileyCNTYGWwells.csv", stringsAsFactors = FALSE)
elev <- raster('elevation.tif')
KS_counties <- st_read("KS_counties.shp")
#Select desired columns from .csv file
gw_sp <- gw %>%
dplyr::select(LONGITUDE, LATITUDE, WELL_USE, WELL_DEPTH, EST_YIELD) %>% na.omit(gw_sp)
#Convert to spatial dataframe
gw_cor <- st_as_sf(gw_sp, coords=c("LONGITUDE","LATITUDE"),
crs = st_crs(4326))
#Remove duplicated rows with dplyr's `distinct` function
gw_sp <- gw_cor %>%
distinct()
#Omit points outside Riley Co.
riley <- KS_counties %>%
filter(name == "Riley")
riley <- st_transform(riley, 4326)
gw_final <- st_intersection(riley, gw_sp)
#Project to a projected CRS, as spatstat is not happy with WGS84
utm14 <- '+proj=utm +zone=14 +ellps=GRS80 +to_meter=0.3048006096012192 +no_defs'
g <- st_transform(gw_final, crs = utm14)
#Filter unwanted columns
g <- g %>%
dplyr::select(WELL_USE:EST_YIELD)
#Finally, convert to ppp (RDS file)
gw_ppp <- as(g, "Spatial")
gw_ppp <- as(gw_ppp, "ppp")
From here, we can generate the quadrants:
#Generate the quadrat
q_well <- quadratcount(gw_ppp, nx = 10, ny = 10)
#Plot the quadrats and points
plot(gw_ppp, main = "Riley County Quadrat Well Count", cex = 0.5, pch = "+", cols = "red", legend = FALSE, use.marks = FALSE)
plot(q_well, add=TRUE, textargs = list(cex = 0.8))
These are the quadrant totals that need to show up on the graph (problem 2), but they are not being plotted.
Now, we will read in the elevation raster, reclassify it into 4 categories based on quantiles, and then plot the tessellation together with the gw_ppp points:
#Read in raster and mask to desired county shapefile
elev <- raster("elevation.tif")
riley <- st_transform(riley, crs(elev))
crop_riley <- crop(elev, riley)
mask_riley <- mask(crop_riley, mask = riley)
plot(mask_riley, main = "Riley County Elevation Map")
#Reclassify raster into quantiles
quantile(mask_riley)
elev_zones <- reclassify(mask_riley,
c(0, 361.6296, 1,
361.6296, 387.6583, 2,
387.6583, 403.2133, 3,
403.2133, 466.1521, 4))
elev_zones <- ratify(elev_zones)
plot(elev_zones, main = "Elevation Zones")
#Convert to a Spatstat-compatible object
elev_zones <- as.im.RasterLayer(elev_zones)
#Tesselate the image
tes <- tess(image = elev_zones)
plot(tes, main = "Tesselated Elevation Zones")
plot(gw_ppp, add=T, main = "Riley County Quadrat Well Count", cex = 1, pch = "+", cols = "black", legend = FALSE, use.marks = FALSE)
Problem 1 appears after the last line of code is run above. There are no gw_ppp points plotted.
Now, I'm trying to generate the number of quadrants that appear in each tessellated region:
q_elev <- quadratcount.ppp(gw_ppp, tess = tes)
plot(q_elev, main = "Riley County Quadrat Well Count")
plot(gw_ppp, add=T, cex = 1, pch = "+", cols = "black", legend = FALSE, use.marks = FALSE)
Result:
Here is problem 2. These values shouldn't be zeros, and the gw_ppp points are not showing. How can I fix these issues?
I am hoping someone can help me with the formating from phylo.to.plot() or suggest another method that can produce a similar output.
I have followed tutorial(s) here to produce an output but it seems difficult to alter the resulting figures.
Briefly these are my questions. I will expand further below.
How to plot a subregion of a "WorldHires" map, not entire region?
Change the shape of the points on the map, but maintain the colour?
Add gradient of continuous variable to map
Reproducible example:
Here is a very basic tree with some randomly assigned geographic locations
myTree <- ape::read.tree(text='((A, B), ((C, D), (E, F)));')
plot(myTree)
# It needs to be rooted for `phylo.to.map()` to work
myTree$branch.length = NULL
rooted_cladogram = ape::compute.brlen(myTree)
# Sample information
Sample <- c("A","B","C","D","E","F")
coords <- matrix(c(56.001966,57.069417,50.70228, 51.836213, 54.678997, 54.67831,-5.636926,-2.47805,-3.8975018, -2.235444,-3.4392211, -1.751833), nrow=6, ncol=2)
rownames(coords) <- Sample
head(coords)
## Plot phylo.to.map
obj<-phylo.to.map(rooted_cladogram,coords,database="worldHires", regions="UK",plot=FALSE,xlim=c(-11,3), ylim=c(49,59),direction="rightwards")
plot(obj,direction="rightwards",fsize=0.5,cex.points=c(0,1), lwd=c(3,1),ftype="i")
Plot output here:
Question 1: How do I plot a subregion of a "WorldHires" map, not the entire region?
I would like to only have mainland Britain which is a subregion of the "UK" in the WorldHires database. To access it normally I would do:
map1 <- ggplot2::map_data(map = "worldHires", region = c("UK"),xlim=c(-11,3), ylim=c(49,59))
GB <- subset(map1, subregion=="Great Britain")
# Plot
GB_plot<- ggplot(GB )+
geom_polygon(aes(x = long, y = lat, group = group), fill = "white", colour = "black")+
theme_classic()+
theme(axis.line=element_blank(),
axis.text=element_blank(),
axis.ticks=element_blank(),
axis.title=element_blank(),
panel.border = element_blank())
Which looks like this:
I have tried but it ignore the subregion argument.
obj<-phylo.to.map(ttree,coords,database="worldHires", regions="UK", subregion="Great Britain",plot=FALSE,xlim=c(-11,3), ylim=c(49,59),direction="rightwards")
Is there a way to provide it directly with a map instead of using WorldHires?
Question 2: How do I change the shape of the points on the map but keep maintain the colour?
I want to use shapes on the map to indicate the 3 major clade on my tree geographically. However, when I add a pch argument in, it correctly changes the shapes but the points then become black instead of following the colour that they were before. The lines from the tree to the map maintain the colour, it is just the points themselves that seem to turn black.
This is how I have tried to change the shape of the points:
# Original code - points
cols <-setNames(colorRampPalette(RColorBrewer::brewer.pal(n=6, name="Dark2"))(Ntip(myTree)),myTree$tip.label)
obj<-phylo.to.map(rooted_cladogram,coords,database="worldHires", regions="UK",plot=FALSE,xlim=c(-11,3), ylim=c(49,59),direction="rightwards")
plot(obj,direction="rightwards",fsize=0.5,cex.points=c(0,1), colors=cols,lwd=c(3,1),ftype="i")
Point and lines are coloured. I would like to change the shape of points
# Code to change points = but points are no longer coloured
shapes <- c(rep(2,2),rep(1,2),rep(0,2))
obj<-phylo.to.map(rooted_cladogram,coords,database="worldHires", regions="UK",plot=FALSE,xlim=c(-11,3), ylim=c(49,59),direction="rightwards")
plot(obj,direction="rightwards",fsize=0.5,cex.points=c(0,1), colors=cols,pch=shapes,lwd=c(3,1),ftype="i")
Output: The shapes are changed but they are no longer coloured in:
Question 3: How do I add a gradient to the map?
Given this fake dataset, how to I create a smoothed gradient of the value variable?
Any help and advice on this would be very much appreciated.
It would also be useful to know how to change the size of points
Thank you very much in advance,
Eve
I improved (somewhat) on my comments by using the map you made in your question. Here's the code:
library(mapdata)
library(phytools)
library(ggplot2)
myTree <- ape::read.tree(text='((A, B), ((C, D), (E, F)));')
plot(myTree)
# It needs to be rooted for `phylo.to.map()` to work
myTree$branch.length = NULL
rooted_cladogram = ape::compute.brlen(myTree)
# Sample information
Sample <- c("A","B","C","D","E","F")
coords <- matrix(
c(56.001966,
57.069417,
50.70228,
51.836213,
54.678997,
54.67831,
-5.636926,
-2.47805,
-3.8975018,
-2.235444,
-3.4392211,
-1.751833),
nrow=6,
ncol=2)
rownames(coords) <- Sample
head(coords)
obj <- phylo.to.map(
rooted_cladogram,
coords,
database="worldHires",
regions="UK",
plot=FALSE,
xlim=c(-11,3),
ylim=c(49,59),
direction="rightwards")
# Disable default map
obj2 <- obj
obj2$map$x <- obj$map$x[1]
obj2$map$y <- obj$map$y[1]
# Set plot parameters
cols <- setNames(
colorRampPalette(
RColorBrewer::brewer.pal(n=6, name="Dark2"))(Ntip(myTree)),myTree$tip.label)
shapes <- c(rep(2,2),rep(1,2),rep(0,2))
sizes <- c(1, 2, 3, 4, 5, 6)
# Plot phylomap
plot(
obj2,
direction="rightwards",
fsize=0.5,
cex.points=0,
colors=cols,
pch=shapes,
lwd=c(3,1),
ftype="i")
# Plot new map area that only includes GB
uk <- map_data(
map = "worldHires",
region = "UK")
gb <- uk[uk$subregion == "Great Britain",]
points(x = gb$long,
y = gb$lat,
cex = 0.001)
# Plot points on map
points(
x = coords[,2],
y = coords[,1],
pch = shapes,
col = cols,
cex = sizes)
e: Use sf object instead of points to illustrate GB. It is tough to provide more advice beyond this on how to add symbology for your spatially varying variable, but sf is popular and very well documented, e.g. https://r-spatial.github.io/sf/articles/sf5.html. Let me know if you have any other questions!
ee: Added lines to plot name and symbol on tips.
eee: Added gradient dataset to map.
library(phytools)
library(mapdata)
library(ggplot2)
library(sf)
myTree <- ape::read.tree(text='((A, B), ((C, D), (E, F)));')
plot(myTree)
# It needs to be rooted for `phylo.to.map()` to work
myTree$branch.length = NULL
rooted_cladogram = ape::compute.brlen(myTree)
# Sample information
Sample <- c("A","B","C","D","E","F")
coords <- matrix(c(56.001966,57.069417,50.70228, 51.836213, 54.678997, 54.67831,-5.636926,-2.47805,-3.8975018, -2.235444,-3.4392211, -1.751833), nrow=6, ncol=2)
rownames(coords) <- Sample
head(coords)
obj <- phylo.to.map(
rooted_cladogram,
coords,
database="worldHires",
regions="UK",
plot=FALSE,
xlim=c(-11,3),
ylim=c(49,59),
direction="rightwards")
# Disable default map
obj2 <- obj
obj2$map$x <- obj$map$x[1]
obj2$map$y <- obj$map$y[1]
## Plot tree portion of map
# Set plot parameters
cols <- setNames(
colorRampPalette(
RColorBrewer::brewer.pal(n=6, name="Dark2"))(Ntip(myTree)),myTree$tip.label)
shapes <- c(rep(2,2),rep(1,2),rep(0,2))
sizes <- c(1, 2, 3, 4, 5, 6)
# Plot phylomap
plot(
obj2,
direction="rightwards",
fsize=0.5,
cex.points=0,
colors=cols,
pch=shapes,
lwd=c(3,1),
ftype="i")
tiplabels(pch=shapes, col=cols, cex=0.7, offset = 0.2)
tiplabels(text=myTree$tip.label, col=cols, cex=0.7, bg = NA, frame = NA, offset = 0.2)
## Plot GB portion of map
# Plot new map area that only includes GB
uk <- map_data(map = "worldHires", region = "UK")
gb <- uk[uk$subregion == "Great Britain",]
# Convert GB to sf object
gb_sf <- st_as_sf(gb, coords = c("long", "lat"))
# Covert to polygon
gb_poly <- st_sf(
aggregate(
x = gb_sf$geometry,
by = list(gb_sf$region),
FUN = function(x){st_cast(st_combine(x), "POLYGON")}))
# Add polygon to map
plot(gb_poly, col = NA, add = TRUE)
## Load and format gradient data as sf object
# Load data
g <- read.csv("gradient_data.txt", sep = " ", na.strings = c("NA", " "))
# Check for, then remove NAs
table(is.na(g))
g2 <- g[!is.na(g$Lng),]
# For demonstration purposes, make dataset easier to manage
# Delete this sampling line to use the full dataset
g2 <- g2[sample(1:nrow(g2), size = 1000),]
# Create sf point object
gpt <- st_as_sf(g2, coords = c("Lng", "Lat"))
## Set symbology and plot
# Cut data into 5 groups based on "value"
groups <- cut(gpt$value,
breaks = seq(min(gpt$value), max(gpt$value), len = 5),
include.lowest = TRUE)
# Set colors
gpt$colors <- colorRampPalette(c("yellow", "red"))(5)[groups]
# Plot
plot(gpt$geometry, pch = 16, col = gpt$colors, add = TRUE)
## Optional legend for gradient data
# Order labels and colors for the legend
lev <- levels(groups)
# Used rev() here to make colors in correct order
fil <- rev(levels(as.factor(gpt$colors)))
legend("topright", legend = lev, fill = fil, add = TRUE)
## Plot sample points on GB
# Plot points on map
points(
x = coords[,2],
y = coords[,1],
pch = shapes,
col = cols,
cex = sizes)
see here for more info on gradient symbology and legends: R: Gradient plot on a shapefile
I found many resources on how to draw Venn diagrams in R. Stack Overflow has a lot of them. However, I still can't draw my diagrams the way I want. Take the following code as an example:
library("VennDiagram")
A <- 1:4
B <- 3:6
d <- list(A, B)
vp <- venn.diagram(d, fill = c("white", "white"), alpha = 1, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp)
I want the intersection between the sets to be red. However, if I change any of the white colors to red, I get the following:
vp_red <- venn.diagram(d, fill = c("red", "white"), alpha = 1, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp_red)
That's not quite what I want. I want only the intersection to be red. If I change the alpha, this is what I get:
vp_alpha <- venn.diagram(d, fill = c("red", "white"), alpha = 0.5, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp_alpha)
Now I have pink in my intersection. This is not what I want as well. What I want is something like this image from Wikipedia:
How can I do this? Maybe VennDiagram package can't do it and I need some other package, but I've been testing different ways to do it, and I'm not being able to find a solution.
I will show two different possibilities. In the first example, polyclip::polyclip is used to get the intersection. In the second example, circles are converted to sp::SpatialPolygons and we get the intersection using rgeos::gIntersection. Then we re-plot the circles and fill the intersecting area.
The resulting object when using venn.diagram is
"of class gList containing the grid objects that make up the diagram"
Thus, in both cases we can grab relevant data from "vp". First, check the structure and list the grobs of the object:
str(vp)
grid.ls()
# GRID.polygon.234
# GRID.polygon.235
# GRID.polygon.236 <~~ these are the empty circles
# GRID.polygon.237 <~~ $ col : chr "black"; $ fill: chr "transparent"
# GRID.text.238 <~~ labels
# GRID.text.239
# GRID.text.240
# GRID.text.241
# GRID.text.242
1. polyclip
Grab x- and y-values, and put them in the format required for polyclip:
A <- list(list(x = as.vector(vp[[3]][[1]]), y = as.vector(vp[[3]][[2]])))
B <- list(list(x = as.vector(vp[[4]][[1]]), y = as.vector(vp[[4]][[2]])))
Find intersection:
library(polyclip)
AintB <- polyclip(A, B)
Grab labels:
ix <- sapply(vp, function(x) grepl("text", x$name, fixed = TRUE))
labs <- do.call(rbind.data.frame, lapply(vp[ix], `[`, c("x", "y", "label")))
Plot it!
plot(c(0, 1), c(0, 1), type = "n", axes = FALSE, xlab = "", ylab = "")
polygon(A[[1]])
polygon(B[[1]])
polygon(AintB[[1]], col = "red")
text(x = labs$x, y = labs$y, labels = labs$label)
2. SpatialPolygons and gIntersection
Grab the coordinates of the circles:
# grab x- and y-values from first circle
x1 <- vp[[3]][["x"]]
y1 <- vp[[3]][["y"]]
# grab x- and y-values from second circle
x2 <- vp[[4]][["x"]]
y2 <- vp[[4]][["y"]]
Convert points to SpatialPolygons and find their intersection:
library(sp)
library(rgeos)
p1 <- SpatialPolygons(list(Polygons(list(Polygon(cbind(x1, y1))), ID = 1)))
p2 <- SpatialPolygons(list(Polygons(list(Polygon(cbind(x2, y2))), ID = 2)))
ip <- gIntersection(p1, p2)
Plot it!
# plot circles
plot(p1, xlim = range(c(x1, x2)), ylim = range(c(y1, y2)))
plot(p2, add = TRUE)
# plot intersection
plot(ip, add = TRUE, col = "red")
# add labels (see above)
text(x = labs$x, y = labs$y, labels = labs$label)
I'm quite sure you could work directly on the grobs using clipping functions in grid or gridSVG package.
It's very easy in eulerr R package
library(eulerr)
plot(euler(c("A"=5,"B"=4,"A&B"=2)),quantities = TRUE,fills=c("white","white","red"))
euler set colours
Continue from my previous question 'create vectorplot from velocity dataset'. I still have 2 question how to make the figure look like below:
1) How to make the region interpolation? I have tried used interpolate = TRUE but didn't work.
2) How to define the arrow symbol with the same length (It's mean the arrow only show the velocity direction)
Here my data uv.nc and syntax I have written:
library (raster)
flname <- 'uv.nc'
u <- raster(flname, varname = 'U')
v <- raster(flname, varname = 'V')
uv <- stack(u,v)
s <- sqrt(u^2 + v^2)
library(rasterVis)
jet <- colorRampPalette(c('#00007F', 'blue', '#007FFF', 'cyan','#7FFF7F', 'yellow', '#FF7F00', 'red', '#7F0000'))
range = seq(0, 0.5, 0.05)
vectorplot(uv, isField = 'dXY', interpolate = TRUE, col.regions = jet, region=s, length=0.05)
(First question) The interpolate argument needs the panel.levelplot.raster function to be called by levelplot (used internally by vectorplot to render the background). However, this does not work directly with the current version of rasterVis. You can try this trick:
levelplot(s,
panel = panel.levelplot.raster,
interpolate = TRUE,
margin = FALSE) +
vectorplot(uv, isField = 'dXY', region = FALSE)
(Second question) The length of the arrows is determined by your data, because you are using dXY = TRUE. Thus, you should use modify your data to get vectors with the same magnitude.
uv0 <- uv / s
vectorplot(uv0, isField = 'dXY', region = s)
While working in GeoDa on a data set of the US Census Shapefiles I can quickly create a connectivity histogram shown below:
Assuming that my data is sourced in the following manner:
# Download an read US state shapefiles
tmp_shps <- tempfile(); tmp_dir <- tempdir()
download.file("http://www2.census.gov/geo/tiger/GENZ2014/shp/cb_2014_us_state_20m.zip",
tmp_shps)
unzip(tmp_shps, exdir = tmp_dir)
# Libs
require(rgdal); require(ggplot2)
# Read
us_shps <- readOGR(dsn = tmp_dir, layer = "cb_2014_us_state_20m")
How can I arrive at a similar connectivity histogram in R? Addittionally, I would be interested in creating a meanigful histogram derived from distance matrix created in the following manner:
require(geospacom)
dzs_distmat <- DistanceMatrix(poly = us_shps, id = "GEOID",
unit = 1000, longlat = TRUE, fun = distHaversine)
In practice, I'm interested in achieving the following objectives:
Summarising how often geographies border one another, ideally through a connectivity histogram shown above
Summarising information on distances amongst geographies
I played around with it a bit. This seems to be a start.
For your second point. Can you be more specific? I guess a simple histogram or density plot would summarise just fine? I.e. something like:
dists <- dzs_distmat[lower.tri(dzs_distmat)]
hist(dists, xlab = "Dist",
main = "Histogram of distances",
col = "grey")
abline(v = mean(dists), col = "red", lwd = 2)
Regarding your first point, the following should be a very non-fancy version of the histogram you present. (But it doesn't look like it very much?!) It should be a histogram of the number of touching neighbours following this post.
library("rgeos")
# Get adjencency matrix
adj <- gTouches(us_shps, byid = TRUE)
# Add names
tmp <- as.data.frame(us_shps)$STATEFP
dimnames(adj) <- list(tmp, tmp)
# Check names
stopifnot(all(rownames(adj) == rownames(dzs_distmat))) # Sanity check
hist(rowSums(adj), col = "grey", main = "Number of neighbours",
breaks = seq(-0.5, 8.5, by = 1))
I guess the fancy colours can be added relatively easily.
Using spdep you could identify the spatial neighbors of the regions using the the poly2nb function and then plot the histogram using the card function. Ex:
nb_q <- poly2nb(us_shp, queen = T)
hist(card(nb_q), col = "grey", main = "Number of neighbours", breaks = seq(-0.5, 8.5, by = 1))