I'm struggling to work out how to code this sum in R; I'm guessing we can use a for loop somehow but can't get my head around it.
The equation I am trying to code is:
n-\sum_{k=0}^{n-1}choose(n-1,k)beta_kexp(kLn-k) for n=1,2,..
where:
beta_k is a vector I already have
L is a constant.
I've coded this manually but would like to put it into some kind of for loop.
mu3<-3-choose(2,1)*beta1*exp(-1*lambdaL*(3-1))-choose(2,2)*beta2*exp(-2*lambdaL*(3-2))
mu4<-4-choose(3,1)*beta1*exp(-1*lambdaL*(4-1))-choose(3,2)*beta2*exp(-2*lambdaL*(4-2))-choose(3,3)*beta3*exp(-3*lambdaL*(4-3))
mu5<-5-choose(4,1)*beta1*exp(-1*lambdaL*(5-1))-choose(4,2)*beta2*exp(-2*lambdaL*(5-2))-choose(4,3)*beta3*exp(-3*lambdaL*(5-3))-choose(4,4)*beta4*exp(-4*lambdaL*(5-4))
etc
lambdaL<-0.5
This is my list of beta's
betarec(10,0.5)
[1] 0.0000000 1.0000000 0.7869387 1.0278660 1.5510843 2.3702034 3.4694342
4.7718938
[9] 6.1685468 7.5667952 8.9154479
Thank you!
Consider a nested apply call with mapply iteratively passing n and k args to an embedded sapply to loop through all successive betas from 1 to current k and iteratively sum the results.
Input
lambdaL <- 0.5
beta <- c(0.0000000,1.0000000,0.7869387,1.0278660,1.5510843,2.3702034,
3.4694342,4.7718938,6.1685468,7.5667952,8.9154479)
Current version
mu3<-3-choose(2,1)*beta[1]*exp(-1*lambdaL*(3-1))-choose(2,2)*beta[2]*exp(-2*lambdaL*(3-2))
mu3
# [1] 2.632121
mu4<-4-choose(3,1)*beta[1]*exp(-1*lambdaL*(4-1))-choose(3,2)*beta[2]*exp(-2*lambdaL*(4-2))-choose(3,3)*beta[3]*exp(-3*lambdaL*(4-3))
mu4
# [1] 3.418404
mu5<-5-choose(4,1)*beta[1]*exp(-1*lambdaL*(5-1))-choose(4,2)*beta[2]*exp(-2*lambdaL*(5-2))-choose(4,3)*beta[3]*exp(-3*lambdaL*(5-3))-choose(4,4)*beta[4]*exp(-4*lambdaL*(5-4))
mu5
# [1] 4.405454
Loop version (output equivalent to previous version)
mu_formula <- function(n,k) {
n + sum(sapply(seq(k), function(i)
-choose((n-1),i)*beta[i]*exp(-i*lambdaL*(n-i))))
}
mu_vector <- setNames(mapply(mu_formula, 3:5, 2:4), paste0("mu", 3:5))
mu_vector
# mu3 mu4 mu5
# 2.632121 3.418404 4.405454
mu_list <- setNames(Map(mu_formula, 3:5, 2:4),paste0("mu", 3:5))
mu_list
# $mu3
# [1] 2.632121
# $mu4
# [1] 3.418404
# $mu5
# [1] 4.405454
Generalized Loop (for all betas)
mu_list <- setNames(Map(mu_formula,seq_along(beta)[-1]+1,seq_along(beta)[-1]),
paste0("mu",seq_along(beta)[-1]+1))
mu_list
# $mu3
# [1] 2.632121
# $mu4
# [1] 3.418404
# $mu5
# [1] 4.405454
# $mu6
# [1] 5.507972
# $mu7
# [1] 6.640989
# $mu8
# [1] 7.756735
# $mu9
# [1] 8.840919
# $mu10
# [1] 9.896983
# $mu11
# [1] 10.93315
# $mu12
# [1] 11.95646
Related
I would like to get the results from a while loop as a vector. My code looks like this and nld is just some numeric data and lk represents yearly rate of a country:
i<-1
while (i<=length(nld)) {
lk<-((nld[i+1]-nld[i])/nld[i])*100
i <- i+1
print(lk) }
But the output looks like this:
> [1] 2.34391
[1] 4.421947
[1] 0.6444809
[1] 11.29308
[1] 4.282817
[1] 1.773046
[1] 5.443044
[1] 6.332272
[1] 9.207917
[1] 6.173719
[1] 5.449088
[1] 3.977678
[1] 7.697896
[1] 6.313985
[1] 1.449447
[1] 5.149968
[1] 1.840442
[1] 2.628424
[1] 2.269874
[1] 4.195588
[1] -2.868499
[1] -2.764851
[1] 0.216549
[1] 1.907869
[1] -2.13202
[1] 4.637701
[1] 1.051423
[1] 3.946669
[1] 4.332345
[1] 6.260946
[1] 3.113528
[1] 1.537622
[1] 3.075729
[1] 2.925915
[1] 5.146445
[1] 6.129935
[1] 5.185049
[1] 3.45909
[1] 7.835161
[1] 9.649116
[1] 1.311721
[1] 0.3325002
... etc.
and i can't get and plot these results from this loop. I would be appreciated if someone could enlighthen me.
Thanks in advance.
i <- 1
result <- c()
while (i<=length(nld)) {
lk<-((nld[i+1]-nld[i])/nld[i])*100
i <- i+1
result <- c(result, lk) } # this collects `lk` in the vector `result`.
But what you are doing is very C-ish (or C++-ish).
Whenever in R or Python you see indexes and index incrementation,
in 99% of the cases there is a better expression in R or Python.
E.g. in this case, you are actually going through nld using a while loop - that is not good.
In R you would use Map() - which can iterate in parallel through vectors/lists.
nld <- 1:10
result <- Map(f=function(x, y) (x - y)/y * 100,
nld[2:length(nld)],
nld)
But there is a mistake in your original code.
You loop from i=1 to i=length(nld) but requires nld[i+1].
The i+1 would in the last case demand sth not existing.
so it should be while (i < length(nld)) { ...
and
result <- Map(f=function(x, y) (x - y)/y * 100,
nld[2:length(nld)],
nld[1:(length(nld)-1)])
Or even more R-ish: use vectorization:
f <- function(x, y) (x-y)/y*100
> f(nld[2:length(nld)], nld[1:(length(nld)-1)])
## [1] 100.00000 50.00000 33.33333 25.00000 20.00000 16.66667 14.28571
## [8] 12.50000 11.11111
Or:
f <- function(vec) {
vec1 <- vec[2:length(vec)]
vec2 <- vec[1:(length(vec)-1)]
(vec1 - vec2)/vec1 * 100 # this uses vectorization!
}
f(nld)
I'm looking for a speedy solution for randomly subsetting vectors nested in a list.
If we simulate the following data, we get a list l that holds 3 million vectors inside, each one is of length 5. But I want the length of each vector to vary. So I thought I should apply a function that randomly subsets each vector. The problem is, this method is not as speedy as I wished.
simulate data: the list l
library(stringi)
set.seed(123)
vec_n <- 15e6
vec_vals <- 1:vec_n
vec_names <- stringi::stri_rand_strings(vec_n, 5)
my_named_vec <- setNames(vec_vals, vec_names)
split_func <- function(x, n) {
unname(split(x, rep_len(1:n, length(x))))
}
l <- split_func(my_named_vec, n = vec_n / 5)
head(l)
#> [[1]]
#> HmPsw Qk8NP Quo3T 8f0GH nZmjN
#> 1 3000001 6000001 9000001 12000001
#>
#> [[2]]
#> 2WtYS ZaHFl 6YjId jbGuA tAG65
#> 2 3000002 6000002 9000002 12000002
#>
#> [[3]]
#> xSgZ6 jM5Uw ujPOc CTV5F 5JRT5
#> 3 3000003 6000003 9000003 12000003
#>
#> [[4]]
#> tF2Kx r4ZCI Ooklo VOLHU M6z6H
#> 4 3000004 6000004 9000004 12000004
#>
#> [[5]]
#> tgdze w8d1B FYERK jlClo NQfsF
#> 5 3000005 6000005 9000005 12000005
#>
#> [[6]]
#> hXaH9 gsY1u CjBwC Oqqty dxJ4c
#> 6 3000006 6000006 9000006 12000006
Now that we have l, I wish to subset each vector randomly: meaning that the number of elements being subsetted (per vector) will be random. So one option is to set the following utility function:
randomly_subset_vec <- function(x) {
my_range <- 1:length(x)
x[-sample(my_range, sample(my_range))]
}
lapply(head(l), randomly_subset_vec)
#> [[1]]
#> Quo3T
#> 6000001
#>
#> [[2]]
#> 6YjId jbGuA
#> 6000002 9000002
#>
#> [[3]]
#> xSgZ6 jM5Uw ujPOc CTV5F
#> 3 3000003 6000003 9000003
#>
#> [[4]]
#> Ooklo
#> 6000004
#>
#> [[5]]
#> named integer(0)
#>
#> [[6]]
#> CjBwC Oqqty dxJ4c
#> 6000006 9000006 12000006
But running this procedure over the entire l takes forever. I've tried using rrapply which is a fast package for dealing with lists, and it takes "only" 110 seconds on my machine.
library(rrapply)
library(tictoc)
tic()
l_subsetted <- rrapply(object = l, f = randomly_subset_vec)
toc()
#> 110.23 sec elapsed
I will be happy with either of the following:
Is there a speedier alternative to:
rrapply(object = l, f = randomly_subset_vec)
Or more generally, is there a speedier way to start with my_named_vec and arrive at l_subsetted?
UPDATE 1 to fix the name behavior in stack for large objects
Your subsets don't include the full set, so this first removes a random element from each vector, then randomly retains all other elements:
library(stringi)
set.seed(123)
vec_n <- 15e6
vec_vals <- 1:vec_n
vec_names <- stringi::stri_rand_strings(vec_n, 5)
my_named_vec <- setNames(vec_vals, vec_names)
split_func <- function(x, n) {
unname(split(x, rep_len(1:n, length(x))))
}
l <- split_func(my_named_vec, n = vec_n / 5)
system.time({
lenl <- lengths(l)
# use stack to unlist the list while keeping the originating list index for each value
vec_names <- names(unlist(l))
blnKeep <- replace(sample(c(FALSE, TRUE), length(vec_names), replace = TRUE), ceiling(runif(length(l))*lenl) + c(0, head(cumsum(lenl), -1)), FALSE)
temp <- stack(setNames(l, seq_along(l)))[blnKeep,]
# re-list
l_subsetted <- unname(split(setNames(temp$values, vec_names[blnKeep]), temp$ind))
})
#> user system elapsed
#> 22.999 0.936 23.934
head(l_subsetted)
#> [[1]]
#> HmPsw nZmjN
#> 1 12000001
#>
#> [[2]]
#> 2WtYS 6YjId
#> 2 6000002
#>
#> [[3]]
#> xSgZ6 jM5Uw ujPOc
#> 3 3000003 6000003
#>
#> [[4]]
#> tF2Kx r4ZCI
#> 4 3000004
#>
#> [[5]]
#> FYERK NQfsF
#> 6000005 12000005
#>
#> [[6]]
#> gsY1u
#> 3000006
Created on 2021-11-01 by the reprex package (v2.0.0)
UPDATE 2 for vectors of uniformly distributed lengths:
#runr is correct in the comments that the above code will result in binomially-distributed vector lengths, while the OP's original code results in uniformly-distributed vector lengths. Below is an example of how to use the same idea to get uniformly-distributed vector lengths. The code is more complex, but the run-time seems to be a bit faster (possibly due to circumventing stack):
library(stringi)
set.seed(123)
vec_n <- 15e6
vec_vals <- 1:vec_n
vec_names <- stringi::stri_rand_strings(vec_n, 5)
my_named_vec <- setNames(vec_vals, vec_names)
split_func <- function(x, n) {
unname(split(x, rep_len(1:n, length(x))))
}
l <- split_func(my_named_vec, n = vec_n / 5)
system.time({
idx <- seq_along(l)
lenl <- lengths(l)
ul <- unlist(l)
# get a random number of elements to remove from each vector
nRemove <- ceiling(runif(length(l))*lenl)
nRemove2 <- nRemove
blnNotEmpty <- nRemove != lenl # will the subset vector have any elements?
blnKeep <- rep(TRUE, length(l))
# loop until the predetermined number of elements have been removed from each vector
while (length(nRemove)) {
# remove a random element from vectors that have too many
ul <- ul[-(ceiling(runif(length(idx))*lenl[idx]) + c(0, head(cumsum(lenl), -1))[idx])]
lenl[idx] <- lenl[idx] - 1L # decrement the vector lengths
blnKeep <- nRemove != 1
idx <- idx[blnKeep]
nRemove <- nRemove[blnKeep] - 1L # decrement the number of elements left to remove
}
l_subsetted <- rep(list(integer(0)), length(l))
l_subsetted[blnNotEmpty] <- unname(split(ul, rep.int(seq_along(l), lenl)))
})
#> user system elapsed
#> 18.396 0.935 19.332
head(l_subsetted)
#> [[1]]
#> Qk8NP Quo3T 8f0GH
#> 3000001 6000001 9000001
#>
#> [[2]]
#> integer(0)
#>
#> [[3]]
#> xSgZ6 ujPOc CTV5F 5JRT5
#> 3 6000003 9000003 12000003
#>
#> [[4]]
#> tF2Kx Ooklo VOLHU
#> 4 6000004 9000004
#>
#> [[5]]
#> tgdze w8d1B jlClo NQfsF
#> 5 3000005 9000005 12000005
#>
#> [[6]]
#> gsY1u CjBwC Oqqty dxJ4c
#> 3000006 6000006 9000006 12000006
# check that vector lengths are uniformly-distributed (lengths of 0-4 are equally likely)
table(lengths(l_subsetted))
#>
#> 0 1 2 3 4
#> 599633 599041 601209 600648 599469
Created on 2021-11-02 by the reprex package (v2.0.1)
Very rough and I'm not particularly proud of this. I'm sure there is a more elegant way but this ran in the matter of seconds on my machine
> # Make some fake data
> out <- lapply(1:3000000, function(i){sample(LETTERS, 5, replace = FALSE)})
> out[1:5]
[[1]]
[1] "D" "H" "C" "Y" "V"
[[2]]
[1] "M" "E" "H" "G" "S"
[[3]]
[1] "R" "P" "O" "L" "M"
[[4]]
[1] "C" "U" "G" "Q" "X"
[[5]]
[1] "Q" "L" "W" "O" "V"
> # Create list with ids to sample
> id <- lapply(1:3000000, function(i){sample(1:5, sample(1:5, 1), replace = FALSE)})
> id[1:5]
[[1]]
[1] 2
[[2]]
[1] 2 3 4 1 5
[[3]]
[1] 4
[[4]]
[1] 5
[[5]]
[1] 1 2
> # Extract the ids from the original data using the id list.
> # Like I said I'm not particularly proud of this but it gets the job
> # done quick enough on my computer
> out <- lapply(1:3000000, function(i){out[[i]][id[[i]]]})
> out[1:5]
[[1]]
[1] "H"
[[2]]
[1] "E" "H" "G" "M" "S"
[[3]]
[1] "L"
[[4]]
[1] "X"
[[5]]
[1] "Q" "L"
Simplify the sampling function:
randomly_subset_vec_2 <- function(x) {
my_range <- length(x)
x[-sample(my_range, sample(my_range, 1))]
}
This alone can give a significant speed-up.
And though I have not tested it, given the problem description, to remove some elements (minus sign before sample) is to keep the others. Why not extract some elements (no minus sign) thereby keeping those?
Simpler and faster: To sample directly from x is the fastest so far.
randomly_subset_vec_3 <- function(x) {
sample(x, sample(length(x), 1))
}
It seems that the largest bottleneck is running all the sample calls, so we could try the following. One way, is the solution by Julius Vainora. First, we generate funFast by Rcpp:
library(inline)
library(Rcpp)
src <-
'
int num = as<int>(size), x = as<int>(n);
Rcpp::NumericVector vx = Rcpp::clone<Rcpp::NumericVector>(x);
Rcpp::NumericVector pr = Rcpp::clone<Rcpp::NumericVector>(prob);
Rcpp::NumericVector rnd = rexp(x) / pr;
for(int i= 0; i<vx.size(); ++i) vx[i] = i;
std::partial_sort(vx.begin(), vx.begin() + num, vx.end(), Comp(rnd));
vx = vx[seq(0, num - 1)] + 1;
return vx;
'
incl <-
'
struct Comp{
Comp(const Rcpp::NumericVector& v ) : _v(v) {}
bool operator ()(int a, int b) { return _v[a] < _v[b]; }
const Rcpp::NumericVector& _v;
};
'
funFast <- cxxfunction(signature(n = "Numeric", size = "integer", prob = "numeric"),
src, plugin = "Rcpp", include = incl)
Then, define an alternative to your randomly_subset_vec using funFast instead of sample:
'randomly_subset_vec_2' <- function(x) {
range <- length(x)
probs <- rep(1/range, range)
o <- funFast(range, size = funFast(range, size = 1, prob = probs), prob = probs)
return(x[-o])
}
tic();obj <- rrapply(object = l, f = randomly_subset_vec_2);toc();
Maybe we can replace randomly_subset_vec with something simpler with sample and sample.int:
lapply(l, function(x) x[sample.int(5, sample(5, 1))])
More efficient is probably to replace the many individual sample calls by a single larger sample call. Below is an approach that samples a large logical matrix keep (since l initially has a rectangular format) and keep only the entries for which keep evaluates to TRUE:
system.time({
keep <- matrix(sample(c(TRUE, FALSE), size = vec_n, replace = TRUE), nrow = 5, ncol = length(l))
l1 <- lapply(seq_along(l), function(i) l[[i]][keep[, i]])
})
#> user system elapsed
#> 8.667 0.448 9.114
head(l1)
#> [[1]]
#> HmPsw Quo3T 8f0GH
#> 1 6000001 9000001
#>
#> [[2]]
#> 2WtYS ZaHFl 6YjId
#> 2 3000002 6000002
#>
#> [[3]]
#> xSgZ6 jM5Uw ujPOc CTV5F 5JRT5
#> 3 3000003 6000003 9000003 12000003
#>
#> [[4]]
#> M6z6H
#> 12000004
#>
#> [[5]]
#> tgdze w8d1B FYERK jlClo NQfsF
#> 5 3000005 6000005 9000005 12000005
#>
#> [[6]]
#> hXaH9 CjBwC Oqqty
#> 6 6000006 9000006
NB: here the order of the entries in l stays the same (i.e. no resampling), also list elements of l1 are not guaranteed to contain at least one value.
I'm putting this in a new answer so as to not further confuse my previous one.
I noticed from some of the comments that the vectors in l are intended to have all the same lengths (5) and that you may not need l at all. It's also a little unclear whether you want the lengths of l_subsetted to be between 0 and 4 or between 0 and 5. You also seem to be interested in the distribution of the lengths of l_subsetted (uniform vs. binomial).
Below is a generic function if length(unique(lengths(l))) == 1. It subsets directly from my_named_vec without creating l. It pretty consistently runs in the 5-13 second range.
set.seed(123)
vec_n <- 15e6L
my_named_vec <- setNames(1:vec_n, stringi::stri_rand_strings(vec_n, 5))
fSub <- function(nv, vecLen = 5L, maxLen = 5L, unif = FALSE) {
# subset each named vector from the list l (l is not generated):
# l <- unname(split(nv, rep_len(seq(length(nv)/vecLen), length(nv))))
# INPUTS:
# nv: named vector whose length is a multiple of vecLen
# vecLen: the length of the vectors in l
# maxLen: the maximum length of the subsetted vectors
# unif: FALSE = binomial subset vector lengths
# TRUE = uniform subset vector lengths
# OUTPUT: a list of named vectors subset from l
nrw <- length(nv)%/%vecLen # length of the output list
# get all possible logical indices for sampling each vector in l
mKeep <- as.matrix(expand.grid(rep(list(c(TRUE, FALSE)), vecLen)), ncol = vecLen)
nKeep <- rowSums(mKeep)
# remove logical indices that would result in vectors greater than maxLen
blnKeep <- nKeep <= maxLen
mKeep <- mKeep[blnKeep,]
nKeep <- nKeep[blnKeep]
if (unif) {
# sample mKeep with non-uniform probability in order to get uniform lengths
iKeep <- sample(length(nKeep), nrw, replace = TRUE, prob = 1/choose(vecLen, nKeep))
} else {
iKeep <- sample(length(nKeep), nrw, replace = TRUE)
}
blnKeep <- c(mKeep[iKeep,])
l <- rep(list(integer(0L)), nrw)
l[iKeep != length(nKeep)] <- unname(split(nv[blnKeep], rep(1:nrw, vecLen)[blnKeep]))
return(l)
}
lbinom5 <- fSub(my_named_vec) # binomial vector lengths (0 to 5)
lunif5 <- fSub(my_named_vec, unif = TRUE) # uniform vector lengths (0 to 5)
lbinom4 <- fSub(my_named_vec, maxLen = 4L) # binomial vector lenghts (0 to 4)
lunif4 <- fSub(my_named_vec, maxLen = 4L, unif = TRUE) # uniform vector lengths (0 to 4)
> microbenchmark::microbenchmark(
+ lbinom5 = {lbinom5 <- fSub(my_named_vec)},
+ lunif5 = {lunif5 <- fSub(my_named_vec, unif = TRUE)},
+ lbinom4 = {lbinom4 <- fSub(my_named_vec, maxLen = 4L)},
+ lunif4 = {lunif4 <- fSub(my_named_vec, maxLen = 4L, unif = TRUE)},
+ times = 10)
Unit: seconds
expr min lq mean median uq max neval
lbinom5 5.974837 8.060281 9.192600 9.014967 10.15609 13.01182 10
lunif5 5.240133 6.618115 9.688577 10.799230 11.44718 12.73518 10
lbinom4 5.082508 6.497218 8.636434 8.656817 11.40678 11.81519 10
lunif4 5.468311 6.639423 8.310269 7.919579 10.28546 11.28075 10
You can try the code below
lapply(
l,
function(x) {
head(sample(x), sample(length(x), 1))
}
)
I tried to create a repeat loop function based on logical case as follow:
n=5 # number of element in lambda
t=10 # limit state
lambda=c(runif(n,2,4)) #vector to be tested
tes=function(x)
{
if(x>=t) {a=0;b=0;c=0}
else
{
repeat
{
a=runif(1,0.5,0.8)
b=runif(1, 5, 8)
c=x+a+b
print(a)
print(b)
if (c>=t) {break}
}
}
return(list(a,b,c))
}
I need to save all of the repeat loop iterations output into an object in the workspace to be used afterwards. however my function only save the latest value of the iterations.
here's the example of iteration for lambda[1]:
The iteration:
[1] 0.6714837
[1] 5.840948
[1] 0.7914275
[1] 7.264076
The saved result in the list:
[[1]]
[[1]][[1]]
[1] 0.7914275
[[1]][[2]]
[1] 7.264076
[[1]][[3]]
[1] 11.03819
how to save each of the result per iterations in the output list?
I’ve looked through other thread, but I haven’t found a suitable solution for my case yet. Thank you.
You can accumulate the results onto a data.frame.
I would also recommend you not assign identifiers like c and t, since those are built-in functions which can be masked by locals, especially if you're passing around functions as arguments, such as do.call(c,...).
I also suggest that it's probably appropriate to pass the limit state variable as another argument to the function.
tes <- function(x,lim) {
res <- data.frame(a=double(),b=double(),c=double());
if (x >= lim) {
res[1L,] <- c(0,0,0);
} else {
i <- 1L;
repeat {
ta <- runif(1L,0.5,0.8);
tb <- runif(1L,5,8);
tc <- x+ta+tb;
res[i,] <- c(ta,tb,tc);
print(ta);
print(tb);
if (tc >= lim) break;
i <- i+1L;
};
};
return(res);
};
Demo:
set.seed(5L);
n <- 5L; ## number of elements in lambda
lambda <- runif(n,2,4); ## vector to be tested
lambda;
## [1] 2.400429 3.370437 3.833752 2.568799 2.209300
res <- lapply(lambda,tes,10);
## [1] 0.7103172
## [1] 6.58388
## [1] 0.7423806
## [1] 7.8695
## [1] 0.5331359
## [1] 5.819855
## [1] 0.647154
## [1] 5.955212
## [1] 0.6677518
## [1] 5.787779
## [1] 0.5605626
## [1] 6.162577
## [1] 0.7663609
## [1] 6.664768
## [1] 0.7526538
## [1] 7.670621
## [1] 0.7162103
## [1] 5.634021
## [1] 0.5677152
## [1] 5.419951
## [1] 0.6439742
## [1] 6.312236
## [1] 0.7897892
## [1] 5.425742
## [1] 0.7864937
## [1] 6.334192
## [1] 0.5178087
## [1] 5.825448
## [1] 0.5093445
## [1] 5.043447
## [1] 0.6461507
## [1] 6.785455
## [1] 0.6793559
## [1] 6.193042
## [1] 0.6190491
## [1] 7.448228
res;
## [[1]]
## a b c
## 1 0.7103172 6.58388 9.694626
## 2 0.7423806 7.86950 11.012310
##
## [[2]]
## a b c
## 1 0.5331359 5.819855 9.723428
## 2 0.6471540 5.955212 9.972803
## 3 0.6677518 5.787779 9.825968
## 4 0.5605626 6.162577 10.093577
##
## [[3]]
## a b c
## 1 0.7663609 6.664768 11.26488
##
## [[4]]
## a b c
## 1 0.7526538 7.670621 10.99207
##
## [[5]]
## a b c
## 1 0.7162103 5.634021 8.559531
## 2 0.5677152 5.419951 8.196967
## 3 0.6439742 6.312236 9.165510
## 4 0.7897892 5.425742 8.424831
## 5 0.7864937 6.334192 9.329986
## 6 0.5178087 5.825448 8.552557
## 7 0.5093445 5.043447 7.762092
## 8 0.6461507 6.785455 9.640906
## 9 0.6793559 6.193042 9.081698
## 10 0.6190491 7.448228 10.276578
You can save the intermediate results in a list, then return it (loop_results). See below. I have also formatted a bit your code so that, intermediate results are printed in a more intelligible/compact way, and the returned list is named.
tes <- function(x) {
if(x>=t) {
a=0;b=0;c=0
} else {
loop_results <- list()
i=0
repeat
{
i <- i+1
a=runif(1,0.5,0.8)
b=runif(1, 5, 8)
c=x+a+b
cat("iteration ", i, "a: ", a, "b: ", b, "\n")
loop_results[[i]] <- list(a=a, b=b, c=c)
if (c>=t) {break}
}
}
return(list(a=a, b=b, c=c, loop_results=loop_results))
}
I took the liberty to add an argument in the function and a "maximum iteration" argument coupled with a warning. i think the optimal result form is the data frame for vectors a, b, and c.
Then, to apply it on a vector, I propose to use an lapply function.
n <- 5 # number of element in lambda
limitstate <- 10 # limit state
lambda <- c(runif(n,2,4)) #vector to be tested
tes <- function(x, t, maxiter = 1000) {
if( x >= t) {
return(data.frame(a=0, b=0, c=0))
} else {
iter <- 1
a <- c()
b <- c()
c <- c()
repeat {
a[iter] <- runif(1, 0.5, 0.8)
b[iter] <- runif(1, 5, 8)
c[iter] <- x + a[iter] + b[iter]
if (c[iter] >= t) break
iter <- iter+1
if (iter >= maxiter) {
warning("Maximum iteration reached")
break
}
}
}
return(data.frame(a=a,b=b,c=c))
}
tes(2, 10)
lapply(lambda, tes, t=limitstate)
A similar problem is faced in this question, that I hope you find useful. So, you should insert a cumulative function inside of your's, as in the following example. It simulate a game where, in case of victory you earn money, otherwise you will lose it. This procedure stores your savings fluctuations during all the process.
x <- y <- 10
while (x > 0) {
if (rbinom(1, 1, 0.5) == 1) {
x <- x + 10
} else {
x <- x - 1
}
y <- c(y, x)
}
Otherwise, if your problem goes on a superior dimensional level, you could try a vectorized approach, which is much faster. But for your problem the approach exposed should be fine.
Recently I've stumbled upon this bit of code:
y <- NULL
y[cbind(1:2, 1:2)] <- list( list(1,2), list(2,3))
From the second answer here.
But it doesn't seem to differ from y <- list(...), as the comparisons below show:
> identical(y, list( list(1,2), list(2,3)))
[1] TRUE
> identical(y, y[cbind(1:2, 1:2)])
[1] FALSE
What is going on in the bracket assignment here? Why it doesn't throw an error? And why is it different from the non-assigment version in the last line of code?
Matrix indexing only applies when y has dim. Combine this with standard R recycling and the fact that all matrices are actually vectors, and this behavior makes sense.
When you initialize y to NULL, you ensure it has no dim. Therefore, when you index y by a matrix, say ind, you get the same results as having called y[as.vector(ind)]
identical(y[ind], y[as.vector(ind)])
# [1] TRUE
If there are repeat values in ind and you are also assigning, then for each index, only the last value assigned ot it will remain. For example Lets assume we are executing
y <- NULL; y[cbind(1:2, 2:1)] <- list( list(1,2), list(3,4) )
# y has no dimension, so `y[cbind(1:2, 2:1)]`
# is the equivalent of `y[c(1:2, 2:1)]`
When you assign y[c(1, 2, 2, 1)] <- list("A", "B") , in effect what happens is analogous to:
y[[1]] <- "A"
y[[2]] <- "B"
y[[2]] <- "B" # <~~ 'Overwriting' previous value
y[[1]] <- "A" # <~~ 'Overwriting' previous value
Here is a further look at the indexing that occurs: (Notice how the first two letters are being repeated)
ind <- cbind(1:2, 1:2)
L <- as.list(LETTERS)
L[ind]
# [[1]]
# [1] "A"
#
# [[2]]
# [1] "B"
#
# [[3]]
# [1] "A"
#
# [[4]]
# [1] "B"
Here is the same thing, now with assignment. Notice how only the 3rd and 4th values being assigned have been kept.
L[ind] <- c("FirstWord", "SecondWord", "ThirdWord", "FourthWord")
L[ind]
# [[1]]
# [1] "ThirdWord"
#
# [[2]]
# [1] "FourthWord"
#
# [[3]]
# [1] "ThirdWord"
#
# [[4]]
# [1] "FourthWord"
Try a different index for further clarity:
ind <- cbind(c(3, 2), c(1, 3)) ## will be treated as c(3, 2, 1, 3)
L <- as.list(LETTERS)
L[ind] <- c("FirstWord", "SecondWord", "ThirdWord", "FourthWord")
L[1:5]
# [[1]]
# [1] "ThirdWord"
#
# [[2]]
# [1] "SecondWord"
#
# [[3]]
# [1] "FourthWord"
#
# [[4]]
# [1] "D"
#
# [[5]]
# [1] "E"
L[ind]
# [[1]]
# [1] "FourthWord"
#
# [[2]]
# [1] "SecondWord"
#
# [[3]]
# [1] "ThirdWord"
#
# [[4]]
# [1] "FourthWord"
Edit regarding #agstudy's questions:
Looking at the src for [ we have the following comments:
The special [ subscripting where dim(x) == ncol(subscript matrix)
is handled inside VectorSubset. The subscript matrix is turned
into a subscript vector of the appropriate size and then
VectorSubset continues.
Looking at the function static SEXP VectorSubset(SEXP x, SEXP s, SEXP call) the relevant check is the following:
/* lines omitted */
attrib = getAttrib(x, R_DimSymbol);
/* lines omitted */
if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
/* lines omitted */
...
This is a reproducible example:
a <- 0.05
za.2 <- qnorm(1-a/2)
b <- 0.20
zb <- qnorm(1-b)
lambda12 <- -log(1/2)/12
lambda18 <- -log(1/2)/18
theta <- lambda18/lambda12
(d = round(4*(za.2+zb)^2/log(theta)^2))
Tf<-36
library(Ryacas)
n <- Sym("n")
Solve(n/2*(2-exp(-lambda12*Tf)-exp(-lambda18*Tf))==d , n)
The last line returns
expression(list(n == 382/1.625))
Is there a way to extract the quotient and assign it to another variable (235.0769)?
G.Grothendieck pointed out in comments that you'll need to first to capture the expression to be operated upon below:
soln <- Solve(n/2*(2-exp(-lambda12*Tf)-exp(-lambda18*Tf))==d , n)
X <- yacas(soln)$text
Then, to extract the quotient, you can take advantage of the fact that many R language objects either are or can be coerced to lists.
X <- expression(list(n == 382/1.625))
res <- eval(X[[1]][[2]][[3]])
res
[1] 235.0769
The following just shows why that sequence of indices extracts the right piece of the expression:
as.list(X)
# [[1]]
# list(n == 382/1.625)
as.list(X[[1]])
# [[1]]
# list
#
# [[2]]
# n == 382/1.625
as.list(X[[1]][[2]])
# [[1]]
# `==`
#
# [[2]]
# n
#
# [[3]]
# 382/1.625