For Loop error in r - r

I am trying to simulate a markov chain by using code that wasnt made for it. My for loop is not correct and I continue to get error messages but I kept track of the brackets and syntax but I cannot quite put my finger on the issue. The matrix for the markov chain is markov. I am trying to plot each point by appending to the vector a but I dont think my loops are doing exactly what I want.
I am using the random number generator in order to test which state to move to and from. I understand there are easier ways to go about writing this code but I would like to try to use this basic foundation in order to get the code right. If you could please help me straighten the code up and figure out which way to nest the loop properly I would be grateful.
x is my starting point
The markov chain probabilities are uniformly distributed
x1 <- runif(100, 1.0, 100)
markov <- matrix(c(.5,.3,.2,.4,.5,.1,.2,.4,.4),nrow=3)
m1 <- markov[1:3]
m2 <- markov[4:6]
m3 <- markov[7:9]
y <- 2
x <- 1
a <- c(1)
while (y <= 100)
{
if(x==1) {
if(x1[y] < m1[1] * 100) {
x <- 1
} else if (x1[y] <= m1[2]*100 + m1[1] * 100 && x1[y] > m1[1] * 100) {
x <- 2
} else {
x <- 3
}
a <- union(x,c(y))
} else if (x==2) {
if(x1[y] < m2[1] * 100) {
x <- 1
} else if (x1[y] <= m2[2]*100 + m2[1] * 100 && x1[y] > m2[1] * 100) {
x <- 2
} else {
x <- 3
}
a <- union(x,c(y))
} else {
if(x1[y] < m3[1] * 100) {
x <- 1
} else if (x1[y] <= m3[2]*100 + m3[1] * 100 && x1[y] > m3[1] * 100) {
x <- 2
} else {
x <- 3
}
a <- union(x,c(y))
y <- y + 1
}
}
plot(c(1:100),a)

Your y <- y+1 is in one too many curly brackets. It is not being called most of the time.
I think this is what you want:
x1 <- runif(100, 1.0, 100)
markov <- matrix(c(.5,.3,.2,.4,.5,.1,.2,.4,.4),nrow=3)
m1 <- markov[1:3]
m2 <- markov[4:6]
m3 <- markov[7:9]
y <- 2
x <- 1
a <- c(1)
aa <- c()
while (y <= 100)
{
if(x==1) {
if(x1[y] < m1[1] * 100) {
x <- 1
} else if (x1[y] <= m1[2]*100 + m1[1] * 100 && x1[y] > m1[1] * 100) {
x <- 2
} else {
x <- 3
}
a <- union(x,c(y))
} else if (x==2) {
if(x1[y] < m2[1] * 100) {
x <- 1
} else if (x1[y] <= m2[2]*100 + m2[1] * 100 && x1[y] > m2[1] * 100) {
x <- 2
} else {
x <- 3
}
a <- union(x,c(y))
} else {
if(x1[y] < m3[1] * 100) {
x <- 1
} else if (x1[y] <= m3[2]*100 + m3[1] * 100 && x1[y] > m3[1] * 100) {
x <- 2
} else {
x <- 3
}
a <- union(x,c(y))
}
aa <- c(aa,x)
y <- y + 1
}
plot(aa)

Related

Dynamically update equation using vectors

I was hoping to automate the following process but have been unable to find a solution. The aim is to use vectors height and area to update each if equation in the function. The function would then use depth (x) to convert to volume.
The equation for each if statement would use the following syntax:
for (i in 2:length(height) {
(x >= height[i - 1] &&
x <= height[i]) {
(((area[i] - area[i - 1]) * (x - height[i - 1]) /
(height[i] - height[i - 1]) + area[i - 1]) * x)
}
Manual method:
height <- c(0.01, seq(0.05, 0.5, by = 0.05))
area <- c(8, 210, 300, 350, 400, 440, 470, 500, 535, 570, 610)
# Height values
Hmin <- min(height)
Hmax <- max(height)
for(i in 2:(length(height) - 1)) {
assign(paste0("H", i-1), height[i])
}
# Area values
Amin <- min(area)
Amax <- max(area)
for(i in 2:(length(area) - 1)) {
assign(paste0("A", i-1), area[i])
}
volume.fn <- function(x) {
if (x < Hmin) { # if less than min height value
x <- 0 # x <- 0
} else if (x >= Hmin && # if between min height and next height value
x <= H1) {
(((A1 - Amin) * (x - Hmin) / (H1 - Hmin) + Amin) * x) # apply this linear interpolation equation to depth column (x)
} else if (x >= H1 && # if x between height1 and height 2
x <= H2) {
(((A2 - A1) * (x - H1) / (H2 - H1) + A1) * x) # apply this linear interpolation equation to depth column (x)
} else if (x >= H2 &&
x <= H3) {
(((A3 - A2) * (x - H2) / (H3 - H2) + A2) * x)
} else if (x >= H3 &&
x <= H4) {
(((A4 - A3) * (x - H3) / (H4 - H3) + A3) * x)
} else if (x >= H4 &&
x <= H5) {
(((A5 - A4) * (x - H4) / (H5 - H4) + A4) * x)
} else if (x >= H5 &&
x <= H6) {
(((A6 - A5) * (x - H5) / (H6 - H5) + A5) * x)
} else if (x >= H6 &&
x <= H7) {
(((A7 - A6) * (x - H6) / (H7 - H6) + A6) * x)
} else if (x >= H7 &&
x <= H8) {
(((A8 - A7) * (x - H7) / (H8 - H7) + A7) * x)
} else if (x >= H8 &&
x <= H9) {
(((A9 - A8) * (x - H8) / (H9 - H8) + A8) * x)
} else if (x >= H9 &&
x <= Hmax) {
(((Amax - A9) * (x - H9) / (Hmax - H9) + A9) * x)
} else {
NA
}
}
Using findInterval you could do:
volume.fn1 <- function(x, height, area) {
volume <- if (x < min(height)) {
0
} else if (x > max(height)) {
NA
} else {
i <- findInterval(x, height, rightmost.closed = TRUE) + 1
((area[i] - area[i - 1]) * (x - height[i - 1]) /
(height[i] - height[i - 1]) + area[i - 1]) * x
}
return(volume)
}
volume.fn(.32)
#> [1] 154.24
volume.fn1(.32, height, area)
#> [1] 154.24
volume.fn(.48)
#> [1] 285.12
volume.fn1(.48, height, area)
#> [1] 285.12

Fastest Implementation of Dijkstra Algorithm in R

I have a below R code. The code works fine in computing shortest path between minimal input. If my input is big the code throws error in my coding environment.
Is there a way to fine tune the below code to achieve faster implementation. Suggestions/Corrections are highly appreciable.
Note : I am trying to implement without external packages
input <- suppressWarnings(readLines(stdin(), n=7))
5 6
1 2 30
1 3 10
5 2 40
3 5 20
5 1 30
5 4 20
l1 <- unlist(strsplit(input[1]," "))
cities <- as.numeric(l1[1])
roads <- as.numeric(l1[2])
L <- matrix(100000000,cities,roads)
#L <- format(L,scientific = FALSE)
distance <- function(inp){
f <- unlist(strsplit(input[inp+1]," "))
m <- as.numeric(f[1])
n <- as.numeric(f[2])
L[m,n] <<- as.numeric(f[3])
}
invisible(mapply(distance,seq_along(1:roads )))
if(cities > dim(L)[2])
{
cat("NOT POSSIBLE")
} else {
n=length(L[,1])
v=1
dest=n
cost=L
dijkstra = function(n, v, cost, dest) {
dest = numeric(n)
flag = numeric(n)
prev = numeric(n)
dstv <- function(i){
prev[i] <<- -1
dest[i] <<- cost[v, i]
}
invisible(mapply(dstv,seq_along(1:n)))
count = 2
while (count <= n) {
min = 100000000
destw <- function(w) {
if (dest[w] < min && !flag[w]) {
min <<- dest[w]
u <<- w
}
}
invisible(mapply(destw,seq_along(1:n)))
flag[u] = 1
count = count + 1
destu <- function(w) {
if ((dest[u] + cost[u, w] < dest[w]) && !flag[w]) {
dest[w] <<- dest[u] + cost[u, w]
prev[w] <<- u
}
}
invisible(mapply(destu,seq_along(1:n)))
}
return(prev)
}
savepath = function(f, x) {
path = x
while (f[x] != -1) {
path = c(path, f[x])
x = f[x]
savepath(f, x)
}
path = c(path, 1)
return(path)
}
prev = dijkstra(n,v,cost,dest)
path = sort(savepath(prev,dest))
}

How to iterate over 1 <= i < j <= n elements in R?

So I am trying to do a for loop over the upper triangle part of a matrix, so I only want the elements 1 <= i < j <= n. And I tried it out in R as follows:
for(i in 1:n-1) {
for(j in i+1:n) {
...
}
}
But instead of iterating over 1 <= i < j <= n these for loops go over the elements i + 1 <= j <= i + n, 1 <= i < n.
I'm new to R, so I don't understand what is happening. Could someone give me a hint how to do it correctly?
Thanks.
for(i in seq(1, n - 1)) {
for(j in seq(i + 1, n)) {
...
}
}
alternatively
for(i in 1:(n - 1)) {
for(j in (i + 1):n) {
...
}
}
The issue is that R understands i+1:n as i + (1:n)

Why does a piece of code that works on its own not work in parallel in R?

I wrote a piece of code (appended below) that works fine when I run it in serial, but when I use the foreach and doparallel libraries in R, I get an error code that reads: " task 1 failed - "missing value where TRUE/FALSE needed"
Everything inside the for each loop works on its own, and on a smaller batch, I can run it serially and it works.
ListOfColumns <- colnames(tempdata)
foreach(i = 1:nSubsets,
.export = ls(globalenv())) %dopar% {
DoubleTempData <- get(paste0("Subset", i))
DoubleTempData <- subset(DoubleTempData, select = -c(subset))
RowCounter <- 2
ColumnFigurer <- 2
LastCATEGORYIndicator <- "THERE IS NO CATEGORY, ONLY ZUUL"
while (RowCounter <= nrow(DoubleTempData)) {
print(paste("Checking row ", RowCounter))
RowChecker <- max(1, RowCounter - 5)
while (RowChecker < RowCounter) {
print(paste("Checking row",
RowCounter,
"against row",
RowChecker))
if (DoubleTempData$CATEGORY[RowChecker] == DoubleTempData$CATEGORY[RowCounter])
{
print("The rows match!")
while (ColumnFigurer > 0) {
if (DoubleTempData$CATEGORY[RowCounter] != LastCATEGORYIndicator) {
ColumnFigurer <- 2
}
print(paste ("Checking Iteration", ColumnFigurer))
if (ColumnFigurer * length(ListOfColumns) <= length(colnames(DoubleTempData)))
{
print(paste("Iteration", ColumnFigurer, " exists"))
CellChecker <-
((ColumnFigurer - 1) * length(ListOfColumns) + 1)
if (is.na(DoubleTempData[[RowChecker, CellChecker]])) {
print(paste("Current value is NA. Writing in new value."))
ColumnCounter <- 1
while (ColumnCounter <= length(ListOfColumns)) {
DoubleTempData[[RowChecker, (ColumnFigurer - 1) * length(ListOfColumns) +
ColumnCounter]] <-
DoubleTempData[[RowCounter, ColumnCounter]]
ColumnCounter <- ColumnCounter + 1
}
DoubleTempData <- DoubleTempData[-RowCounter]
LastCATEGORYIndicator <-
DoubleTempData$CATEGORY[RowChecker]
RowCounter <- max(2, RowCounter - 1)
ColumnFigurer <- ColumnFigurer + 1
break
}
else
{
print(paste(
"Current value is not NA, increasing iteration count."
))
ColumnFigurer <- ColumnFigurer + 1
}
}
if (ColumnFigurer * length(ListOfColumns) > length(colnames(DoubleTempData)))
{
print(paste(
"Iteration ",
ColumnFigurer,
"does not exist, adding iteration."
))
ColumnAdder <- 1
while (ColumnAdder <= length(ListOfColumns)) {
NewColumnName <-
paste0(ListOfColumns[ColumnAdder], "_", ColumnFigurer)
DoubleTempData[, NewColumnName] <- NA
ColumnAdder <- ColumnAdder + 1
}
}
}
}
RowChecker <- RowChecker + 1
}
RowCounter <- RowCounter + 1
}
assign(paste0("Subset", i), DoubleTempData)
}
For example, here is a sample of a randomly generated Subset1 that I ran, with about 70 observations and 7 columns (one of which gets dropped by the program as intended):
[![enter image description here][1]][1]
[1]: https://i.stack.imgur.com/Jlytj.png
It then outputs a dataset with 9 observations, and 60 columns:

R - Error executing user-defined function

I am trying to build a function that takes 2 arguments and uses those 2 arguments inside a replicate funtion
SPM <- function(bilhetes, N){
total_bilhetes <- 12012000
total_bilhetes_premios <- 3526450
premios <- c(0,5,10,15,20,25,50,100,300,1000,27000,108000,288000)
premios_bilhetes <- c(8485550,1895000,496800*2,88800*3,55200*4,16800*4,7920*6,5030*6,950*5,950,30,10,10)
probs <- premios_bilhetes/total_bilhetes
vector_ganhos <- c()
ganho <- 0
replicate(N, function(bilhetes) {
total_bilhetes1 <- total_bilhetes
premios_bilhetes1 <- premios_bilhetes
probs1 <- probs
for (i in c(1:bilhetes)) {
A <- sample(x = premios,replace = T,size = 1, prob = probs1)
ganho <- ganho - 5 + A
if (A == 0) {
premios_bilhetes1[1] <- premios_bilhetes1[1] - 1
} else if (A == 5) {
premios_bilhetes1[2] <- premios_bilhetes1[2] - 1
} else if (A == 10) {
premios_bilhetes1[3] <- premios_bilhetes1[3] - 1
} else if (A == 15) {
premios_bilhetes1[4] <- premios_bilhetes1[4] - 1
} else if (A == 20) {
premios_bilhetes1[5] <- premios_bilhetes1[5] - 1
} else if (A == 25) {
premios_bilhetes1[6] <- premios_bilhetes1[6] - 1
} else if (A == 50) {
premios_bilhetes1[7] <- premios_bilhetes1[7] - 1
} else if (A == 100) {
premios_bilhetes1[8] <- premios_bilhetes1[8] - 1
} else if (A == 300) {
premios_bilhetes1[9] <- premios_bilhetes1[9] - 1
} else if (A == 1000) {
premios_bilhetes1[10] <- premios_bilhetes1[10] - 1
} else if (A == 27000) {
premios_bilhetes1[11] <- premios_bilhetes1[11] - 1
} else if (A == 108000) {
premios_bilhetes1[12] <- premios_bilhetes1[12] - 1
} else {
premios_bilhetes1[13] <- premios_bilhetes1[13] - 1
}
total_bilhetes1 <- total_bilhetes1 - 1
probs1 <- premios_bilhetes1/(total_bilhetes1)
}
vector_ganhos[length(vector_ganhos)+1] = ganho
})
return(vector_ganhos)
}
when I try to run it, e.g., SPM(bilhetes = 5, N = 100) I get:
Error in SPM(bilhetes = 5, N = 100) : could not find function "SPM"
I looked in another question and someone mentioned "sourcing" the function. I tried it, and this was the output:
> source("SPM")
Error in file(filename, "r", encoding = encoding) :
cannot open the connection
In addition: Warning message:
In file(filename, "r", encoding = encoding) :
I'm rather new to R, so I'm probably making a dumb mistake.
Can someone help?

Resources