I have two matrices of bearing and speed data for ocean currents
bearings <- matrix(data = c(170.0833, 175.6863, 182.3538, 180.3335, 170.8965,
178.3276, 182.3693, 187.2196, 182.3533, 168.3498,
189.1664, 187.6813, 187.0393, 180.2259, 166.8412,
193.4223, 188.5367, 182.4128, 175.2626, 167.3058,
192.2930, 185.5073, 175.0302, 168.6284, 167.8392),
ncol = 5, nrow = 5, byrow = F)
speed <- matrix(data = c(0.1389173, 0.1585099, 0.1796583, 0.2021887, 0.2117295,
0.1196745, 0.1463118, 0.1637266, 0.1730471, 0.1804999,
0.1309982, 0.1546123, 0.1593298, 0.1517513, 0.1550037,
0.1621728, 0.1694083, 0.1606560, 0.1459710, 0.1457233,
0.1659898, 0.1535861, 0.1396885, 0.1294339, 0.1337756),
ncol = 5, nrow = 5, byrow = F)
I wanted to graph the direction of the current bearings with arrows, while the magnitude/speed of the current is represented by the length of the arrow, a bit something like these maps:
Wind stress figure taken from Shankar et al. 2002
I know the package oce may be able to do something like that, but it specifically works with different types of oceanographic data rather than matrices/data frames that I'm using.
Anyone happen to know how to do that? I have gotten as far as making them into raster objects using the raster() function from the raster library:
library(raster)
bearing.rst <- raster(bearings,
xmn = 66,
xmx = 67.3333,
ymn = 10.6667,
ymx = 12)
speed.rst <- raster(speed,
xmn = 66,
xmx = 67.3333,
ymn = 10.6667,
ymx = 12)
Ideally I'd do this with base R graphics, or with a package that plays nice with base R graphics (e.g. not ggplot2 or lattice).
Graph from:
Shankar, D., Vinayachandra, P.N., & Unnikrishnan, A.S. (2002). The monsoon currents in the north Indian Ocean. Progress in Oceanography, 52: 62-120. doi: 10.1016/S0079-6611(02)00024-1
with base R:
plot(bearing.rst) # your base map, I use this because I didn't have it
Get your starting coordinates:
arr.coor <- rasterToPoints(bearing.rst)
arr.coor <- cbind(arr.coor[,-3], bearing=c(t(bearings)), speed=c(t(speed)))
Calculate your finishing coordinates with trigonometric functions:
x1 <- arr.coor[,1] + arr.coor[,4] * cos(arr.coor[,3]*pi/180)
y1 <- arr.coor[,2] + arr.coor[,4] * sin(arr.coor[,3]*pi/180)
arr.coor <- cbind(arr.coor, x1, y1)
Plot your arrows:
arrows(arr.coor[,1],arr.coor[,2],arr.coor[,5],arr.coor[,6])
I guess the same principal could work with ggplot2. The idea is to get a table with all your arrows origin and end.
With ggplot
bearings <- c(170.0833, 175.6863, 182.3538, 180.3335, 170.8965,
178.3276, 182.3693, 187.2196, 182.3533, 168.3498,
189.1664, 187.6813, 187.0393, 180.2259, 166.8412,
193.4223, 188.5367, 182.4128, 175.2626, 167.3058,
192.2930, 185.5073, 175.0302, 168.6284, 167.8392)
speed <- c(0.1389173, 0.1585099, 0.1796583, 0.2021887, 0.2117295,
0.1196745, 0.1463118, 0.1637266, 0.1730471, 0.1804999,
0.1309982, 0.1546123, 0.1593298, 0.1517513, 0.1550037,
0.1621728, 0.1694083, 0.1606560, 0.1459710, 0.1457233,
0.1659898, 0.1535861, 0.1396885, 0.1294339, 0.1337756)
df <- data.frame(x = rep(1:5,5),
y = rep(1:5, each = 5),
bearings = bearings,
speed = speed)
df$dx <- sin((df$bearings)/360*pi*2)*df$speed
df$dy <- cos((df$bearings)/360*pi*2)*df$speed
ggplot(df, aes(x, y)) +
geom_segment(aes(xend = x + dx, yend = y + dy),
arrow = arrow(length = unit(0.1,"cm"))) +
theme_bw()
Related
I want to identify 3d cylinders in an rgl plot to obtain one attribute of the nearest / selected cylinder. I tried using labels to simply spell out the attribute, but I work on data with more than 10.000 cylinders. Therefore, it gets so crowded that the labels are unreadable and it takes ages to render.
I tried to understand the documentation of rgl and I guess the solution to my issue is selecting the cylinder in the plot manually. I believe the function selectpoints3d() is probably the way to go. I believe it returns all vertices within the drawn rectangle, but I don't know how to go back to the cylinder data? I could calculate which cylinder is closest to the mean of the selected vertices, but this seems like a "quick & dirty" way to do the job.
Is there a better way to go? I noticed the argument value=FALSE to get the indices only, but I don't know how to go back to the cylinders.
Here is some dummy data and my code:
# dummy data
cylinder <- data.frame(
start_X = rep(1:3, 2)*2,
start_Y = rep(1:2, each = 3)*2,
start_Z = 0,
end_X = rep(1:3, 2)*2 + round(runif(6, -1, 1), 2),
end_Y = rep(1:2, each = 3)*2 + round(runif(6, -1, 1), 2),
end_Z = 0.5,
radius = 0.25,
attribute = sample(letters[1:6], 6)
)
# calculate centers
cylinder$center_X <- rowMeans(cylinder[,c("start_X", "end_X")])
cylinder$center_Y <- rowMeans(cylinder[,c("start_Y", "end_Y")])
cylinder$center_Z <- rowMeans(cylinder[,c("start_Z", "end_Z")])
# create cylinders
cylinder_list <- list()
for (i in 1:nrow(cylinder)) {
cylinder_list[[i]] <- cylinder3d(
center = cbind(
c(cylinder$start_X[i], cylinder$end_X[i]),
c(cylinder$start_Y[i], cylinder$end_Y[i]),
c(cylinder$start_Z[i], cylinder$end_Z[i])),
radius = cylinder$radius[i],
closed = -2)
}
# plot cylinders
open3d()
par3d()
shade3d(shapelist3d(cylinder_list, plot = FALSE), col = "blue")
text3d(cylinder$center_X+0.5, cylinder$center_Y+0.5, cylinder$center_Z+0.5, cylinder$attribute, color="red")
# get attribute
nearby <- selectpoints3d(value=TRUE, button = "right")
nearby <- colMeans(nearby)
cylinder$dist <- sqrt(
(nearby["x"]-cylinder$center_X)**2 +
(nearby["y"]-cylinder$center_Y)**2 +
(nearby["z"]-cylinder$center_Z)**2)
cylinder$attribute[which.min(cylinder$dist)]
If you call selectpoints3d(value = FALSE), you get two columns. The first column is the id of the object that was found. Your cylinders get two ids each. One way to mark the cylinders is to use "tags". For example, this modification of your code:
# dummy data
cylinder <- data.frame(
start_X = rep(1:3, 2)*2,
start_Y = rep(1:2, each = 3)*2,
start_Z = 0,
end_X = rep(1:3, 2)*2 + round(runif(6, -1, 1), 2),
end_Y = rep(1:2, each = 3)*2 + round(runif(6, -1, 1), 2),
end_Z = 0.5,
radius = 0.25,
attribute = sample(letters[1:6], 6)
)
# calculate centers
cylinder$center_X <- rowMeans(cylinder[,c("start_X", "end_X")])
cylinder$center_Y <- rowMeans(cylinder[,c("start_Y", "end_Y")])
cylinder$center_Z <- rowMeans(cylinder[,c("start_Z", "end_Z")])
# create cylinders
cylinder_list <- list()
for (i in 1:nrow(cylinder)) {
cylinder_list[[i]] <- cylinder3d(
center = cbind(
c(cylinder$start_X[i], cylinder$end_X[i]),
c(cylinder$start_Y[i], cylinder$end_Y[i]),
c(cylinder$start_Z[i], cylinder$end_Z[i])),
radius = cylinder$radius[i],
closed = -2)
# Add tag here:
cylinder_list[[i]]$material$tag <- cylinder$attribute[i]
}
# plot cylinders
open3d()
par3d()
shade3d(shapelist3d(cylinder_list, plot = FALSE), col = "blue")
text3d(cylinder$center_X+0.5, cylinder$center_Y+0.5, cylinder$center_Z+0.5, cylinder$attribute, color="red")
# Don't get values, get the ids
nearby <- selectpoints3d(value=FALSE, button = "right", closest = FALSE)
ids <- nearby[, "id"]
# Convert them to tags. If you select one of the labels, you'll get
# a blank in the list of tags, because we didn't tag the text.
unique(tagged3d(id = ids))
When I was trying this, I found that using closest = TRUE in selectpoints3d seemed to get too many ids; there may be a bug there.
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
I am plotting multiple shapefiles using spplot. Here's a data to construct that
library(raster)
library(randomcoloR)
my.shp <- getData('GADM', country = 'BRA', level = 2)
my.shp$ID<- 1:nrow(my.shp)
My data consists of a variable X for 10 years as shown where each column is a year
df <- matrix(sample(100:5000, 55040, replace = T), nrow = 5504, ncol = 10)
df <- data.frame(ID = 1:nrow(my.shp), df)
my.dat <- merge(my.shp, df, by = "ID")
variable.names <- paste0("X",1:10)
spplot(my.dat, rev(variable.names), col = NA, at = seq(from = 100, to = 5000, by = 500),
col.regions = distinctColorPalette(length(seq(from = 100, to = 5000, by = 500))),
main = list(label = "TEST"))
My problem is this plot takes so much time (around an hour) to get plotted and was wondering if there is something inherently wrong in the code itself that it is taking too long to plot. My laptop has a 32 GB RAM.
Thanks
I haven't compared this plot to your spplot because I don't want to spend an hour waiting for it.
Instead I'm proposing to use library(mapdeck) to plot an interactive map, which takes a matter of seconds.
Two things to note
You need a Mapbox Access token
You need to convert the sp object to sf
library(raster)
my.shp <- getData('GADM', country = 'BRA', level = 2)
my.shp$ID <- 1:nrow(my.shp)
df <- matrix(sample(100:5000, 55040, replace = T), nrow = 5504, ncol = 10)
df <- data.frame(ID = 1:nrow(my.shp), df)
my.dat <- merge(my.shp, df, by = "ID")
library(sf)
sf <- sf::st_as_sf( my.dat )
library(mapdeck)
set_token( "YOUR_MAPBOX_TOKEN" )
mapdeck() %>%
add_sf(
data = sf
, fill_colour = "GID_2"
)
Are you willing/able to switch to sf instead of sp?
The sf plot function is considerably faster than spplot, although the layout differs a bit.
library(sf)
my.dat_sf <- st_as_sf(my.dat)
plot(my.dat_sf[rev(variable.names)], max.plot=10, breaks=c(seq(from = 100, to = 5000, by = 500),5000),
pal = distinctColorPalette(length(seq(from = 100, to = 5000, by = 500))),
main = "TEST", border=NA, key.pos=4)
Additionally, you could try to simplify the polygon with rmapshaper::ms_simplify() for Spatial*-objects or sf::st_simplify() for SimpleFeatures, which lets you reduce the object size by quite a bit, depending on the given dTolerance. Thus plotting, will also be faster with simplified polygons.
The original SpatialPolygon:
format(object.size(my.dat_sf), units="Kb")
"25599.2 Kb"
and a simplified SimpleFeature:
dat_sf_simple <- st_transform(my.dat_sf, crs = 3035)
dat_sf_simple <- st_simplify(dat_sf_simple, dTolerance = 1000, preserveTopology = T)
dat_sf_simple <- st_transform(dat_sf_simple, crs = 4326)
format(object.size(dat_sf_simple), units="Kb")
"7864.2 Kb"
Plot the simplified SimpleFeature, which takes about 1 minute on my machine with 8GB RAM.
plot(dat_sf_simple[rev(variable.names)], max.plot=10, breaks=c(seq(from = 100, to = 5000, by = 500),5000),
pal = distinctColorPalette(length(seq(from = 100, to = 5000, by = 500))),
main = "TEST", border=NA, key.pos=4)
You could also try out with ggplot2, but I am pretty sure the most performant solution will be the sf plot.
library(ggplot2)
library(dplyr)
library(tidyr)
dat_sf_simple_gg <- dat_sf_simple %>%
dplyr::select(rev(variable.names), geometry) %>%
gather(VAR, SID, -geometry)
ggplot() +
geom_sf(data = dat_sf_simple_gg, aes(fill=SID)) +
facet_wrap(~VAR, ncol = 2)
I'm plotting legs of a route to a ggmap. It works okay so far. I've been trying to add a label containing the order (n from the loop) of each leg.
I've tried +geom_text to the geom_leg() but I get the error :
Error in geom_leg(aes(x = startLon, y = startLat, xend = endLon, yend = endLat), :
non-numeric argument to binary operator
I'd appreciate any help adding a label to indicate the leg.
Data :
structure(c("53.193418", "53.1905138631287", "53.186744", "53.189836",
"53.1884117", "53.1902965", "53.1940384", "53.1934748", "53.1894004",
"53.1916771", "-2.881248", "-2.89043889005541", "-2.890165",
"-2.893896", "-2.88802", "-2.8919373", "-2.8972299", "-2.8814698",
"-2.8886692", "-2.8846099"), .Dim = c(10L, 2L))
Function :
create.map<-function(lst){
library("ggmap")
cncat<-c(paste(lst[,1],lst[,2],sep=","))
df2<-data.frame(cncat)
leg <-function(start, dest, order){
r<- route(from=start,to=dest,mode = c("walking"),structure = c("legs"))
c<- geom_leg(aes(x = startLon, y = startLat,xend = endLon, yend = endLat),
alpha = 2/4, size = 2, data = r,colour = 'blue')+
geom_text(aes(label = order), size = 3)
return (c)
}
a<-qmap('Chester, UK', zoom = 15, maptype = 'road')
for (n in 1:9){
l<-leg(as.character(df2[n,1]), as.character(df2[n+1,1]),n)
a<-a+l
}
a
}
Is this close? (Note: this calls your list of points way.points).
way.points <- as.data.frame(way.points,stringsAsFactors=FALSE)
library(ggmap)
rte.from <- apply(way.points[-nrow(way.points),],1,paste,collapse=",")
rte.to <- apply(way.points[-1,],1,paste,collapse=",")
rte <- do.call(rbind,
mapply(route, rte.from, rte.to, SIMPLIFY=FALSE,
MoreArgs=list(mode="walking",structure="legs")))
coords <- rbind(as.matrix(rte[,7:8]),as.matrix(rte[nrow(rte),9:10]))
coords <- as.data.frame(coords)
ggm <- qmap('Chester, UK', zoom = 15, maptype = 'road')
ggm +
geom_path(data=coords,aes(x=startLon,y=startLat),color="blue",size=2)+
geom_point(data=way.points,aes(x=as.numeric(V2),y=as.numeric(V1)),
size=10,color="yellow")+
geom_text(data=way.points,
aes(x=as.numeric(V2),y=as.numeric(V1), label=seq_along(V1)))
So this assembles a vector of from and to coordinates using apply(...), then uses mapply(...) to call route(...) with both vectors, returning the overall list of coordinates in a data frame rte. Because the coordinates are stored as, e.g. $startLat and $endLat, we form a coords data frame by adding the final $endLat and $endLong to rte to get the very last leg of the route. Then we use geom_path(...) to draw the path in one step. Finally we use geom_text(...) with x and y-values from the original way.points data frame, and we use geom_point(...) just to make them stand out a bit.
Here's a bare bones solution. I just added the labels to the finished ggmap object a. If you replace the line
a
with
lst2 <- data.frame(cbind(lst, leg = as.character(1:10) )
names(lst2) <- c("lat", "lon", "leg")
a <- a + geom_text(data=lst2,aes(x=lon,y=lat,label=leg),size=5, vjust = 0, hjust = -0.5)
return(a)
in your create.map function, you should get (roughly) the desired result. I might have reversed the lat and lon variables, and you probably want to tweak the size, location, etc. Hope this helps!
This is the 3d version of this question.
Consider the following data:
Income2<-structure(list(X = 1:30, Education = c(21.5862068965517, 18.2758620689655,
12.0689655172414, 17.0344827586207, 19.9310344827586, 18.2758620689655,
19.9310344827586, 21.1724137931034, 20.3448275862069, 10, 13.7241379310345,
18.6896551724138, 11.6551724137931, 16.6206896551724, 10, 20.3448275862069,
14.1379310344828, 16.6206896551724, 16.6206896551724, 20.3448275862069,
18.2758620689655, 14.551724137931, 17.448275862069, 10.4137931034483,
21.5862068965517, 11.2413793103448, 19.9310344827586, 11.6551724137931,
12.0689655172414, 17.0344827586207), Seniority = c(113.103448275862,
119.310344827586, 100.689655172414, 187.586206896552, 20, 26.2068965517241,
150.344827586207, 82.0689655172414, 88.2758620689655, 113.103448275862,
51.0344827586207, 144.137931034483, 20, 94.4827586206897, 187.586206896552,
94.4827586206897, 20, 44.8275862068966, 175.172413793103, 187.586206896552,
100.689655172414, 137.931034482759, 94.4827586206897, 32.4137931034483,
20, 44.8275862068966, 168.965517241379, 57.2413793103448, 32.4137931034483,
106.896551724138), Income = c(99.9171726114381, 92.579134855529,
34.6787271520874, 78.7028062353695, 68.0099216471551, 71.5044853814318,
87.9704669939115, 79.8110298331255, 90.00632710858, 45.6555294997364,
31.9138079371295, 96.2829968022869, 27.9825049000603, 66.601792415137,
41.5319924201478, 89.00070081522, 28.8163007592387, 57.6816942573605,
70.1050960424457, 98.8340115435447, 74.7046991976891, 53.5321056283034,
72.0789236655191, 18.5706650327685, 78.8057842852386, 21.388561306174,
90.8140351180409, 22.6361626208955, 17.613593041445, 74.6109601985289
)), .Names = c("X", "Education", "Seniority", "Income"), class = "data.frame", row.names = c(NA,
-30L))
How can one do a 3d plot of the model, including: 3d scatterplot + model surface + connecting points to surface ?
I already have one easy and beautiful solution using car and rgl packages:
scatter3d(Income ~Seniority + Education, data=Income2, fit="smooth")
But I would like to see more ways to do it, specially with base graphics, lattice and "pure" rgl.
I figured out how to do it with base graphics:
Fit model:
model <- loess(Income ~Education + Seniority, data=Income2)
Create sequencies of x's and y's:
x <-range(Income2$Education)
x <- seq(x[1], x[2], length.out=50)
y <- range(Income2$Seniority)
y <- seq(y[1], y[2], length.out=50)
Create values of z with all the combinations of x and y:
z <- outer(x,y,
function(Education,Seniority)
predict(model, data.frame(Education,Seniority)))
Plot with persp:
p <- persp(x,y,z, theta=30, phi=30,
col="lightblue",expand = 0.5,shade = 0.2,
xlab="Education", ylab="Seniority", zlab="Income")
Project 3d points to 2d, so you can use points and segment:
obs <- trans3d(Income2$Education, Income2$Seniority,Income2$Income,p)
pred <- trans3d(Income2$Education, Income2$Seniority,fitted(model),p)
points(obs, col="red",pch=16)
segments(obs$x, obs$y, pred$x, pred$y)