Realistic simulated elevation data in R / Perlin noise - r

Does anyone know how to create a simulation raster elevation dataset - i.e. a 2d matrix of realistic elevation values - in R? R's jitter doesn't seem appropriate. In Java/Processing the noise() function achieves this with a Perlin noise algorithm e.g.:
size(200, 200);
float ns = 0.03; // for scaling
for (float i=0; i<200; i++) {
for (float j=0; j<200; j++) {
stroke(noise(i*ns, j*ns) * 255);
point(i, j);
}
}
But I've found no references to Perlin noise in R literature. Thanks in advance.

Here is an implementation in R,
following the explanations in
http://webstaff.itn.liu.se/~stegu/TNM022-2005/perlinnoiselinks/perlin-noise-math-faq.html
perlin_noise <- function(
n = 5, m = 7, # Size of the grid for the vector field
N = 100, M = 100 # Dimension of the image
) {
# For each point on this n*m grid, choose a unit 1 vector
vector_field <- apply(
array( rnorm( 2 * n * m ), dim = c(2,n,m) ),
2:3,
function(u) u / sqrt(sum(u^2))
)
f <- function(x,y) {
# Find the grid cell in which the point (x,y) is
i <- floor(x)
j <- floor(y)
stopifnot( i >= 1 || j >= 1 || i < n || j < m )
# The 4 vectors, from the vector field, at the vertices of the square
v1 <- vector_field[,i,j]
v2 <- vector_field[,i+1,j]
v3 <- vector_field[,i,j+1]
v4 <- vector_field[,i+1,j+1]
# Vectors from the point to the vertices
u1 <- c(x,y) - c(i,j)
u2 <- c(x,y) - c(i+1,j)
u3 <- c(x,y) - c(i,j+1)
u4 <- c(x,y) - c(i+1,j+1)
# Scalar products
a1 <- sum( v1 * u1 )
a2 <- sum( v2 * u2 )
a3 <- sum( v3 * u3 )
a4 <- sum( v4 * u4 )
# Weighted average of the scalar products
s <- function(p) 3 * p^2 - 2 * p^3
p <- s( x - i )
q <- s( y - j )
b1 <- (1-p)*a1 + p*a2
b2 <- (1-p)*a3 + p*a4
(1-q) * b1 + q * b2
}
xs <- seq(from = 1, to = n, length = N+1)[-(N+1)]
ys <- seq(from = 1, to = m, length = M+1)[-(M+1)]
outer( xs, ys, Vectorize(f) )
}
image( perlin_noise() )
You can have a more fractal structure by adding those matrices,
with different grid sizes.
a <- .6
k <- 8
m <- perlin_noise(2,2,2^k,2^k)
for( i in 2:k )
m <- m + a^i * perlin_noise(2^i,2^i,2^k,2^k)
image(m)
m[] <- rank(m) # Histogram equalization
image(m)

An alternative method:
require(geoR)
sim <- grf(441, grid="reg", cov.pars=c(1, .25))
image(sim, col=gray(seq(1, .1, l=30)))
Can extract object data with cbind(sim[[1]], z = sim[[2]])

Also now some functions in the {ambient} package.

Related

Dynamic Programming in R - Algorithm for Distance Between Warehouse Locations

I am trying to calculate the distance between warehouse locations in rStudio utilizing an algorithm from an academic paper. The formula accounts for dimensions of location width, depth, and side of the aisle. The added complexity comes in when calculating the shortest distance with multiple cross aisles. This is all based on this paper.
This is from a bird's eye view:
I have static values for α = 48, ß = 96, ϒ = 108, Ω = 75, S = 22.
I then have a data frame with i as the key for location number, X for aisle number, y for section number, z for side number, and Cross Aisle is a boolean (0 = not a cross-aisle, 1 = is a cross-aisle). Here is a sample:
i X Y Z Cross Aisle
1 1 1 1 0
2 1 2 1 0
....
357 12 20 2 0
These are the formulas between locations i and j if the warehouse had no cross-aisles and was one rectangular grid:
Items in the same aisle (xi = xj):
dij = |yi - yj| * ß + |zi - zj| * ϒ
If items are in different aisles, there are three different scenarios:
dij = {|xi - xj| * (2α + ϒ) + v} if zi = zj
dij = {(xj - xi) * (2α + ϒ) + ϒ + v} if zi = 1, zj = 2
dij = {(xj - xi) * (2α + ϒ) - ϒ + v} if zi = 2, zj = 1
where v is the "vertical" distance (bird's eye, up-down aisle):
v = min(ß * (2 * S - yi - yj), ß * (yi + yj)) + 2Ω
(*Note: the academic paper has a typo in the v formula. It states 2 - yi - yj in the first bit, but I found another, original source that had it correctly as 2 * S-yi - yj.)
This piece of the formula is not the tricky part. It is a fairly simple if/then function in R to compute. However, this next bit with the cross-aisle gets me.
This is from the academic paper:
The authors state essentially: There are two locations p1 and p2. There are two neighboring cross-aisles, a1 and a2. One is above p1 and the other is below p1. Also, cross-aisles b1 and b2 are found, which are neighboring p2 and lead left. The distance between p1 and p2 are as follows:
d(p1,p2) = min{d(p1,ai) + d(ai,bj) + d(bj,p2),i,j ∈ {1,2}}
I am unsure how to apply this algorithm to my data set and construct the necessary loops, and matrix to find the distances between my warehouse locations. I could really use some help here making sense of it.
Here is my actual data set.
Here is an image of my warehouse to give you a sense of the layout. The "X" locations are cross-aisles.
I was able to get a workable loop without the cross-aisles:
whse.data <- read.xlsx("data set.xlsx", sheet = 1) %>%
as.data.frame()
### CREATE COMBINATION OF LOCATIONS
require(tools)
cmbn.loc <- combinations(n = max(whse.data$i), r = 2, v = whse.data$i,
repeats.allowed = FALSE) %>%
as.data.frame()
### CALCULATE DISTANCE BETWEEN LOCATIONS
LocDst <- function(dc, wc, wa, tr, s, df, comb){
# Creates a distance between various locations
#
# Args:
# dc: Depth of cell (alpha)
# wc: Width of cell (beta)
# wa: Width of aisle (y)
# tr: turning radius (omega)
# s: number of sections (S)
# df: Data Frame with location i, x, y, z, Cross.Aisle data
# comb: Combination of locations to compare
#
# Returns:
# Data frame with distances between each location combination
#
dist.df_total <- data.frame()
for (n in 1:nrow(comb)){
i <- comb[n,1]
j <- comb[n,2]
xi <- df[df$i == i,2]
yi <- df[df$i == i,3]
zi <- df[df$i == i,4]
xj <- df[df$i == j,2]
yj <- df[df$i == j,3]
zj <- df[df$i == j,4]
v <- min(wc * (2 * s - yi - yj), wc * (yi + yj)) + 2 * tr
if(xi == xj){
dij <- abs(yi - yj) * wc + abs(zi - zj) * wa
} else if (zi == zj){
dij <- (abs(xi - xj) * (2 * dc + wa) + v)
} else if (zi == 1 & zj == 2){
dij <- ((xj - xi) * (2 * dc + wa) + wa + v)
} else {
dij <- ((xj - xi) * (2 * dc * wa) - wa + v)
}
dist.df <- data.frame(`i` = i, `j` = j, dist = dij)
dist.df_total <- rbind.data.frame(dist.df_total, dist.df)
}
return(dist.df_total)
}
dist <- LocDst(48, 96, 108, 75, 18, whse.data, cmbn.loc)
I need a workable for loop or something to be run Algorithm 1 above, please.
I was able to get something to work. If anyone has anything more straightforward, I am all ears. Maybe this will be helpful to someone out there!
I had to use Excel to calculate the distance between the cross-aisles. There's probably a code for it, but it wasn't value-add for me at this time. Here's a sample of that data:
V1 V2 Dist
7 18 672
7 19 780
7 33 204
....
341 342 108
where V1 represents the first location number and V2 the second for all cross-aisle combinations.
Everything else should be computed within the code (beyond what put above):
require(dplyr)
require(openxlsx)
require(tools)
whse.data <- read.xlsx("data set.xlsx", sheet = 1) %>%
as.data.frame()
### CREATE COMBINATION OF LOCATIONS
cmbn.loc <- combinations(n = max(whse.data$i), r = 2, v = whse.data$i,
repeats.allowed = FALSE) %>%
as.data.frame()
# CROSS-AISLES IN EACH SHELF
ca.shelf <- cross.aisles %>%
group_by(Shelf) %>%
summarise(No.Cross.Aisles = sum(Cross.Aisle)) %>%
as.data.frame()
# DISTANCE BETWEEN CROSS AISLES
cmbn.cross.aisle <- combinations(n = nrow(cross.aisles),
r = 2,
v = cross.aisles$i,
repeats.allowed = FALSE) %>%
as.data.frame()
dist.cross.aisle <- read.xlsx("Combination of Cross-Aisles v3.xlsx", sheet = 1) %>%
as.data.frame()
# CROSS AISLE FUNCTION
CrsAisDst <- function(dc, wc, wa, tr, s, no.sh, df, comb, ca.m, d.m){
# Creates a distance between various locations
#
# Args:
# dc: Depth of cell (alpha)
# wc: Width of cell (beta)
# wa: Width of aisle (y)
# tr: turning radius (omega)
# s: number of sections (S)
# no.sh: number of shelves
# df: Data Frame with location i, x, y, z, Cross.Aisle data
# comb: Combination of locations to compare
# ca.m: Cross-aisles matrix
# d.m: Distances between cross-aisles
#
# Returns:
# Data frame with distances between each location combination
#
dist.df_total <- data.frame()
for (n in 1:nrow(comb)){
i <- comb[n,1]
j <- comb[n,2]
xi <- df[df$i == i,2]
yi <- df[df$i == i,3]
zi <- df[df$i == i,4]
xj <- df[df$i == j,2]
yj <- df[df$i == j,3]
zj <- df[df$i == j,4]
v <- min(wc * (2 * s - yi - yj), wc * (yi + yj)) + 2 * tr
if(xi == xj){
min.dij <- abs(yi - yj) * wc + abs(zi - zj) * wa
} else {
shi <- df[df$i == i,6]
shj <- df[df$i == j,6]
### CROSS-AISLES
ca.i <- #ca.m[ca.m$Shelf == shi,1]
data.frame(`i` = ca.m[ca.m$Shelf == shi,1])
ca.j <- #ca.m[ca.m$Shelf == shj,1]
data.frame(`j` = ca.m[ca.m$Shelf == shj,1])
## JOIN DISTANCES
dist.df_total.i <- data.frame()
dist.df_total.j <- data.frame()
#
for (m in 1:nrow(ca.i)){
i.i <- i
j.i <- ca.i[m,]
xi.i <- df[df$i == i.i,2]
yi.i <- df[df$i == i.i,3]
zi.i <- df[df$i == i.i,4]
xj.i <- df[df$i == j.i,2]
yj.i <- df[df$i == j.i,3]
zj.i <- df[df$i == j.i,4]
dij.i <- abs(yi.i - yj.i) * wc + abs(zi.i - zj.i) * wa
dist.df.i <- data.frame(`i` = i.i, `j` = j.i, dist = dij.i)
dist.df_total.i <- rbind.data.frame(dist.df_total.i, dist.df.i)
}
for (l in 1:nrow(ca.j)){
i.j <- j
j.j <- ca.j[l,]
xi.j <- df[df$i == i.j,2]
yi.j <- df[df$i == i.j,3]
zi.j <- df[df$i == i.j,4]
xj.j <- df[df$i == j.j,2]
yj.j <- df[df$i == j.j,3]
zj.j <- df[df$i == j.j,4]
dij.j <- abs(yi.j - yj.j) * wc + abs(zi.j - zj.j) * wa
dist.df.j <- data.frame(`i` = i.j, `j` = j.j, dist = dij.j)
dist.df_total.j <- rbind.data.frame(dist.df_total.j, dist.df.j)
}
min.i <- dist.df_total.i %>% slice(which.min(dist))
min.j <- dist.df_total.j %>% slice(which.min(dist))
aisle <- data.frame(V1=min.i$j,V2=min.j$j)
dist.aisle <- semi_join(d.m, aisle, by = c("V1", "V2"))
# CALCULATING DISTANCE WITHOUT CROSS-AISLES
if (zi == zj){
dij <- (abs(xi - xj) * (2 * dc + wa) + v)
} else if (zi == 1 & zj == 2){
dij <- ((xj - xi) * (2 * dc + wa) + wa + v)
} else {
dij <- ((xj - xi) * (2 * dc * wa) - wa + v)
}
min.dij <- min(dij, (min.i$dist + min.j$dist + dist.aisle$Dist))
}
dist.df <- data.frame(`i` = i, `j` = j, dist = min.dij)
dist.df_total <- rbind.data.frame(dist.df_total, dist.df)
}
return(dist.df_total)
}
aisle.dist <- CrsAisDst(48, 96, 108, 75, 18, 23, whse.data, cmbn.loc, cross.aisles,
dist.cross.aisle)
Output looks like this:
i j dist
7 18 672
7 19 780
7 33 204
....
341 342 108
(Note: this last same I ran was just among cross-aisles, which is why the numbers look the same. I have tested it, though, and it will use the regular formula if it is less distance.)

Trying to build a function to simulate 100 paths of a particle in R

so basically lets say I have a function X that will calculate the random motion of a particle in 1 dimension. The function has different constants, and a normal random variable W, every path happens every 0.1ms. I want to simulate 100 paths.
X <- 0;
Dt <- 0.0001;
V <- 0.5;
for (j in 0:100){
W <- rnorm(100, j*Dt*V,1);
x[0] = 0;
x[j] = x[j-1] + Dt*V+ W*sqrt(Dt)
}
But I get an error saying that "replacement has zero length", also after getting the arrya of the different positions of the particle I would like to simulate it but I am not sure on how to do this.
Thank you
X <- array()
Dt <- 0.0001
V <- 0.5
X[1] = 0
for (j in 2:101){
W <- rnorm(100, j*Dt*V,1)
X[j] = X[j-1] + Dt*V+ W*sqrt(Dt)
}
I believe you are trying to do something like this:
X <- 0;
Dt <- 0.0001;
V <- 0.5;
LEN <- 101
W <- rnorm(LEN - 1, Dt * V, 1)
x <- rep(0, LEN)
for (i in seq_len(LEN - 1)) {
x[i + 1] = x[i] + Dt * V + W[i] * sqrt(Dt)
}
x

Iterative optimization of alternative glm family

I'm setting up an alternative response function to the commonly used exponential function in poisson glms, which is called softplus and defined as $\frac{1}{c} \log(1+\exp(c \eta))$, where $\eta$ corresponds to the linear predictor $X\beta$
I already managed optimization by setting parameter $c$ to arbitrary fixed values and only searching for $\hat{\beta}$.
BUT now for the next step I have to optimize this parameter $c$ as well (iteratively changing between updated $\beta$ and current $c$).
I tried to write a log-lik function, score function and then setting up a Newton Raphson optimization (using a while loop)
but I don't know how to seperate the updating of c in an outer step and updating \beta in an inner step..
Are there any suggestions?
# Response function:
sp <- function(eta, c = 1 ) {
return(log(1 + exp(abs(c * eta)))/ c)
}
# Log Likelihood
l.lpois <- function(par, y, X){
beta <- par[1:(length(par)-1)]
c <- par[length(par)]
l <- rep(NA, times = length(y))
for (i in 1:length(l)){
l[i] <- y[i] * log(sp(X[i,]%*%beta, c)) - sp(X[i,]%*%beta, c)
}
l <- sum(l)
return(l)
}
# Score function
score <- function(y, X, par){
beta <- par[1:(length(par)-1)]
c <- par[length(par)]
s <- matrix(rep(NA, times = length(y)*length(par)), ncol = length(y))
for (i in 1:length(y)){
s[,i] <- c(X[i,], 1) * (y[i] * plogis(c * X[i,]%*%beta) / sp(X[i,]%*%beta, c) - plogis(c * X[i,]%*%beta))
}
score <- rep(NA, times = nrow(s))
for (j in 1:length(score)){
score[j] <- sum(s[j,])
}
return(score)
}
# Optimization function
opt <- function(y, X, b.start, eps=0.0001, maxiter = 1e5){
beta <- b.start[1:(length(b.start)-1)]
c <- b.start[length(b.start)]
b.old <- b.start
i <- 0
conv <- FALSE
while(conv == FALSE){
eta <- X%*%b.old[1:(length(b.old)-1)]
s <- score(y, X, b.old)
h <- numDeriv::hessian(l.lpois,b.old,y=y,X=X)
invh <- solve(h)
# update
b.new <- b.old + invh %*% s
i <- i + 1
# Test
if(any(is.nan(b.new))){
b.new <- b.old
warning("convergence failed")
break
}
# convergence reached?
if(sqrt(sum((b.new - b.old)^2))/sqrt(sum(b.old^2)) < eps | i >= maxiter){
conv <- TRUE
}
b.old <- b.new
}
eta <- X%*%b.new[1:(length(b.new)-1)]
# covariance
invh <- solve(numDeriv::hessian(l.lpois,b.new,y=y,X=X))
fitted <- sp(eta, b.new[length(b.new)])
result <- list("coefficients" = c(beta = b.new),
"fitted.values" = fitted,
"covariance" = invh)
}
# Running fails ..
n <- 100
x <- runif(n, 0, 1)
Xdes <- cbind(1, x)
eta <- 1 + 2 * x
y <- rpois(n, sp(eta, c = 1))
opt(y,Xdes,c(0,1,1))
You have 2 bugs:
line 25:
(y[i] * plogis(c * X[i,]%*%beta) / sp(X[i,]%*%beta, c) - plogis(c * X[i,]%*%beta))
this returns matrix so you must convert to numeric:
as.numeric(y[i] * plogis(c * X[i,]%*%beta) / sp(X[i,]%*%beta, c) - plogis(c * X[i,]%*%beta))
line 23:
) is missing:
you have:
s <- matrix(rep(NA, times = length(y)*length(par), ncol = length(y))
while it should be:
s <- matrix(rep(NA, times = length(y)*length(par)), ncol = length(y))

How to use a matrix as an input in a User-Defined Function and Loop it in R?

Here is the current script I have:
delta <- 1/52
T <- 0.5
S0 <- 25
sigma <- 0.30
K <- 25
r <- 0.05
n <- 1000000
m <- T/delta
S <- numeric(m + 1)
S[1] <- S0
#Payoff asian option
asian_option_price <- function() {
for(j in 1:m) {
W <- rnorm(1)
S[j + 1] <- S[j] * exp((r - 0.5 * sigma^2) * delta + sigma * sqrt(delta) * W)
}
Si.bar <- mean(S)
exp(-r * T) * max(Si.bar - K, 0)
}
#Loops
C <- raply(n, asian_option_price(), .progress = "text")
My issue is that I need to use "-W" for a second simulation right after this one is done. The way the script is made, "W" is inside my loop which makes it impossible (i think) to use the corresponding "-W" after that. I think I need to use an independent matrix filled with rnorm() mat(x) = matrix(rnorm(m*n,mean=0,sd=1), m, n) so that I can simply use -mat(x) in my second simulation. I don't get how to take "W" out of my loop and still use it's corresponding matrix. Any help would be very useful. Thanks!
Your idea to preallocate all the random numbers is correct. You could then loop over the individual entries. However, it is faster to go for a vectorized approach:
delta <- 1/52
T <- 0.5
S0 <- 25
sigma <- 0.30
K <- 25
r <- 0.05
n <- 100000
m <- ceiling(T/delta)
W <- matrix(rnorm(n*m), nrow = m, ncol = n)
S <- apply(exp((r - 0.5 * sigma^2) * delta + sigma * sqrt(delta) * W), 2, cumprod)
S <- S0 * rbind(1, S)
Si_bar <- apply(S, 2, mean)
mean(pmax(Si_bar -K, 0)) * exp(-r*T)

How to convert UK grid reference to latitude and longitude in R

I have a vector of UK British National Grid references:
x <- c("SK393744", "SK442746", "SK376747", "SK108191", "SP169914", "SP206935", "SK173105", "SJ993230", "SK448299", "SK112396")
I need to convert this vector in WGS84 coordinates (latitude and longitude).
How can I do it using R?
Give these a go. If they work, I'll make a package with a few more of the other functions in that javascript library (which also has sister PHP & Java libraries, so it's fitting R shld have one).
# takes numeric east/north generated from the os.grid.parse() function
# i shld have made it take the vector the os.grid.parse() returns but
# we'll save that for a proper package version
os.grid.to.lat.lon <- function(E, N) {
a <- 6377563.396
b <- 6356256.909
F0 <- 0.9996012717
lat0 <- 49*pi/180
lon0 <- -2*pi/180
N0 <- -100000
E0 <- 400000
e2 <- 1 - (b^2)/(a^2)
n <- (a-b)/(a+b)
n2 <- n^2
n3 <- n^3
lat <- lat0
M <- 0
repeat {
lat <- (N-N0-M)/(a*F0) + lat
Ma <- (1 + n + (5/4)*n2 + (5/4)*n3) * (lat-lat0)
Mb <- (3*n + 3*n*n + (21/8)*n3) * sin(lat-lat0) * cos(lat+lat0)
Mc <- ((15/8)*n2 + (15/8)*n3) * sin(2*(lat-lat0)) * cos(2*(lat+lat0))
Md <- (35/24)*n3 * sin(3*(lat-lat0)) * cos(3*(lat+lat0))
M <- b * F0 * (Ma - Mb + Mc - Md)
if (N-N0-M < 0.00001) { break }
}
cosLat <- cos(lat)
sinLat <- sin(lat)
nu <- a*F0/sqrt(1-e2*sinLat*sinLat)
rho <- a*F0*(1-e2)/((1-e2*sinLat*sinLat)^1.5)
eta2 <- nu/rho-1
tanLat <- tan(lat)
tan2lat <- tanLat*tanLat
tan4lat <- tan2lat*tan2lat
tan6lat <- tan4lat*tan2lat
secLat <- 1/cosLat
nu3 <- nu*nu*nu
nu5 <- nu3*nu*nu
nu7 <- nu5*nu*nu
VII <- tanLat/(2*rho*nu)
VIII <- tanLat/(24*rho*nu3)*(5+3*tan2lat+eta2-9*tan2lat*eta2)
IX <- tanLat/(720*rho*nu5)*(61+90*tan2lat+45*tan4lat)
X <- secLat/nu
XI <- secLat/(6*nu3)*(nu/rho+2*tan2lat)
XII <- secLat/(120*nu5)*(5+28*tan2lat+24*tan4lat)
XIIA <- secLat/(5040*nu7)*(61+662*tan2lat+1320*tan4lat+720*tan6lat)
dE <- (E-E0)
dE2 <- dE*dE
dE3 <- dE2*dE
dE4 <- dE2*dE2
dE5 <- dE3*dE2
dE6 <- dE4*dE2
dE7 <- dE5*dE2
lon <- lon0 + X*dE - XI*dE3 + XII*dE5 - XIIA*dE7
lat <- lat - VII*dE2 + VIII*dE4 - IX*dE6
lat <- lat * 180/pi
lon <- lon * 180/pi
return(c(lat, lon))
}
# takes a string OS reference and returns an E/N vector
os.grid.parse <- function(grid.ref) {
grid.ref <- toupper(grid.ref)
# get numeric values of letter references, mapping A->0, B->1, C->2, etc:
l1 <- as.numeric(charToRaw(substr(grid.ref,1,1))) - 65
l2 <- as.numeric(charToRaw(substr(grid.ref,2,2))) - 65
# shuffle down letters after 'I' since 'I' is not used in grid:
if (l1 > 7) l1 <- l1 - 1
if (l2 > 7) l2 <- l2 - 1
# convert grid letters into 100km-square indexes from false origin - grid square SV
e <- ((l1-2) %% 5) * 5 + (l2 %% 5)
n <- (19 - floor(l1/5) *5 ) - floor(l2/5)
if (e<0 || e>6 || n<0 || n>12) { return(c(NA,NA)) }
# skip grid letters to get numeric part of ref, stripping any spaces:
ref.num <- gsub(" ", "", substr(grid.ref, 3, nchar(grid.ref)))
ref.mid <- floor(nchar(ref.num) / 2)
ref.len <- nchar(ref.num)
if (ref.len >= 10) { return(c(NA,NA)) }
e <- paste(e, substr(ref.num, 0, ref.mid), sep="", collapse="")
n <- paste(n, substr(ref.num, ref.mid+1, ref.len), sep="", collapse="")
nrep <- 5 - match(ref.len, c(0,2,4,6,8))
e <- as.numeric(paste(e, "5", rep("0", nrep), sep="", collapse=""))
n <- as.numeric(paste(n, "5", rep("0", nrep), sep="", collapse=""))
return(c(e,n))
}

Resources