Incorporating a stop function in a random walk - r

In my previous question:How do I put arena limits on a random walk? the community helped create a random walk function in a set arena. This function is designed to simulate a fish moving through an area, but now I need to make it decide when to stop when a certain condition is satisfied.
I thought it would be as simple as
{{if(z>P)break}} put in just before the loop function. What I want it to understand is "if this condition is satisfied then stop, otherwise keep going until you reach the maximum number of steps.
Instead it caused my random walk to become deterministic (I always get the same path and it never stops before step.max).
Main question: How do I tell the random walk to stop if z>P?
For reference:
step.max<-125
step.prob<-function(n.times=step.max){
draw=sample(0:100,1,replace=T)
CS<-sample(draw,size=1,replace=TRUE)
CS.max<-100
step.num<-15
SP<-((CS/CS.max)*(1-(step.num/step.max))+(step.num/step.max))*100
if(SP>P){stop('Settled at step number',P)}else{SP
}
}
z<-step.prob(1) #renaming the above function to be easier to reference later
P<-80 #preset cutoff point for value z, ranges from 0-100
walkE <- function(n.times=125,
xlim=c(524058,542800),
ylim=c(2799758,2818500),
start=c(525000,2810000),
stepsize=c(4000,4000)) {
plot(c(0,0),type="n",xlim=xlim,ylim=ylim,
xlab="Easting",ylab="Northing")
x <- start[1]
y <- start[2]
steps <- 1/c(1,2,4,8,12,16)
steps.y <- c(steps,-steps,0)
steps.x <- c(steps,-steps[c(1,5,6)],0)
points(x,y,pch=16,col="red",cex=1)
for (i in 1:n.times) {
repeat {
xi <- stepsize[1]*sample(steps.x,1)
yi <- stepsize[2]*sample(steps.y,1)
newx <- x+xi
newy <- y+yi
if (newx>xlim[1] && newx<xlim[2] &&
newy>ylim[1] && newy<ylim[2]) break
}
lines(c(x,newx),c(y,newy),col="blue")
x <- newx
y <- newy
if(z>P){stop(points(newx,newy,col="green",cex=1))}
#this is where I want it to stop if z>P
else
if(z<P){points(newx,newy,pch=1,col="blue",cex=1)}
else
if(step.max){points(newx,newy,pch=16,col="green",cex=1)}
set.seed(101)}
}
walkE(step.max) #run above random walk function walkE looped for the step.max number
Thanks in advance!!!

This is pretty easy and can be accomplished by inserting a stop(...) function in your user defined step.prob function.
step.prob<-function(n.times=step.max, p){
draw=sample(0:100,1,replace=T)
CS<-sample(draw,size=1,replace=TRUE)
CS.max<-100
CS.max
step.num<-15
SP<-((CS/CS.max)*(1-(step.num/step.max))+(step.num/step.max))*100
if(SP > p) {
stop('Your random walk exceeded ', p)
} else {
SP
}
}
If this doesn't do it for you look into the break command.
So, when the random walk value is > p:
step.prob(p=300000)
# Error in step.prob(p = 3) : Your random walk exceeded 3
And if you want to set the value returned by the function to p you can just add in SP <- p before the stop command.

Related

How can I find the observations associated with rank j in this code?

I have been trying to find the observations associated with rank j in Ranked Set Sampling method. The problem is I don't know how to use the simulations to find the Xj values I'm supposed to work with further. Please help!
#The rankedsets function selects ranked sets from a target population. The selection of units in a set is without replacement, but the sets are selecting with replacement.
rankedsets<-function(X,m,s=m){
if(s==m){
x=sample(X,(m^2),replace=F)
n=matrix(x,ncol=m,nrow=m,byrow=T)
ms=matrix(0,ncol=m,nrow=m)
for (i in 1:m){
ms[i,]=sort(n[i,])
}
}else {
x=sample(X,(m*s),replace=F)
n=matrix(x,ncol=m,nrow=s,byrow=T)
ms=matrix(0,ncol=m,nrow=s)
for (i in 1:s){
ms[i,]=sort(n[i,])
}
}
return(ms)
}
#The rss function samples from a target population by using ranked set sampling method
rss<-function(X,m,r=1,sets=FALSE){
rss=numeric()
set=matrix(0,ncol=m,nrow=(m*r))
if (is.vector(X)){
a=0
for (j in 1:r){
ms=rankedsets(X,m)
for (i in 1:(m)){
set[i+a,]=ms[i,]
rss[i+a]=ms[i,i]
}
a=a+m
}
rss=matrix(rss,ncol=m,nrow=r,byrow=T)
cn=rn=numeric()
for (i in 1:r){
rn[i]=paste("r","=",i)
}
for (i in 1:m){
cn[i]=paste("m","=",i)
}
rownames(rss)=rn
colnames(rss)=cn
if (sets){
s=list(sets=set,sample=rss)
return(s)
} else {
return(rss)}
}else stop(" X must be a vector!",call.=F)
}
#RSS Data Generation
data=rnorm(10000,1,3)
rss(data,m=5,r=3,sets=TRUE)
I was trying using simulations but the code doesn't return Xj values:
sims = 1000
Xj = rep(NA, sims)
because I don't really know where I should put my for loop.

How to implement a function with a sum inside in R?

I am trying to define a function with a for loop and inside a conditional in R studio. Yesterday I was able with the help of another thread to devise this piece of code. The problem is that I want to sum the vector elements ma for any possible x, so that is inside the function l. This is a simpler case which I am trying to solve to adapt the original model. However, I do not know how to proceed.
ma<-rep(0,20)
l <- function(x, ma) {
for(i in seq_along(ma)) {
if(i %% 2 == 1) {
ma[i] <- i + x
} else {
ma[i] <- 0
}
}
return(ma)
}
My problem is that I would like to have the sum of i+x+0+i+x... for any possible x. I mean a function of the kind for any possible x.
Question:
Can someone explain to me how to implement such a function in R?
Thanks in advance!
I am going to update the original function:
Theta_alpha_s<-function(s,alpha,t,Basis){
for (i in seq_along(Basis)){
if(i%% 2==1) {Basis[i]=s*i^{-alpha-0.5}*sqrt(2)*cos(2*pi*i*t)}
else{Basis[i]=s*i^{-alpha-0.5}*sqrt(2)*sin(2*pi*i*t)}
}
return(Basis)
}
If you don't want to change the values in Basis, you can create a new vector in the function (here result) that you will return:
l = function(s,alpha,t,Basis){
is.odd = which(Basis %% 2 == 1)
not.odd = which(Basis %% 2 == 0)
result = rep(NA, length(Basis))
result[is.odd] = s*is.odd^{-alpha-0.5}*sqrt(2)*cos(2*pi*is.odd*t)
result[not.odd] = s*not.odd^{-alpha-0.5}*sqrt(2)*sin(2*pi*not.odd*t)
#return(result)
return(c(sum(result[is.odd]), sum(result[not.odd])))
}

Error message in Bubble sort code in R language

I did some programming work on R language to do the bubble sort. Sometimes it works perfectly without any error message, but sometimes, it shows "Error in if (x[i] > x[i + 1]) { : argument is of length zero". Can any one help me check whats wrong with it? I have attached my code below
example <- function(x) {
n <- length(x)
repeat {
hasChanged <- FALSE
n <- n - 1
for(i in 1:n) {
if ( x[i] > x[i+1] ) {
temp <- x[i]
x[i] <- x[i+1]
x[i+1] <- temp
hasChanged <- TRUE
cat("The current Vector is", x ,"\n")
}
}
if ( !hasChanged ) break;
}
}
x <-sample(1:10,5)
cat("The original Vector is", x ,"\n")
example(x)
The error occurs because you are iteratively decreasing n. Depending on the original vector's order (or lack thereof), n can reach the value of 1 after the last change. In that case, a further reduction of n in the next iteration step addresses the value x[0], which is undefined.
With a minimal correction your code will work properly, without giving error messages. Try to replace the line
if ( !hasChanged ) break;
with
if ( !hasChanged | n==1 ) break
Basically you have two termination criteria: Either nothing has been changed in the previous iteration or n is equal to one. In both cases, a further iteration won't change the vector since it is already ordered.
By the way, in R programming you don't need a semicolon at the end of a command. It is tolerated/ignored by the interpreter, but it clutters the code and is not considered good programming style.
Hope this helps.

How to optimize an iterative function for big data analysis?

I have a problem of optimizing a model. My function increments the value of a variable (Dem) in an iterative process to arrive at the condition set in the "WHILE".
I had to use a "FOR's" and some "IF's", I know that makes the very slow processing in the R environment, but I have to do in R.
 
The variable P is the length of 10958 obs. The variables A and C has a length of 65511 obs.
Using system.time (myfunction), using only one element of the variables Area [1] and C [1], my computer takes 2.5 seconds to complete the process. But for all elements of Area and C will take 45 hours.
My professor said it's too slow, but I think for the amount of data is normal, there is a way to optimize this? Should a option optimize the function (PSO,DEoptim,etc) instead using WHILE?
myfunction = function(P,Area,C,Cap,Inc){
Vin<- Cap
Q<-NA
Ov<-NA
Def<-NA
Vf<-NA
Vp<-NA
Dem<-0
Dem_100<-NA
Fail<-0
for (i in 1:length(Area)){
while(Fail==0){
Dem<-Dem+Inc
for (j in 1:length(P)){
#-----------------------------------------------------------------------#
####################### Calculate Q #####################################
#-----------------------------------------------------------------------#
if (P[j]==0){
Q<-0
}else{
Q<-P[j]*Area[i]*C[i]
}
#-----------------------------------------------------------------------
################################ Calculate Vp ##########################
#-----------------------------------------------------------------------
Vp<- (Vin + Q) - Dem
if(Vp<0){
Fail<-1
break #stop For j and continue the while
}
#----------------------------------------------------------------------
###################################### Calculate OV ###################
#----------------------------------------------------------------------
if (Vp>Cap){
Ov<-Vp-Cap
}else{
Ov<-0
}
#---------------------------------------------------------------------
######################################## Calculate Def ###############
#---------------------------------------------------------------------
if (Vp<0){
Def<-0-Vp
}else{
Def<-0
}
#---------------------------------------------------------------------#
################################## Calculate Vf ###########
#---------------------------------------------------------------------#
if (Vp>Cap){
Vf<-Cap
}else{
if (Vp<0) {
Vf<-0
}else{
Vf<-Vp
}
}
#-----------------------------------------------------------------------#
################################## Update Vin ###########
#-----------------------------------------------------------------------#
Vin<-Vf
}
Vin<- Cap # Reset the var Vin for new j
}
Dem_100[i]<-Dem-Inc
Def<-NA
Dem<-0
Vin<- Cap
Fail<-0
}
return(list(DemGar100=Dem_100))
}
Test for time process
P<-abs(rnorm(10958))
system.time(myfunction(P = P,Area = 100,C = 0.8,Cap = 10000,Inc = 1))
user system elapsed
2.45 0.00 2.50
Don't have enough rep to comment, but since not a full answer it should go there.
Did you think to replace some ifs with ifelse? That should speed it up
Eg, you could rplace the whole j-loop with something like:
for (i in 1:length(Area)){
while(Fail==0){
Dem<-Dem+Inc
Q <- ifelse(P==0,0,P*Area[i]*C[i]) ##note Q is a vector of length length(P)
...
Also I think that Def seems to be never calculated (and Vf is always Vp when Vp<=Cap), because if Vp<0 you jump out of the j-loop and maybe even the while (you set fail to 1, but I do not know when R checks the condition, at end of the cycle?Or the beginning)

Incorporating point error information into a distance function--how to do it in R?

I have been working with the proxy package in R to implement a distance measure that weights Euclidean distance by the propagated errors of each individual point. The formula to do this is
sqrt((xi - xj)2) + (yi - yj)2) + ...(ni - nj)2) ÷ sqrt((σxi2 + σxj2) + (σyi2 + σyj2) + ...(σni2 + σnj2)).
I was able to get proxy to work for me in a basic sense (see proxy package in R, can't make it work) and replicated plain Euclidean distance functionality, hooray for the amateur.
However, once I started writing the function for the error-weighted distance, I immediately ran into a difficulty: I need to read in the errors as distinct from the points and have them processed distinctly.
I know that R has very strong functionality and I'm sure it can do this, but for the life of me, I don't know how. It looks like proxy's dist can handle two matrix inputs, but how would I tell it that matrix X is the points and matrix Y is the errors, and then have each go to its appropriate part of the function before being ultimately combined into the distance measure?
I had been hoping to use proxy directly, but I also realized that it looks like I can't. I believe I was able to come up with a function that works. First, the distance function:
DistErrAdj <- function(x,y) {
sing.err <- sqrt((x^2) + (y^2))
sum(sing.err)
}
Followed, of course, by
library(proxy)
pr_DB$set_entry(FUN=DistErrAdj,names="DistErrAdj")
Then, I took code already kindly written from augix (http://augix.com/wiki/Make%20trees%20in%20R,%20test%20its%20stability%20by%20bootstrapping.html) and altered it to suit my needs, to wit:
boot.errtree <- function(x, q, B = 1001, tree = "errave") {
library(ape)
library(protoclust)
library(cluster)
library(proxy)
func <- function(x,y) {
tr = agnes((dist(x, method = "euclidean")/dist(q, method = "DistErrAdj")), diss = TRUE, method = "average")
tr = as.phylo(as.hclust(tr))
return(tr)
}
if (tree == "errprot") {
func <- function(x,y) {
tr = protoclust((dist(x, method = "euclidean")/dist(q, method = "DistErrAdj")))
tr = as.phylo(tr)
return(tr)
}
}
if (tree == "errdiv") {
func <- function(x,y) {
tr = diana((dist(x, method = "euclidean")/dist(q, method = "DistErrAdj")), diss=TRUE)
tr = as.phylo(as.hclust(tr))
return(tr)
}
}
tr_real = func(x)
plot(tr_real)
bp <- boot.phylo(tr_real, x, FUN=func, B=B)
nodelabels(bp)
return(bp)
}
It seems to work.

Resources