I am trying to set up a process using a while loop in order to have my code consistently sample among certain xd[i] before one particular xd[i] becomes equal to x.
I know it would be more efficient to put everything under one for loop (except for the while loop) but I am trying to create this step by step. Right now, I am stuck on the while loop part. I cannot run that part of the code without R crashing, or if it does not crash, it seems to continue sampling nonstop until I manually stop it. How can I change my while loop such that it samples over the xd vector until one of the elements of xd matches with x?
Thank you
reset1 = {
a = 0.3 #lower legal threshold
b = 0.9 #upper legal threshold
x = 0
theta = runif(1,min = a, max = b)
theta
A = 5 ## monetary value of harm from
maxw = 2*A
minw = 0
wbar = (maxw+minw)/2 ##average cost
wbar
xd = c(1,2,3)
w = c(1,2,3)
}
for (i in 1:length(xd)){w[i] = runif(1, min = 0, max = 2)} #trying to make it create a w for each person
##Drivers problem: pick the x that will minimize your cost
for(i in 1:length(xd)){xd[i] = min(c(1-(w[i]/(2*A)),((2+b)-sqrt(b^2-2*b+1+3*(w[i]/A)*(b-a)))/3,b))}
xd
for(i in 1:length(xd)){proba = function(xd){(xd-1)^2}}
proba(xd) #ith individual probability of getting in an accident given their xd[i]
proba(xd[c(1:3)])
probn = 1 - proba(xd) #probability of not getting in an accident given driveri's effort level
probn
while (any(x!=xd)) {x = sample(c(xd[c(1,2,3)],0,0,0),size = 1, replace = TRUE, prob = c(proba(xd), probn)) ###the x is selected based on which ever x resulted in an accident
}
show(x)
Perhaps
while(sum(xd!=x)==3){}
This loops runs as long as no element of xd equals x
Related
Recently, I learned how to write a loop that initializes some number, and then randomly generates numbers until the initial number is guessed (while recording the number of guesses it took) such that no number will be guessed twice:
# https://stackoverflow.com/questions/73216517/making-sure-a-number-isnt-guessed-twice
all_games <- vector("list", 100)
for (i in 1:100){
guess_i = 0
correct_i = sample(1:100, 1)
guess_sets <- 1:100 ## initialize a set
trial_index <- 1
while(guess_i != correct_i){
guess_i = sample(guess_sets, 1) ## sample from this set
guess_sets <- setdiff(guess_sets, guess_i) ## remove it from the set
trial_index <- trial_index + 1
}
## no need to store `i` and `guess_i` (as same as `correct_i`), right?
game_results_i <- data.frame(i, trial_index, guess_i, correct_i)
all_games[[i]] <- game_results_i
}
all_games <- do.call("rbind", all_games)
I am now trying to modify the above code to create the following two loops:
(Deterministic) Loop 1 will always guess the midpoint (round up) and told if their guess is smaller or bigger than the correct number. They will then re-take the midpoint (e.g. their guess and the floor/ceiling) until they reach the correct number.
(Semi-Deterministic) Loop 2 first makes a random guess and is told if their guess is bigger or smaller than the number. They then divide the difference by half and makes their next guess randomly in a smaller range. They repeat this process many times until they reach the correct number.
I tried to write a sketch of the code:
#Loop 2:
correct = sample(1:100, 1)
guess_1 = sample(1:100, 1)
guess_2 = ifelse(guess_1 > correct, sample(50:guess_1, 1), sample(guess_1:100, 1))
guess_3 = ifelse(guess_2 > correct, sample(50:guess_2, 1), sample(guess_2:100, 1))
guess_4 = ifelse(guess_4 > correct, sample(50:guess_3, 1), sample(guess_3:100, 1))
#etc
But I am not sure if I am doing this correctly.
Can someone please help me with this?
Thank you!
Example : Suppose I pick the number 68
Loop 1: first random guess = 51, (100-51)/2 + 51 = 75, (75-50)/2 + 50 = 63, (75 - 63)/2 + 63 = 69, (69 - 63)/2 + 63 = 66, etc.
Loop 2: first random guess = 53, rand_between(53,100) = 71, rand_between(51,71) = 65, rand(65,71) = 70, etc.
I don't think you need a for loop for this, you can create structures since the beginning, with sample, sapply and which:
## correct values can repeat, so we set replace to TRUE
corrects <- sample(1:100, 100, replace = TRUE)
## replace is by default FALSE in sample(), if you don't want repeated guesses
## sapply() creates a matrix
guesses <- sapply(1:100, function(x) sample(1:100, 100))
## constructing game_results_i equal to yours, but could be simplified
game_results_i <- data.frame(
i = 1:100,
trial_index = sapply(
1:100,
function(x) which(
## which() returns the index of the first element that makes the predicate true
guesses[, x] == corrects[x]
)
),
guess_i = corrects,
correct_i = corrects # guess_i and correct_i are obviously equal
)
Ok, let's see if now I match question and answer properly :)
If I got correctly your intentions, in both loops, you are setting increasingly finer lower and upper bounds. Each guess reduces the search space. However, this interpretation does not always match your description, please double check if it can be acceptable for your purposes.
I wrote two functions, guess_bisect for the deterministic loop_1 and guess_sample for loop_2:
guess_bisect <- function(correct, n = 100) {
lb <- 0
ub <- n + 1
trial_index <- 1
guess <- round((ub - lb) / 2) + lb
while (guess != correct) {
# cat(lb, ub, guess, "\n") # uncomment to print the guess iteration
if (guess < correct)
lb <- guess
else
ub <- guess
guess <- round((ub - lb) / 2) + lb
trial_index <- trial_index + 1
}
trial_index
}
guess_sample <- function(correct, n = 100) {
lb <- 0
ub <- n + 1
trial_index <- 1
guess <- sample((lb + 1):(ub - 1), 1)
while (guess != correct) {
# cat(lb, ub, guess, "\n") # uncomment to print the guess iteration
if (guess < correct)
lb <- guess
else
ub <- guess
guess <- sample((lb + 1):(ub - 1), 1)
trial_index <- trial_index + 1
}
trial_index
}
Obviously, guess_bisect always produces the same results with the same input, guess_sample changes randomly instead.
By plotting the results in a simple chart, it seems that the deterministic bisection is on the average much better, as the random sampling may become happen to pick improvements from the wrong sides. x-axis is the correct number, spanning 1 to 100, y-axis is the trial index, with guess_bisect you get the red curve, with many attempts of guess_sample you get the blue curves.
How to specify a monotonicity constraint (that one time series should not come before the other) when using dynamic time warping?
For example, I have cost and revenue data; one should impact the other but not vice versa. I am using the basic dtw package but I know that there are many others that could be better. Below is my current alignment.
(I would like to save the corresponding revenue point into a separate column, would that be possible?)
library(dtw)
asy<-dtw(df$cost,
df$revenue,
keep=TRUE,
window.size = 7, # max 7 days shift
step=asymmetric # gives best results for this problem (other: symmetric1 & symmetric2)
);
plot(asy, type="two", off=1);
Thank you for your help!
I think you can enforce this by defining your own window function.
For example, take these series:
library(dtw)
set.seed(310L)
idx <- seq(0, 6.28, len = 100L)
reference <- sin(idx)
query <- cos(idx) + runif(100L) / 10
foo <- dtw(query, reference, keep = TRUE, step.pattern = symmetric2, window.type = sakoeChibaWindow, window.size = 30L)
plot(foo, type = "two", off = 2)
The red line is the reference,
and you want the query's values to only match values from the past or the same day.
win_fun <- function(i, j, ...) { i >= j }
bar <- dtw(query, reference, keep = TRUE, step.pattern = symmetric2, window.type = win_fun)
plot(bar, type = "two", off = 2)
If you want to match past values strictly excluding values from the same time,
change the condition to i > j.
Check the documentation of dtwWindowingFunctions for more options.
You might want to add a window size constraint.
Please see below my code for trying to run a loop of 10000 iterations, every time the code loops I want it to select a new value for my two random variables labelled: premium_A_1 and cost_of_claim.
for (i in 1:10000){
profit_A_scheme1 = c()
premium_A_scheme1=sample(c(200,170,140), size = 1, replace = TRUE, prob = s.d_scheme1)
costclaim_A= runif(1, 0, 400)
profit_A_scheme1[i] = premium_A_scheme1 - costclaim_A
}
The code returns profit_A_scheme_1 = (NA, NA, ..., x) when I was hoping for profit_A_scheme_1 = (x1, x2, ..., xn). Essentially only assigning a value to the final loop and NA for every loop previous. In case anyone tries to run this code the probabilities for the premium r.v. are prob = (0.4510610, 0.3207926, 1 - 0.4510620 - 0.3207926).
Thanks for any help you are able to offer as I've been stuck on this for a minute now.
Try (replace prob =abs(rnorm(3)/100) with your own) :
for (i in 1:10000){
profit_A_scheme1 = NULL
premium_A_scheme1=sample(c(200,170,140), size = 1, replace = TRUE, prob =abs(rnorm(3)/100))
costclaim_A= runif(1, 0, 400)
profit_A_scheme1 = premium_A_scheme1 - costclaim_A
print(profit_A_scheme1)
}
I'm working on a formula in R, that iterates over a data frame in reverse. Right now, the formula will take a set number of columns, and find the mean for each column, up to a set row number. What I'd like to do is have the row number decrease by 1 for each iteration of the for loop. The goal here is to create a "triangular" reference that uses one less value for the column means, per iteration.
Here's some code you can use to create sample data that works in the formula.
test = data.frame(p1 = c(1,2,0,1,0,2,0,1,0,0), p2 = c(0,0,1,2,0,1,2,1,0,1))
Here's the function I'm working with. My best guess is that I'll need to add some sort of reference to i in the mean(data[1:row, i]) section, but I can't seem to work the logic/math out on my own.
averagePickup = function(data, day, periods) {
# data will be your Pickup Data
# day is the day you're forecasting for (think row number)
# periods is the period or range of periods that you need to average (a column or range of columns).
pStart = ncol(data)
pEnd = ncol(data) - (periods-1)
row = (day-1)
new_frame <- as.data.frame(matrix(nrow = 1, ncol = periods))
for(i in pStart:pEnd) {
new_frame[1,1+abs(ncol(data)-i)] <- mean(data[1:row , i])
}
return(sum(new_frame[1,1:ncol(new_frame)]))
}
Right now, inputing averagePickup(test,5,2) will yield a result of 1.75. This is the sum of the means for the first 4 values of the two columns. What I'd like the result to be is 1.33333. This would be the sum of the mean of the first 4 values in column p1, and the mean of the first 3 values in column p2.
Please let me know if you need any further clarification, I'm still a total scrub at R!!!
Like this?
test = data.frame(p1 = c(1,2,0,1,0,2,0,1,0,0), p2 = c(0,0,1,2,0,1,2,1,0,1))
averagePickup = function(data, first, second) {
return(mean(test[1:first,1]) + mean(test[1:second,2]))
}
averagePickup(test,4,3)
This gives you 1.333333
Welp, I ended up figuring it out with a few more head bashes against the wall. Here's what worked for me:
averagePickup = function(data, day, periods) {
# data will be your Pickup Data
# day is the day you're forecasting for (think row number)
# periods is the period or range of periods that you need to average (a column or range of columns).
pStart = ncol(data)
pEnd = ncol(data) - (periods-1)
row = (day-1)
new_frame <- as.data.frame(matrix(nrow = 1, ncol = periods))
q <- 0 # Instantiated a q value. Run 0 will be the first one.
for(i in pStart:pEnd) {
new_frame[1,1+abs(ncol(data)-i)] <- mean(data[1:(day - periods + q) , i]) # Added a subtraction of q from the row number to use.
q <- q + 1 # Incrementing q, so the next time will use one less row.
}
return(sum(new_frame[1,1:ncol(new_frame)]))
}
I have been trying to implement a random walk on the n-cycle algorithm in R.
By n-cycle I mean the set of integers Zn, or modulo n. Basically, it’s example 5.3.1 from the book “Markov chains and mixing time”, by Levin, Peres and Wilmer. The intention is as follows: consider two chains modeling the movement of two particles X and Y on Zn with starting points X1 and Y1. By the flip of a fair coin we decide which particle will move (the particles cannot move simultaneously unless they have coupled); the direction is decided by another flip of fair coin.
Once the two particle collide, they move together hereafter. It is part of a study project to implement a CFTP algorithm, so the length of the chains should have a pre-defined value, say T.
The code does not run and an error message appears. The error is “object ‘res’ not found”. However, I had previously defined “res” as a list to store the output of the function. Why does this happen and how could it be fixed?
I have two scripts: in the first one the code is split in smaller helper functions; the second one may be messier, as I tried to put all the helper functions within one single function.
Any help will be much appreciated.
This one is script 2.
# X1 - initial state of chain X
# Y1 - initial state of chain Y
# T - "length" of a chain, number of steps the chains will run for.
# n - length of the n-cycle, i.e., Zn.
Main_Function <- function (X1 = 8, Y1 = 4 , T = 20, n = 6){
X <- rep( X1, T) %% n # X, Y and res will store the results
Y <- rep( Y1, T) %% n
res <- list(X,Y) # Here I defined the object res. Later on R encounters an error "object 'res' not found".
ps <- TakeOneStep() # TakeOneStep is a function defined below
return(ps)
}
TakeOneStep <- function(){
incr_same <- sample(c(-1, 0, 1), size = 1, prob = c(1/4, 1/2, 1/4)) #direction of the particles after they have coupled
incr_dif <- sample(c(-1,1), size = 1, prob = c(1/2, 1/2)) # direction of the particles before coupling occurred.
choice <- runif(T) # determines which chain moves, before coupling occurred.
for(t in 2:T){
if(res[[1]][t-1]%%n == res[[2]][t-1]%%n){
res[[1]][t] <- (res[[1]][t-1] + incr_same) %% n
res[[2]][t] <- (res[[2]][t-1] + incr_same) %% n
}else{ if(choice[t] < 0.5) {
res[[1]][t] <- (res[[1]][t-1] + incr_dif) %% n
}else{res[[2]][t] <- (res[[2]][t-1] + incr_dif)%%n}
}
}
return(res)
}