Dynamic Programming in R - Algorithm for Distance Between Warehouse Locations - r

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.)

Related

Inverse Association Rules

Association rules are a very common technique when you want to figure out which events happens together (like burger and bread mostly sell together). In marketing this technique is used to find out the complimentary products.
I am looking for a technique to extract the "Substitute Products" and to be it is like Inverse Association rules to find out which events are less likely happens together. Is there any algorithm or technique available in Spark, R, Python, etc. for this?
Thanks,
Amir
I've done an a very practical implementation for Substitution Rule Mining using Teng, Hsieh and Chen (2002) for R. Maybe it can help you:
# Used packages:
library(arules)
SRM <- function(TransData, MinSup, MinConf, pMin, pChi, itemLabel, nTID){
# Packages ----------------------------------------------------------------
if (sum(search() %in% "package:arules") == 0) {
stop("Please load package arules")
}
# Checking Input data -----------------------------------------------------
if (missing(TransData)) {
stop("Transaction data is missing")
}
if (is.numeric(nTID) == FALSE) {
stop("nTID has to be one numeric number for the count of
Transactions")
}
if (length(nTID) > 1) {
stop("nTID has to be one number for the count of Transactions")
}
if (is.character(itemLabel) == FALSE) {
stop("itemLabel has to be a character")
}
# Concrete Item sets ---------------------------------------------------
# adding complements to transaction data
compl_trans <- addComplement(TransData,labels = itemLabel)
compl_tab <- crossTable(compl_trans,"support")
compl_tab_D <- as.data.frame(compl_tab)
# ordering matrix
compl_tab_D <- compl_tab_D[order(rownames((compl_tab))),order(colnames((compl_tab)))]
# Chi Value ---------------------------------------------------------------
# empty data frame for loop
complement_data <- data.frame(Chi = as.numeric(),
Sup_X.Y = as.numeric(),
X = as.character(),
Sup_X = as.numeric(),
Y = as.character(),
Sup_Y = as.numeric(),
CX = as.character(),
SupCX = as.numeric(),
CY = as.character(),
Sup_CY = as.numeric(),
Conf_X.CY = as.numeric(),
Sup_X.CY = as.numeric(),
Conf_Y.CX = as.numeric(),
SupY_CX = as.numeric())
# first loop for one item
for ( i in 1 : (length(itemLabel) - 1)) {
# second loop combines it with all other items
for (u in (i + 1) : length(itemLabel)) {
# getting chi value from Teng
a <- itemLabel[i]
b <- itemLabel[u]
ca <- paste0("!", itemLabel[i])
cb <- paste0("!", itemLabel[u])
chiValue <- nTID * (
compl_tab[ca, cb] ^ 2 / (compl_tab[ca, ca] * compl_tab[cb, cb]) +
compl_tab[ca, b] ^ 2 / (compl_tab[ca, ca] * compl_tab[b, b]) +
compl_tab[a, cb] ^ 2 / (compl_tab[a, a] * compl_tab[cb, cb]) +
compl_tab[a, b] ^ 2 / (compl_tab[a, a] * compl_tab[b, b]) - 1)
# condition to be dependent
if (compl_tab[a, b] > compl_tab[a, a] * compl_tab[b, b] && chiValue >= qchisq(pChi, 1) &&
compl_tab[a, a] >= MinSup && compl_tab[b, b] >= MinSup ) {
chi_sup <- data.frame(Chi = chiValue,
Sup_X.Y = compl_tab[a, b],
X = a,
Sup_X = compl_tab[a, a],
Y = b,
Sup_Y = compl_tab[b, b],
CX = ca,
SupCX = compl_tab[ca, ca],
CY = cb,
Sup_CY = compl_tab[cb, cb],
Conf_X.CY = compl_tab[a, cb] / compl_tab[a, a],
Sup_X.CY = compl_tab[a, cb],
Conf_Y.CX = compl_tab[ca, b] / compl_tab[b, b],
SupY_CX = compl_tab[ca, b])
try(complement_data <- rbind(complement_data, chi_sup))
}
}
}
if (nrow(complement_data) == 0) {
stop("No complement item sets could have been found")
}
# changing mode of
complement_data$X <- as.character(complement_data$X)
complement_data$Y <- as.character(complement_data$Y)
# calculating support for concrete itemsets with all others and their complements -------------------
## with complements
matrix_trans <- as.data.frame(as(compl_trans, "matrix"))
sup_three <- data.frame(Items = as.character(),
Support = as.numeric())
setCompl <- names(matrix_trans)
# 1. extracts all other values than that are not in the itemset
for (i in 1 : nrow(complement_data)) {
value <- setCompl[ !setCompl %in% c(complement_data$X[i],
complement_data$Y[i],
paste0("!", complement_data$X[i]),
paste0("!",complement_data$Y[i]))]
# 2. calculation of support
for (u in value) {
count <- sum(rowSums(matrix_trans[, c(complement_data$X[i], complement_data$Y[i], u )]) == 3)
sup <- count / nTID
sup_three_items <- data.frame(Items = paste0(complement_data$X[i], complement_data$Y[i], u),
Support=sup)
sup_three <- rbind(sup_three, sup_three_items)
}
}
# Correlation of single items-------------------------------------------------------------
# all items of concrete itemsets should be mixed for correlation
combis <- unique(c(complement_data$X, complement_data$Y))
# empty object
rules<- data.frame(
Substitute = as.character(),
Product = as.character(),
Support = as.numeric(),
Confidence = as.numeric(),
Correlation = as.numeric())
# first loop for one item
for (i in 1 : (length(combis) - 1)) {
# second loop combines it with all other items
for (u in (i + 1) : length(combis)) {
first <- combis[i]
second <- combis[u]
corXY <- (compl_tab[first, second] - (compl_tab[first, first] * compl_tab[second, second])) /
(sqrt((compl_tab[first, first] * (1 - compl_tab[first,first])) *
(compl_tab[second, second] * (1 - compl_tab[second, second]))))
# confidence
conf1 <- compl_tab[first, paste0("!", second)] / compl_tab[first, first]
conf2 <- compl_tab[second, paste0("!", first)] / compl_tab[second, second]
two_rules <- data.frame(
Substitute = c(paste("{", first, "}"),
paste("{", second, "}")),
Product = c(paste("=>", "{", second, "}"),
paste("=>", "{", first, "}")),
Support = c(compl_tab[first, paste0("!", second)], compl_tab[second, paste0("!", first)]),
Confidence = c(conf1, conf2),
Correlation = c(corXY, corXY)
)
# conditions
try({
if (two_rules$Correlation[1] < pMin) {
if (two_rules$Support[1] >= MinSup && two_rules$Confidence[1] >= MinConf) {
rules <- rbind(rules, two_rules[1, ])
}
if (two_rules$Support[2] >= MinSup && two_rules$Confidence[2] >= MinConf) {
rules <- rbind(rules, two_rules[2, ])
}
} })
}
}
# Correlation of concrete item pairs with single items --------------------
# adding variable for loop
complement_data$XY <- paste0(complement_data$X, complement_data$Y)
# combination of items
for (i in 1 : nrow(complement_data)){
# set of combinations from dependent items with single items
univector <- c(as.vector(unique(complement_data$X)), as.vector(unique(complement_data$Y)))
univector <- univector[!univector %in% c(complement_data$X[i], complement_data$Y[i])]
combis <- c(complement_data[i,"XY"], univector)
for (u in 2 : length(combis)) {
corXYZ <-(sup_three[sup_three$Items == paste0(combis[1], combis[u]),2] -
complement_data[complement_data$XY == combis[1],"Sup_X.Y"] *
compl_tab[combis[u],combis[u]]) /
(sqrt((complement_data[complement_data$XY == combis[1],"Sup_X.Y"] *
(1 - complement_data[complement_data$XY == combis[1],"Sup_X.Y"]) *
compl_tab[combis[u],combis[u]] * (1 - compl_tab[combis[u],combis[u]]))))
dataXYZ <- data.frame(
Substitute = paste("{", combis[1], "}"),
Product = paste("=>", "{", combis[u], "}"),
Support = sup_three[sup_three$Items == paste0(combis[1], "!", combis[u]),2],
Confidence = sup_three[sup_three$Items == paste0(combis[1], "!", combis[u]),2] /
complement_data[complement_data$XY == combis[1],"Sup_X.Y"],
Correlation = corXYZ)
# conditions
if (dataXYZ$Correlation < pMin && dataXYZ$Support >= MinSup && dataXYZ$Confidence >= MinConf) {
try(rules <- rbind(rules, dataXYZ))
}
}
}
if (nrow(rules) == 0) {
message("Sorry no rules could have been calculated. Maybe change input conditions.")
} else {
return(rules)
}
# end
}
I think a better explanation is in my blog:
http://mattimeyer.github.io/2016-12-21-Substitution-Rule-Mining/

Simpifying Output of Deriv and Extract the Coefficients in R

I have two calculations for partial derivatives of an equation in R.
p_deriv_m <- Deriv(eqn, 'm')
#"-(2 * (6 - (b + m)) + 4 * (5 - (2 * m + b)) + 6 * (7 - (3 * m + b)) + 8 * (10 - (4 * m + b)))"
p_deriv_b <- Deriv(eqn, 'b')
#"-(2 * (10 - (4 * m + b)) + 2 * (5 - (2 * m + b)) + 2 * (6 - (b + m)) + 2 * (7 - (3 * m + b)))"
I would like to...
(1) Simplify these equations into something like of the form (making up the coefficients here) p_deriv_m = 8 + 9b - 10m and p_deriv_b = 10 + 15b + 8m
(2) Extract the Coefficients from these partial derivative equations so I can solve for m, b when the partial derivatives both equal 0. Using the examples I made up in (1) above...
9b - 10m = -8
15b + 8m = -10
Pop those numbers into a matrix and solve like this solution here - Solving simultaneous equations with R outputting and m and b.
If anyone knows how I can do (1) and/or (2), help would be greatly appreciated.
Rest of my code for reference:
library(Ryacas)
library(Deriv)
x_p <- c(1,2,3,4)
y_p <- c(6,5,7,10)
# Turn m and b into symbols
b <- Ryacas::Sym("b")
m <- Ryacas::Sym("m")
# Create a function
rss <- function(b,m,x_points, y_points)
(y_points[1] - (b + x_points[1]*m))^2 +
(y_points[2] - (b + x_points[2]*m))^2 +
(y_points[3] - (b + x_points[3]*m))^2 +
(y_points[4] - (b + x_points[4]*m))^2
# Create the equation
eqn <- rss(b,m,x_p,y_p)
p_deriv_m <- Deriv(eqn, 'm')
p_deriv_b <- Deriv(eqn, 'b')
ANSWER: Ended up doing it manually
sls_manual.R
# Doing a linear regression manually - want to find m and b
# Such that rss is minimized
library(Ryacas)
library(Deriv)
source('get_coeff.r')
# Sample Points - keeping the number of points small for now for
# the purposes of this example
x_p <- c(1,2,3,4)
y_p <- c(6,5,7,10)
b <- Ryacas::Sym("b")
m <- Ryacas::Sym("m")
# Create a function
rss <- function(b,m,x_points, y_points)
(y_points[1] - (b + x_points[1]*m))^2 +
(y_points[2] - (b + x_points[2]*m))^2 +
(y_points[3] - (b + x_points[3]*m))^2 +
(y_points[4] - (b + x_points[4]*m))^2
# Create the equation
eqn <- rss(b,m,x_p,y_p)
p_deriv_m <- Deriv(eqn, 'm')
p_deriv_b <- Deriv(eqn, 'b')
simplified_m_deriv <- yacas(Expand(p_deriv_m))
simplified_b_deriv<- yacas(Expand(p_deriv_b))
row_1_coeff <- get_coefficients(simplified_m_deriv)
row_2_coeff <- get_coefficients(simplified_b_deriv)
r_1_coeff <- c(row_1_coeff[[1]][1], row_1_coeff[[2]][1], row_1_coeff[[3]][1])
r_2_coeff <- c(row_2_coeff[[1]][1], row_2_coeff[[2]][1], row_2_coeff[[3]][1])
A <- matrix(data=c(r_1_coeff[1], r_1_coeff[2]
,r_2_coeff[1], r_2_coeff[2])
,nrow=2, ncol=2, byrow=TRUE)
b <- matrix(data=c((-1*r_1_coeff[3]),(-1*r_2_coeff[3]))
,nrow=2, ncol=1, byrow=TRUE)
result <- solve(A,b)
m_coeff = result[1]
b_coeff = result[2]
# Last step is to verify that this does the same thing as lm:w
# fit <- lm(y_p ~ x_p)
# fit
get_coeff.R
get_coefficients <- function(exp) {
# Take out the whitespace
g <- gsub(" ", "", as.character(exp))
# Sub the minuses for a +-
g2 <- gsub("-", "+-", g)
g3 <- gsub("[()]", "", g2)
# break at the plusses
g4 <- strsplit(g3, "[//+]")
b_coeff = 0
m_coeff = 0
other_coeff = 0
i = 1
while(i <= 3)
{
piece <- as.character(g4[[1]][i])
contains_b = grepl("b",piece)
contains_m = grepl("m",piece)
contains_both = contains_b & contains_m
if (contains_b == TRUE){
b_coeff = as.numeric(gsub("[//*b|b//*]", "", piece))
} else if (contains_m == TRUE){
m_coeff = as.numeric(gsub("[//*m|m//*]", "", piece))
} else if (contains_both == FALSE) {
other_coeff = as.numeric(piece)
} else {
}
i = i + 1
}
output <- list(m_coeff,b_coeff, other_coeff)
return(output)
}

Implementing additional standard run rules with R and qcc

I am a newbie with R, and would like to understand what it can do for control charting. I have read articles on qcc and created sample charts in R studio based on my own datasets to generate graphics or simply the underlying data.
It appears that two out of the shewhart control/run rules are implemented in QCC (+/- 3 sigma and a string above/below center), but more have been defined and are frequently used in practice. e.g. Nelson rules
Is there an R library/function that implements these? In addition to implementing the rules, I want to support the option to specify the "constant" related to the rule. For example where the referenced article says "Eight points in a row.." I would like eight to be a parameter. I'm thinking that the $data output from the qcc command could be passed as an argument (along with vector of rule "constant" options), and in return would be a list of violation points and rule number violated.
Any thoughts / suggestions?
We're working on the implementation of Nelson Rules in R. I think this is exactly what you're looking for (happy to share, I couldn't find an R implementation anywhere else on the internet):
nelsonr1 <- function(x, m = mean(x), s = sd(x)) {
# Nelson's QC rule 1: detect values outside + or -3 sd
which(abs((x - m) / s) >= 3)
}
nelsonr2 <- function(x, m = mean(x), minrun = 9) {
# Nelson's QC rule 2: detect runs of >= 9 points on the same side of the mean
n <- length(x)
counts <- sign(x - m)
result <- counts
for (runlength in 2:minrun)
result <- result + c(counts[runlength:n], rep(0, runlength - 1))
which(abs(result) >= minrun)
}
nelsonr3 <- function(x, minrun = 6) {
# Nelson's QC rule 3: detect strict increase or decrease in >= 6 points in a row
# Between 6 points you have 5 instances of increasing or decreasing. Therefore minrun - 1.
n <- length(x)
signs <- sign(c(x[-1], x[n]) - x)
counts <- signs
for (rl in 2:(minrun - 1)) {
counts <- counts + c(signs[rl:n], rep(0, rl - 1))
}
which(abs(counts) >= minrun - 1)
}
nelsonr4 <- function(x, m = mean(x), minrun = 14, directing_from_mean = FALSE) {
# Nelson's QC rule 4: 14 points in a row alternating in direction from the mean,
# or 14 points in a row alternating in increase and decrease
n <- length(x)
if (directing_from_mean == TRUE) {
signs <- sign(x - m)
} else {
signs <- sign(c(x[-1],x[n]) - x)
}
counts <- signs
fac <- -1
for (rl in 2:minrun) {
counts <- counts + fac * c(signs[rl:n], rep(0, rl - 1))
fac <- -fac
}
counts <- abs(counts)
which(counts >= minrun)
}
nelsonr5 <- function(x, m = mean(x), s = sd(x), minrun = 3) {
# Nelson's QC rule 5: two out of 3 >2 sd from mean in the same direction
n <- length(x)
pos <- 1 * ((x - m) / s > 2)
neg <- 1 * ((x - m) / s < -2)
poscounts <- pos
negcounts <- neg
for (rl in 2:minrun) {
poscounts <- poscounts + c(pos[rl:n], rep(0, rl - 1))
negcounts <- negcounts + c(neg[rl:n], rep(0, rl - 1))
}
counts <- apply(cbind(poscounts, negcounts), 1, max)
which(counts >= minrun -1)
}
nelsonr6 <- function(x, m = mean(x), s = sd(x), minrun = 5) {
# Nelson's QC rule 6: four out of five > 1 sd from mean in the same direction
n <- length(x)
pos <- 1 * ((x - m) / s > 1)
neg <- 1 * ((x - m) / s < -1)
poscounts <- pos
negcounts <- neg
for (rl in 2:minrun) {
poscounts <- poscounts + c(pos[rl:n], rep(0, rl - 1))
negcounts <- negcounts + c(neg[rl:n], rep(0, rl - 1))
}
counts <- apply(cbind(poscounts, negcounts), 1, max)
which(counts >= minrun - 1)
}
nelsonr7 <- function(x, m = mean(x), s = sd(x), minrun = 15) {
# Nelson's QC rule 7: >= 15 points in a row within 1 sd from the mean
n <- length(x)
within <- 1 * (abs((x - m) / s) < 1)
counts <- within
for (rl in 2:minrun)
counts <- counts + c(within[rl:n], rep(0, rl - 1))
which(counts >= minrun)
}
nelsonr8 <- function(x, m = mean(x), s = sd(x), minrun = 8) {
# Nelson's QC rule 8: >= 8 points in a row all outside the m + -1s range
n <- length(x)
outofrange <- 1 * (abs((x - m) / s) > 1)
counts <- outofrange
for (rl in 2:minrun)
counts <- counts + c(outofrange[rl:n], rep(0, rl - 1))
which(counts >= minrun)
}
For example where the referenced article says "Eight points in a row.." I would like eight to be a parameter.
That's what this does too with the parameter minrun in some functions.

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))
}

Realistic simulated elevation data in R / Perlin noise

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.

Resources