Related
I am trying to color in specific grid cells within a map to highlight sampling effort.
I can generate the map but then I am unsure how to utilize the data points I have to color in the entire grid cell. The data points I have are for the top left hand corner of a grid cell.
I have tried using stat_density2d (kernel density func), as far as I can work out the issue is I just want the discrete values plotted but currently it is filling in everything in-between.
library(ggOceanMaps)
library(ggOceanMapsData)
dt <- data.frame(lon = c(35, 35, 60, 60), lat = c(-25, -25, -40, -40))
grid_2_colour <- data.frame(lat=c(-29), long=c(50))
basemap(data = dt, bathymetry = TRUE,
lon.interval = 1,
lat.interval = 1,
# bathy.style = "contour_blues",
bathy.border.col = NA,
bathy.size = 0.1,
bathy.alpha = 1) +
stat_density2d(data = grid_2_colour, aes(x = long, y = lat, fill =..density..), geom = 'tile', contour = F)
found a solution:
m1 = basemap(data = dt, bathymetry = TRUE,
lon.interval = 1,
lat.interval = 1,
# bathy.style = "contour_blues",
bathy.border.col = NA,
bathy.size = 0.1,
bathy.alpha = 1)
m1 + stat_density2d(data = grid_2_colour, aes(x = long, y = lat, fill =..density..), geom = 'tile', contour = F)
I have created the following model and predictions but I'm having trouble with the code to plot the predictions. I think it's a dimensions issue, does anyone know the changes I need to make for this to work?
code used;
#variogram
summer_vario = variog(geo_summer_df2, option = 'bin', estimator.type='modulus', bin.cloud = TRUE)
#fitting a basic parametric model
defult_summer_mod = variofit(summer_vario)
#creating predictions
preds_grid = matrix(c(-5.697, 55.441, -0.807, 51.682, -5.328, 50.218, -2.451, 54.684, -4.121, 50.355, -1.586, 54.768, -0.131, 51.505, -4.158, 52.915,
-0.442, 53.875, -3.413, 56.214, -2.860, 54.076, -3.323, 57.711, 0.566, 52.651, -0.626, 54.481, -1.185, 60.139, -2.643, 51.006,
-1.491, 53.381, -1.536, 52.424, -6.319, 58.213, -1.992, 51.503), nrow = 20, byrow = TRUE)
summer_preds = krige.conv(geo_summer_df2, locations = preds_grid, krige = krige.control(obj.model = defult_summer_mod))
#plotting predictions
#mean
image(summer_preds, col = viridis::viridis(100), zlim = c(100, max(c(summer_preds$predict))),
coords.data = geo_summer_df2[1]$coords, main = 'Mean', xlab = 'x', ylab = 'y',
x.leg = c(700, 900), y.leg = c(20, 70))
#variation
image(summer_preds, values = summer_preds$krige.var, col = heat.colors(100)[100:1],
zlim = c(0,max(c(summer_preds$krige.var))), coords.data = geo_summer_df2[1]$coords,
main = 'Variance', xlab = 'x', ylab = 'y', x.leg = c(700, 900), y.leg = c(20, 70))
data used;
https://drive.google.com/file/d/1ngwto6hgqCumoDsStOtPoG2J5EbmqxDf/view?usp=sharing
https://drive.google.com/file/d/1s9yBHsgaFRlF38CgiXCf_vum1DyhEbz4/view?usp=sharing
data changes made before code at the top of the page
#converting data to long format and combining both dataframes
MaxTemp %>%
pivot_longer(.,Machrihanish:Lyneham, names_to = "Location") %>%
full_join(.,metadata) -> MaxTemp_df
#renaming value column to temperature
MaxTemp_df = MaxTemp_df %>%
rename(Temp = 'value')
#filtering data for summer months
summer_df = MaxTemp_df %>%
filter(Date >= 20200701 & Date <=20200731)
#converting our data to geodata
geo_summer_df = as.geodata(summer_df, coords.col = 4:5, data.col = 3)
geo_summer_df2 = jitterDupCoords(geo_summer_df, max = 0.1, min = 0.05)
You're right about the dimensions. The predictions should be made over a regular grid of locations if you want to plot them as an image. Get all the unique x co-ordinates and all the unique y co-ordinates, sort them, then use expand.grid to get x, y co-ordinates for the whole grid. You'll then need to use this for kriging.
When you come to drawing the image, you need to arrange the predictions into a matrix:
xvals <- sort(unique(preds_grid[,1]))
yvals <- sort(unique(preds_grid[,2]))
preds_grid <- as.matrix(expand.grid(xvals, yvals))
colnames(preds_grid) <- NULL
summer_preds = krige.conv(geo_summer_df2, locations = preds_grid,
krige = krige.control(obj.model = default_summer_mod))
image(xvals, yvals, matrix(summer_preds$predict, nrow = length(xvals)),
col = viridis::viridis(100), main = 'Mean', xlab = 'x', ylab = 'y')
image(xvals, yvals, matrix(summer_preds$krige.var, nrow = length(xvals)),
col = heat.colors(100)[100:1], main = 'Variance', xlab = 'x', ylab = 'y')
Note that you will get better images if you use a finely-spaced sequence for x and y:
xvals <- seq(-7, 1, 0.1)
yvals <- seq(50, 62, 0.1)
The plots this produces with the same code otherwise are:
Update - using ggplot
The following adds the data to an outline of the British Isles:
devtools::install_github("ropensci/rnaturalearthhires")
library(rnaturalearth)
xvals <- seq(-7, 1, 0.1)
yvals <- seq(50, 62, 0.1)
preds_grid <- as.matrix(expand.grid(xvals, yvals))
summer_preds <- krige.conv(
geo_summer_df2, locations = preds_grid,
krige = krige.control(obj.model = default_summer_mod))
df <- as.data.frame(cbind(preds_grid,
mean = summer_preds$predict,
var = summer_preds$krige.var))
gb <- sf::st_crop(ne_coastline(scale = 10, returnclass = 'sf'),
xmin = -7, xmax = 1, ymin = 50, ymax = 62)
ggplot(gb) +
geom_tile(data = df, aes(Var1, Var2, fill = mean),
width = 0.11, height = 0.11, size = 0) +
geom_sf() +
scale_fill_viridis_c() +
ggtitle('Mean')
ggplot(gb) +
geom_tile(data = df, aes(Var1, Var2, fill = var),
width = 0.11, height = 0.11, size = 0) +
geom_sf() +
scale_fill_gradientn(colors = heat.colors(100, rev = TRUE)) +
ggtitle('Variance')
I have a data frame of lat lons that surround a center point. The lat lons represent two groups. The groups are represented with a 1 or a 0. I can plot around the center point with different shapes
and colors, but then I would like the colors to be more distinct. I would also like to plot two circles around the points, 300 meters, and 600 meters respectively. I have tried working with
Plot circle with a certain radius around point on a map in ggplot2
but have had no luck
a small sample looks like this
lat <- c(42.99052, 42.99085, 42.99046, 42.99081, 42.99197, 42.99122, 42.99154,42.99161, 42.99102, 42.99014, 42.98966, 42.99091, 42.99092, 42.99114 ,42.99000)
lon <-c(78.69961, -78.69871, -78.69878, -78.69868, -78.69825, -78.69929, -78.69784, -78.69960, -78.69904, -78.69918, -78.69998, -78.69746, -78.70145, -78.70020, -78.70010)
response <- c(0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 1)
data <- data.frame(lat, lon, response)
My center point is
(42.990707, -78.698899)
I get my map without circles and distinct colors like this
library(ggplot2)
library(ggmap)
library(viridis)
#getting map
mapgilbert <- get_map(location = c(lon = -78.698899 , lat=42.990707), zoom = 17,
maptype = "terrain", scale = 2)
ggmap(mapgilbert) +
geom_point(data = data, aes(x = lon, y = lat, color = response , alpha = 1, fill = response),
size = 2, shape = response) +
guides(fill = FALSE, alpha = FALSE, size = FALSE) +
scale_color_viridis(begin = 0, end = .7)
any help would be appreciated.
I got the solution by modifying the answer in
Plot circle with a certain radius around point on a map in ggplot2
center_df<-data.frame(ID=c(1),lon=c(-78.698899),lat=c(42.990707))
make_circles <- function(centers, radius, nPoints = 500){
# centers: the data frame of centers with ID
# radius: radius measured in kilometer
#
meanLat <- mean(centers$lat)
# length per longitude changes with lattitude, so need correction
radiusLon <- radius /111 / cos(meanLat/57.3)
radiusLat <- radius / 111
circleDF <- data.frame(ID = rep(centers$ID, each = nPoints))
angle <- seq(0,2*pi,length.out = nPoints)
circleDF$lon <- unlist(lapply(centers$lon, function(x) x + radiusLon * cos(angle)))
circleDF$lat <- unlist(lapply(centers$lat, function(x) x + radiusLat * sin(angle)))
return(circleDF)
}
myCircles <- make_circles(center_df, 0.2)
myCircles2 <- make_circles(center_df, 0.1)
mapgilbert2<- get_map(location = c(lon = -78.70000 , lat=42.991107), zoom = 16,
maptype = "terrain", scale = 2)
ggmap(mapgilbert2)+
geom_point(data = data, aes(x = lon, y = lat, fill=as.factor(exposure) , alpha = 1), size = 2, pch=21)+
guides(fill=FALSE, alpha=FALSE, size=guide_legend)+
scale_color_viridis(begin = 0, end = .7)+
geom_point(data=myCircles,aes(x=lon,y=lat), color='red')+
geom_point(data=myCircles2,aes(x=lon,y=lat), color='blue')+
scale_fill_manual(values=c("purple", "green"))
I'm producing a whole pile of graphs of changing sizes. I want each graph to display a symbol (say, asterisk) at a specific point on the graph margin (top y-axis value), regardless of plot size. Right now I do it manually by defining x/y for each textGrob, but there has got to be a better way.
Plot size is determined by number of categories in the dataset (toy data below). Ideally, the output plots would have identical panel sizes (I'm assuming that can be controlled through defining margin sizes in inches and adding that value to the height parameter?). Widths don't usually change, but it would be nice to automate both x and y placements based on the defined device width (and plot margins).
Thanks so much!
library(ggplot2)
library(gridExtra)
set.seed(123)
df <- data.frame(x = rnorm(20, 0, 1), y = rnorm(20, 0, 1), category = rep(c("a", "b"), each = 10))
## plot 1
sub <- df[df$category == "a",]
height = 2*length(unique(sub$category))
p <- ggplot(sub) +
geom_point(aes(x = x, y = y)) +
facet_grid(category ~ .)
jpeg(filename = "fig1.jpg",
width = 6, height = height, units = "in", pointsize = 12, res = 900,
quality = 100)
g <- arrangeGrob(p, sub = textGrob("*", x = 0.07, y = 10.15, hjust = 0, vjust=0, #### puts the top discharge value; might need to be adjusted manually in following years
gp = gpar(fontsize = 15)))
grid.draw(g)
dev.off()
## plot 2
height = 2*length(unique(df$category))
p <- ggplot(df) +
geom_point(aes(x = x, y = y)) +
facet_grid(category ~ .)
jpeg(filename = "fig2.jpg",
width = 6, height = height, units = "in", pointsize = 12, res = 900,
quality = 100)
g <- arrangeGrob(p, sub = textGrob("*", x = 0.07, y = 23.1, hjust = 0, vjust=0, #### puts the top discharge value; might need to be adjusted manually in following years
gp = gpar(fontsize = 15)))
grid.draw(g)
dev.off()
Is there any chance to write text which is "wrapped" around the circle? I mean something like this:
Yes, and here is the code, free of charge :-) . I wrote this a while back but I don't think ever published it in any CRAN package.
# Plot symbols oriented to local slope.
# Interesting problem: if underlying plot has some arbitrary aspect ratio,
# retrieve by doing: Josh O'B via SO:
# myasp <- with(par(),(pin[2]/pin[1])/(diff(usr[3:4])/diff(usr[1:2])))
# so make that the default value of argument 'asp'
# Default is 'plotx' is vector of indices at which to
# plot symbols. If is_indices=FALSE, only then turn to splinefun to
# calculate y-values and slopes; and user beware.
#
# 6 Feb 2014: added default col arg so can stick in a color vector if desired
# TODO
#
slopetext<-function(x,y,plotx, mytext, is_indices=TRUE, asp=with(par(), (pin[1]/pin[2])*(diff(usr[3:4])/diff(usr[1:2]))),offsetit= 0, col='black', ...) {
if (length(x) != length(y)) stop('data length mismatch')
if (!is.numeric(c(x,y,plotx) ) ) stop('data not numeric')
if(is_indices) {
# plotting at existing points.
if(any(plotx<=1) | any(plotx>= length(x))) {
warning("can't plot endpoint; will remove")
plotx<-plotx[(plotx>1 & plotx<length(x))]
}
lows<-plotx-1
highs<-plotx+1
# then interpolate low[j],high[j] to get slope at x2[j]
slopes <- (y[highs]-y[lows])/(x[highs]-x[lows]) #local slopes
# sign(highlow) fix the rotation problem
angles <- 180/pi*atan(slopes/asp) + 180*(x[lows] > x[highs] )
intcpts <- y[highs]-slopes*x[highs]
ploty <- intcpts + x[plotx]*slopes
# change name, so to speak, to simplify common plotting code
plotx<-x[plotx]
}else{
#interpolating at plotx values
if (any(plotx<min(x)) | any(plotx>max(x)) ) {
warning("can't plot extrapolated point; will remove")
plotx<-plotx[(plotx>min(x) & plotx<max(x))]
}
spf<-splinefun(x,y)
ploty<-spf(plotx)
angles <- 180/pi * atan(spf(plotx,1)/asp) #getting first deriv, i.e. slope
} #end of else
xlen<-length(plotx) # better match y and mytext
# The trouble is: srt rotates about some non-centered value in the text cell
# Dunno what to do about that.
dely <- offsetit*cos(angles)
delx <- offsetit*sin(angles)
# srt must be scalar
mytext<-rep(mytext,length=xlen)
col <- rep(col,length=xlen)
for (j in 1:xlen) text(plotx[j], ploty[j], labels=mytext[j], srt= angles[j], adj=c(delx,dely),col=col[j], ...)
}
Edit: per David's excellent suggestion, a sample case:
x <- 1:100
y <- x/20 + sin(x/10)
plot(x,y,t='l')
slopetext(x=x,y=y,plotx=seq(10,70,by=10),mytext=letters[1:8])
The third argument in this example selects every tenth value of (x,y) for placement of the text.
I should warn that I haven't idiot-proofed the is_indices=FALSE case and the spline fit may in extreme cases place your text in funny ways.
plotrix::arctext
library(plotrix)
# set up a plot with a circle
plot(x = 0, y = 0, xlim = c(-2, 2), ylim = c(-2, 2))
draw.circle(x = 0, y = 0, radius = 1)
# add text
arctext(x = "wrap some text", center = c(0, 0), radius = 1.1, middle = pi/2)
arctext(x = "counterclockwise", center = c(0, 0), radius = 1.1, middle = 5*pi/4,
clockwise = FALSE, cex = 1.5)
arctext(x = "smaller & stretched", center = c(0, 0), radius = 1.1, middle = 2*pi ,
cex = 0.8, stretch = 1.2)
circlize
For greater opportunities of customization, check the circlize package (see the circlize book). By setting facing = "bending" in circos.text, the text wraps around a circle.
library(circlize)
# create some angles, labels and their corresponding factors
# which determine the sectors
deg <- seq(from = 0, to = 300, by = 60)
lab <- paste("some text", deg, "-", deg + 60)
factors <- factor(lab, levels = lab)
# initialize plot
circos.par(gap.degree = 10)
circos.initialize(factors = factors, xlim = c(0, 1))
circos.trackPlotRegion(ylim = c(0, 1))
# add text to each sector
lapply(factors, function(deg){
circos.updatePlotRegion(sector.index = deg, bg.col = "red")
circos.text(x = 0.5, y = 0.5, labels = as.character(deg), facing = "bending")
})
circos.clear()
From circlize version 0.2.1, circos.text has two new options: bending.inside which is identical to original bending and bending.outside (see Figure 3.4 in the circlize book). Thus, it is easy to turn the text in the bottom half of the plot using bending.outside:
circos.par(gap.degree = 10)
circos.initialize(factors = factors, xlim = c(0, 1))
circos.trackPlotRegion(ylim = c(0, 1))
lapply(factors[1:3], function(deg){
circos.updatePlotRegion(sector.index = deg, bg.col = "red")
circos.text(x = 0.5, y = 0.5, labels = as.character(deg), facing = "bending.outside")
})
lapply(factors[4:6], function(deg){
circos.updatePlotRegion(sector.index = deg, bg.col = "red")
circos.text(x = 0.5, y = 0.5, labels = as.character(deg), facing = "bending.inside")
})
circos.clear()
The figure in the question can now be recreated quite easily in ggplot using the geomtextpath package:
library(geomtextpath)
df <- data.frame(x = c(0, 5.5, 6, 5.2, 0, 0.5, 0) + 8 * rep(0:5, each = 7),
y = rep(c(0, 0, 1, 2, 2, 1, 0), 6) + 8,
id = rep(1:6, each = 7))
df2 <- data.frame(x = c(3, 11, 19, 27, 35, 43), y = 9, id = 1:6,
z = paste("text", 0:5 * 60))
ggplot(df, aes(x, y, group = id)) +
geom_polygon(fill = "red", color = "black") +
geom_hline(yintercept = 9, color = "red", alpha = 0.3, size = 7) +
geom_textpath(data = df2, aes(label = z), size = 7, upright = FALSE) +
ylim(c(0, 10)) +
xlim(c(0, 48)) +
coord_polar(theta = "x", direction = -1, start = -pi/4) +
theme_void()
Disclaimer: I'm co-author of said package.