I am making flow plots for spatial interation models, with x-y coordinates for both origins and destinations:
The problem is that I keep using nested for loops (one for origins, one for destinations) to plot these lines and am sure there's a better way in R.
Anyway to help answer this question I set-up a simple reproducible example with 4 origins and 2 destinations. Suspect the answer to plotting quicker is in matrix algebra, but not sure where to start. Test it out and please let me know:
o <- data.frame(x = c(3,5,6,1), y = c(8,2,3,2))
plot(o)
d <- data.frame(x = c(5,3), y = c(5,3))
points(d, col="red", pch=3)
beta <- 0.6
dist <- matrix(sqrt(c(o[,1] - d[1,1], o[,1] - d[2,1] )^2 +
c(o[,2] - d[1,2], o[,2] - d[2,2] )^2), ncol = 2)
s <- dist
for(i in 1:nrow(o)){
for(j in 1:nrow(d)){
s[i,j] <- exp(-beta * dist[i,j])
}
}
for(i in 1:nrow(o)){
for(j in 1:nrow(d)){
lines(c(o[i,1], d[j,1]), c(o[i,2], d[j,2]),
lwd = 2 * s[i,j] / mean(s))
}
}
Edit - for some context on this project, please see here http://rpubs.com/RobinLovelace/9697
A way to replace the second loop is to use mapply:
fun <- function(row.o, row.d)
{
lines(c(o[row.o,1], d[row.d,1]), c(o[row.o,2], d[row.d,2]),
lwd = 2 * s[row.o,row.d] / mean(s))
}
#all combinatios of rows of `d` and `o`
args.od <- expand.grid(1:nrow(o), 1:nrow(d))
mapply(fun, row.o = args.od[,1], row.d = args.od[,2])
The plot:
Related
I am new to R. As simple as the question sounds, I haven't been able to find a simple way of doing it in the documentation. So far, the best way I've come up, to generate Z is the below. But surely there is some built in function.
Example for the function
grid_size <- 10
x <- seq(0,1,length.out =grid_size)
y <- seq(0,1,length.out =grid_size)
xgrid <- matrix(x, nrow=grid_size, ncol=grid_size, byrow=TRUE)
ygrid <- matrix(x, nrow=grid_size, ncol=grid_size, byrow=FALSE)
f2v <- function(xgrid, ygrid) {
return (1 - xgrid + xgrid*ygrid)
}
Z <- f2v(xgrid, ygrid)
Thank you.
Use outer:
grid_size <- 10
x <- seq(0 ,1, length.out = grid_size)
y <- seq(0, 1, length.out = grid_size)
t(outer(x, y, function(x,y) 1 - x + x*y))
I would like to plot a sphere in R with the gridlines on the surface corresponding to the equal area gridding of the sphere using the arcos transformation.
I have been experimenting with the R packakge rgl and got some help from :
Plot points on a sphere in R
Which plots the gridlines with equal lat long spacing.
I have the below function which returns a data frame of points that are the cross over points of the grid lines I want, but not sure how to proceed.
plot_sphere <- function(theta_num,phi_num){
theta <- seq(0,2*pi,(2*pi)/(theta_num))
phi <- seq(0,pi,pi/(phi_num))
tmp <- seq(0,2*phi_num,2)/phi_num
phi <- acos(1-tmp)
tmp <- cbind(rep(seq(1,theta_num),each = phi_num),rep(seq(1,phi_num),times = theta_num))
results <- as.data.frame(cbind(theta[tmp[,1]],phi[tmp[,2]]))
names(results) <- c("theta","phi")
results$x <- cos(results$theta)*sin(results$phi)
results$y <- sin(results$theta)*sin(results$phi)
results$z <- cos(results$phi)
return(results)
}
sphere <- plot_sphere(10,10)
Can anyone help, in general I am finding the rgl functions tricky to work with.
If you use lines3d or plot3d(..., type="l"), you'll get a plot joining the points in your dataframe. To get breaks (you don't want one long line), add rows containing NA values.
The code in your plot_sphere function seems really messed up (you compute phi twice, you don't generate vectors of the requested length, etc.), but this function based on it works:
function(theta_num,phi_num){
theta0 <- seq(0,2*pi, len = theta_num)
tmp <- seq(0, 2, len = phi_num)
phi0 <- acos(1-tmp)
i <- seq(1, (phi_num + 1)*theta_num) - 1
theta <- theta0[i %/% (phi_num + 1) + 1]
phi <- phi0[i %% (phi_num + 1) + 1]
i <- seq(1, phi_num*(theta_num + 1)) - 1
theta <- c(theta, theta0[i %% (theta_num + 1) + 1])
phi <- c(phi, phi0[i %/% (theta_num + 1) + 1])
results <- data.frame( x = cos(theta)*sin(phi),
y = sin(theta)*sin(phi),
z = cos(phi))
lines3d(results)
}
I am starting in R and trying to get this loop to execute. I am trying to get the loop to calculate consecutive distances between coordinates using a function (Vincenty's formula). 'Distfunc' is the file to the function. The function is then called up by 'x' below. All I want then is a data frame or a list of the distances between coordinates. Greatful of any help!
Distfunc <- source("F://Distfunc.R")
for (i in length(Radians)) {
LatRad1 <- Radians[i,1]
LongRad1 <- Radians[i,2]
LatRad2 <- Radians[i+1,1]
LongRad2 <- Radians[i+1,2]
x <- gcd.vif(LongRad1, LatRad1, LongRad2, LatRad2)
print(data.frame(x[i]))
}
Well, without a good description of the problem you are facing and a proper reproducible example it is very difficult to provide any good insight. To start off, see How to make a great R reproducible example?.
There are many things that are not clear in the way you are doing things. First of all, why assign the results of source(...) to the variable Distfunc?
Anyways, here is some code that I put together in trying to understand this; it runs without problems, but it is not clear that it accomplishes what you expect (since you don't provide much information). In particular, the codet uses the implementation for function gcd.vif by Mario Pineda-Krch (http://www.r-bloggers.com/great-circle-distance-calculations-in-r/). The code below is aimed at clarity, since you mention that you are starting in R.
# Calculates the geodesic distance between two points specified by radian latitude/longitude using
# Vincenty inverse formula for ellipsoids (vif)
# By Mario Pineda-Krch (http://www.r-bloggers.com/great-circle-distance-calculations-in-r/)
gcd.vif <- function(long1, lat1, long2, lat2) {
# WGS-84 ellipsoid parameters
a <- 6378137 # length of major axis of the ellipsoid (radius at equator)
b <- 6356752.314245 # ength of minor axis of the ellipsoid (radius at the poles)
f <- 1/298.257223563 # flattening of the ellipsoid
L <- long2-long1 # difference in longitude
U1 <- atan((1-f) * tan(lat1)) # reduced latitude
U2 <- atan((1-f) * tan(lat2)) # reduced latitude
sinU1 <- sin(U1)
cosU1 <- cos(U1)
sinU2 <- sin(U2)
cosU2 <- cos(U2)
cosSqAlpha <- NULL
sinSigma <- NULL
cosSigma <- NULL
cos2SigmaM <- NULL
sigma <- NULL
lambda <- L
lambdaP <- 0
iterLimit <- 100
while (abs(lambda-lambdaP) > 1e-12 & iterLimit>0) {
sinLambda <- sin(lambda)
cosLambda <- cos(lambda)
sinSigma <- sqrt( (cosU2*sinLambda) * (cosU2*sinLambda) +
(cosU1*sinU2-sinU1*cosU2*cosLambda) * (cosU1*sinU2-sinU1*cosU2*cosLambda) )
if (sinSigma==0) return(0) # Co-incident points
cosSigma <- sinU1*sinU2 + cosU1*cosU2*cosLambda
sigma <- atan2(sinSigma, cosSigma)
sinAlpha <- cosU1 * cosU2 * sinLambda / sinSigma
cosSqAlpha <- 1 - sinAlpha*sinAlpha
cos2SigmaM <- cosSigma - 2*sinU1*sinU2/cosSqAlpha
if (is.na(cos2SigmaM)) cos2SigmaM <- 0 # Equatorial line: cosSqAlpha=0
C <- f/16*cosSqAlpha*(4+f*(4-3*cosSqAlpha))
lambdaP <- lambda
lambda <- L + (1-C) * f * sinAlpha *
(sigma + C*sinSigma*(cos2SigmaM+C*cosSigma*(-1+2*cos2SigmaM*cos2SigmaM)))
iterLimit <- iterLimit - 1
}
if (iterLimit==0) return(NA) # formula failed to converge
uSq <- cosSqAlpha * (a*a - b*b) / (b*b)
A <- 1 + uSq/16384*(4096+uSq*(-768+uSq*(320-175*uSq)))
B <- uSq/1024 * (256+uSq*(-128+uSq*(74-47*uSq)))
deltaSigma = B*sinSigma*(cos2SigmaM+B/4*(cosSigma*(-1+2*cos2SigmaM^2) -
B/6*cos2SigmaM*(-3+4*sinSigma^2)*(-3+4*cos2SigmaM^2)))
s <- b*A*(sigma-deltaSigma) / 1000
return(s) # Distance in km
}
# Initialize the variable 'Radians' with random data
Radians <- matrix(runif(20, min = 0, max = 2 * pi), ncol = 2)
lst <- list() # temporary list to store the results
for (i in seq(1, nrow(Radians) - 1)) { # loop through each row of the 'Radians' matrix
LatRad1 <- Radians[i, 1]
LongRad1 <- Radians[i, 2]
LatRad2 <- Radians[i + 1, 1]
LongRad2 <- Radians[i + 1, 2]
gcd_vif <- gcd.vif(LongRad1, LatRad1, LongRad2, LatRad2)
# Store the input data and the results
lst[[i]] <- c(
latitude_position_1 = LatRad1,
longtude_position_1 = LongRad1,
latitude_position_2 = LatRad2,
longtude_position_2 = LongRad2,
GCD = gcd_vif
)
}
Results <- as.data.frame(do.call(rbind, lst)) # store the input data and the results in a data frame
I'm trying to make a model using deSolve with a fairly large number of states. One of the states, 'foo', is actually made of 15 different states comprising of foo[1,1:5], foo[2,1:5] and foo[3,1:5] so I thought it would be easiest to pass the function a matrix of states instead of typing them out individually and then I could refer to them with indexing:
par <- rep(NA,3)
par_names <- c('alpha','prog','death_rate')
names(par) <-par_names
par['alpha'] <- 0.7
par['prog'] <- 0.8
par['death_rate'] <- 0.3
foo <- matrix(0,nrow = 3,ncol = 5)
states <- foo
my_func <- function(t,states,par){
with(as.list(c(states,par)),{
for (j in 1:5){
dfoo[1,j] <- par['alpha']*par['prog']*foo[1,j] - par['death_rate']*foo[1,j]
dfoo[2,j] <- par['prog']*foo[1,j] - par['prog']*foo[2,j] - par['death_rate']*foo[2,j]
dfoo[3,j] <- par['prog']*foo[2,j] - par['prog']*foo[3,j] - par['death_rate']*foo[3,j]
}
list(c(
dfoo[]
))
})
}
times <- seq(1,365,by=1)
library(deSolve)
alldata <- as.data.frame(ode(y=states,times=times,func=my_func,parms=par))
I've tried to fix it but I just keep getting the same error:
Error in dfoo[1, j] <- par["alpha"] * par["prog"] * foo[1, j] - par["death_rate"] * :
object 'dfoo' not found
So does anyone know how this might be made to work or an easier way of doing this?
Yes, you can pass a matrix in as your states. But every time ode calls your function (except for the first time) it will pass a vector rather than a matrix. But you can convert it to a matrix at the beginning of your function.
You use unnecessary contortions to create your data. Also, as pointed out in the comments, your function doesn't seem to initialize dfoo. Finally, your for loop in the function could be more cleanly handled with a few vectorized operations. Here is an example:
my_func <- function(t,states,par){
foo <- matrix(states, nrow = 3, ncol = 5)
dfoo <- with(as.list(par), rbind(
(prog * alpha * foo[1,]) - (death_rate * foo[1,]),
(prog * foo[-nrow(foo),]) - (prog * foo[-1,]) - (death_rate * foo[-1,])
))
list(dfoo)
}
library(deSolve)
par <- c(alpha = 0.7, prog = 0.8, death_rate = 0.3)
states <- matrix(0,nrow = 3,ncol = 5)
ode <- ode(y=states, times=1:365, func=my_func, parms=par)
alldata <- as.data.frame(ode)
I am trying to create a plot of the (X0,Ujn) points created in the repeat function. Is there a way to do this in R? Here is my code:
LaxFriedrichs <- function(X0,delx,delt,t){
repeat{
Uj <- sin(X0)
U <- sin(X0+2*delx)
Ujn <- (Uj + U)/2 + (Uj - U)*(t/(2*delx))
X0 <- X0+delx
t <- delt + t
plot(X0,Ujn)
if (X0 > 2*pi/40) break
}
}
This might not be the most efficient implementation, but it at least gets all your points plotted (keeps appending to x and y list and then plots those points at the end):
LaxFriedrichs <- function(X0,delx,delt,t){
all.x = c()
all.y = c()
repeat{
Uj <- sin(X0)
U <- sin(X0+2*delx)
Ujn <- (Uj + U)/2 + (Uj - U)*(t/(2*delx))
X0 <- X0+delx
t <- delt + t
all.x <- c(all.x, X0)
all.y <- c(all.y, Ujn)
if (X0 > 2*pi/40) break
}
plot(all.x, all.y)
}
LaxFriedrichs(.001, .001, .001, 0.5)
A slightly shorter version that takes advantage of R's vector operations.
f <- function(x0, dx, dt, t0) {
x <- seq(x0,2*pi/40,by=dx)
t <- seq(t0,t0+(length(x)-1)*dt,by=dt)
Uj <- sin(x)
U <- sin(x+2*dx)
Ujn <- (Uj + U)/2 + (Uj - U)*(t/(2*dx))
plot(x,Ujn)
}
f(.001, .001, .001, .5)
Here, x and t are vectors, so Uj, U, and finally Ujn are calculated in one step, rather than in a loop.
One thing to note: in the original algorithm, at each step Ujn is calculated at x but x+dx is stored, so you end up plotting Ujn(x) vs (x+dx). The approach here corrects that, so the x-axis is offset by -dx.