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.
Related
I'm writing a function, which results I want to write into a list. However, each function call requires to use the results from the previous function call.
So I'm unsure about how to best make sure that each function call (I'm using an lapply approach) uses the updated results. i've read about <<- and assign, but still don't really now what the cleanest/correctest way would be.
Example:
My naive/wrong approach is:
results <- list()
my_function <- function(x)
{
result <- ifelse(length(results) == 0, 0, results[length(results)])
2 * x + unlist(result)
}
results <- lapply(1:5, my_function)
which returns:
[[1]]
[1] 2
[[2]]
[1] 4
[[3]]
[1] 6
[[4]]
[1] 8
[[5]]
[1] 10
What I would like to return is:
[[1]]
[1] 2
[[2]]
[1] 6
[[3]]
[1] 12
[[4]]
[1] 20
[[5]]
[1] 30
So how do I feed the previous results into the function call?
NOTE: the example function is really a very simple example. I know I could probably do a simple cumsum here. But my real life function is way more complicated and not a simple computation of a number.
The problem is that lapply only updates results after the whole loop is done. Consider the following:
my_function <- function(x)
{
last_res <- ifelse(length(results) == 0, 0, results[[length(results)]])
print(last_res)
2 * x + last_res
}
results <- list()
results <- lapply(1:5, my_function)
[1] 0
[1] 0
[1] 0
[1] 0
[1] 0
Whilst where we use a regular loop:
results <- list()
for(i in 1:5) {
results[[i]] <- my_function(i)
}
[1] 0
[1] 2
[1] 6
[1] 12
[1] 20
Now, a better way of achieving this would be to add a repeats argument into your function itself.
my_function <- function(repeats=5)
{
result_list <- list()
for(i in 1:repeats) {
last_res <- ifelse(length(result_list) == 0, 0, result_list[[length(result_list)]])
result_list[[i]] <- 2 * i + last_res
}
result_list
}
my_function(5)
[[1]]
[1] 2
[[2]]
[1] 6
[[3]]
[1] 12
[[4]]
[1] 20
[[5]]
[1] 30
Although the loop-based approach is not strictly global assigning as described in the sixth circle of Patrick Burns' R Inferno: doing global assignments, the second approach is cleaner.
Now, if we wanted to dive into the flames, we could use lapply:
my_function <- function(x)
{
last_res <- ifelse(length(results) == 0, 0, results[[length(results)]])
print(last_res)
results[[x]] <<- 2 * x + last_res
}
results <- list()
results <- lapply(1:5, my_function)
[1] 0
[1] 2
[1] 6
[1] 12
[1] 20
Interestingly, using assign falls back into the first behaviour
my_function <- function(x)
{
last_res <- ifelse(length(results) == 0, 0, results[[length(results)]])
print(last_res)
assign('results[[x]]', 2 * x + last_res, envir=.GlobalEnv)
}
results <- list()
results <- lapply(1:5, my_function)
[1] 0
[1] 0
[1] 0
[1] 0
[1] 0
It seems that even with assign, lapply only updates the full thing after completion.
This can be explained as from ?assign
assign does not dispatch assignment methods, so it cannot be used to
set elements of vectors, names, attributes, etc.
Note that assignment to an attached list or data frame changes the
attached copy and not the original object: see attach and with.
I want to write a decorator function that adds a counter to a function, counting the number of times it was called. E.g.
foo <- function(x) {x}
foo <- counter_decorator(foo)
foo(1)
foo(1)
# => the counter gets incremented with each call and has the value 2 now
The approach below basically works, but:
I want the inner function (which is returned by the decorator) to have the same formal args as the original function and not just ellipsis (i.e. ...). I am not sure how to accomplish that. Any ideas?
Not sure if the whole approach is a good one. Alternatives or improvements are appreciated.
Here is what I did so far:
# Init or reset counter
counter_init <- function() {
.counters <<- list()
}
# Decorate a function with a counter
#
# Each time the function is called the counter is incremented
#
# fun: function to be decorated
# fun_name: name in .counters list to store number of times in
#
counter_decorator <- function(fun, fun_name = NULL)
{
# use function name if no name is passed explicitly
if (is.null(fun_name)) {
fun_name <- deparse(substitute(fun))
}
fun <- force(fun) # deep copy to prevent infinite recursion
function(...) { # ==> ellipsis not optimal!
n <- .counters[[fun_name]]
if (is.null(n)) {
n <- 0
}
.counters[[fun_name]] <<- n + 1
fun(...)
}
}
Now let's create some functions and decorate them.
library(dplyr) # for pipe
# Create functions and decorate them with a counter
# create and decorate in second call
add_one <- function(x) {
x + 1
}
add_one <- counter_decorator(add_one)
# create and decorate the piping way by passing the fun_name arg
add_two <- {function(x) {
x + 2
}} %>% counter_decorator(fun_name = "add_two")
mean <- counter_decorator(mean)
counter_init()
for (i in 1:100) {
add_one(1)
add_two(1)
mean(1)
}
What we get in the .counters list is
> .counters
$add_one
[1] 100
$add_two
[1] 100
$mean
[1] 100
which is basically what I want.
1) The trace command can be used. Use untrace to undo the trace or set .counter to any desired value to start over again from that value.
f <- function(x) x
trace(f, quote(.counter <<- .counter + 1), print = FALSE)
.counter <- 0
f(1)
## [1] 1
f(1)
## [1] 1
.counter
## [1] 2
2) This variation stores the counter in an attribute of f.
f <- function(x) x
trace(f, quote(attr(f, "counter") <<- attr(f, "counter") + 1), print = FALSE)
attr(f, "counter") <- 0
f(1)
## [1] 1
f(1)
## [1] 1
attr(f, "counter")
## [1] 2
3) This variation stores the counter in an option.
f <- function(x) x
trace(f, quote(options(counter = getOption("counter", 0) + 1)), print = FALSE)
f(1)
## [1] 1
f(1)
## [1] 1
getOption("counter")
## [1] 2
This method stores the counter within the wrapper function itself instead of somewhere in the users environment or package environment. (There's nothing wrong with the latter; the former can be problematic or at least annoying/discourteous.)
The biggest side-effect (liability?) of this is when the package is detached or reloaded (i.e., during development), then the counter list is cleared/re-initialized.
counter_decorator <- function(fun) {
.counter <- 0L
fun2 <- function(...) {
.counter <<- .counter + 1L
cl <- match.call()
cl[[1]] <- fun
eval.parent(cl)
}
formals(fun2) <- formals(args(fun))
fun2
}
Demo:
foo <- function(x, y) x + y
foo2 <- counter_decorator(foo)
get(".counter", envir = environment(foo2))
# [1] 0
foo2(5, 9)
# [1] 14
foo2(5, 11)
# [1] 16
foo2(5, 13)
# [1] 18
get(".counter", envir = environment(foo2))
# [1] 3
Same formals:
formals(foo)
# $x
# $y
formals(foo2)
# $x
# $y
Edited (twice) to better track primitives where formals(.) is NULL; in that case, we can use formals(args(fun)).
Adapted for your preferred methodology, albeit with a little poetic liberty:
counters <- local({
.counters <- list()
function(init = FALSE) {
out <- .counters # will return counters *before* initialization
if (init) .counters <<- list()
out
}
})
counter_decorator <- function(fun, fun_name) {
if (missing(fun_name)) {
fun_name <- deparse(substitute(fun))
}
count <- get(".counters", envir = environment(counters))
count[[fun_name]] <- 0L
assign(".counters", count, envir = environment(counters))
fun2 <- function(...) {
.count <- get(".counters", envir = environment(counters))
.count[[fun_name]] <- if (is.null(.count[[fun_name]])) 1L else .count[[fun_name]] + 1L
assign(".counters", .count, envir = environment(counters))
cl <- match.call()
cl[[1]] <- fun
eval.parent(cl)
}
formals(fun2) <- formals(args(fun))
fun2
}
add_one <- function(x) {
x + 1
}
add_one <- counter_decorator(add_one)
add_two <- {function(x) {
x + 2
}} %>% counter_decorator(fun_name = "add_two")
new_mean <- counter_decorator(mean)
for (i in 1:100) {
add_one(1)
add_two(1)
new_mean(1)
}
counters()
# $add_one
# [1] 100
# $add_two
# [1] 100
# $mean
# [1] 100
formals(new_mean)
# $x
# $...
Initialization is not strictly required. Re-initialization returns the counters before reinitializing, so you don't need a double-call to get the values and then reset (and if you don't care about previous values, just ignore its return).
counters(TRUE)
# $add_one
# [1] 100
# $add_two
# [1] 100
# $mean
# [1] 100
counters()
# list()
add_one(10)
# [1] 11
counters()
# $add_one
# [1] 1
Building on this SO question here I want to write a function that manipulates other functions by (1) setting each line visible () and by (2) wrapping withAutoprint({}) around the body of the function. First, I though some call to trace() would yield my desired result, but somehow I can't figure it out.
Here is a simple example:
# Input function foo
foo <- function(x)
{
line1 <- x
line2 <- 0
line3 <- line1 + line2
return(line3)
}
# some function which alters foo (here called make_visible() )
foo2 <- make_visible(foo)
# so that foo2 looks like this after being altered
foo2 <- function(x)
{
withAutoprint({
(line1 <- x)
(line2 <- 0)
(line3 <- line1 + line2)
(return(line3))
})
}
# example of calling foo2 and desired output/result
> foo2(2)
> (line1 <- x)
[1] 2
> (line2 <- 0)
[1] 0
> (line3 <- line1 + line2)
[1] 2
> (return(line3))
[1] 2
background / motivation
Turning functions visible line by line is helpful with longer custom functions when no real error is thrown, but the functions takes a wrong turn and returns and unwanted output. The alternative is using the debugger clicking next and checking each variable step by step. A function like make_visible might save some time here.
Use case
I see an actual use case for this kind of function, when debugging map or lapply functions which do not through an error, but produce an undesired result somewhere in the function that is being looped over.
Here's a solution that creates exactly the body of the solution you proposed in your question, with the addition of the 2 tests you used in your answer :
make_visible <- function(f) {
if (typeof(f) %in% c("special", "builtin")) {
stop("make_visible cannot be applied to primitive functions")
}
if (! typeof(f) %in% "closure") {
stop("make_visible only takes functions of type closures as argument")
}
f2 <- f
bod <- body(f)
if(!is.call(bod) || !identical(bod[[1]], quote(`{`)))
bod <- call("(",body(f))
else
bod[-1] <- lapply(as.list(bod[-1]), function(expr) call("(", expr))
body(f2) <- call("[[",call("withAutoprint", bod),"value")
f2
}
# solve foo issue with standard adverb way
foo <- function(x)
{
line1 <- x
line2 <- 0
line3 <- line1 + line2
return(line3)
}
foo2 <- make_visible(foo)
foo2
#> function (x)
#> withAutoprint({
#> (line1 <- x)
#> (line2 <- 0)
#> (line3 <- line1 + line2)
#> (return(line3))
#> })[["value"]]
foo2(2)
#> > (line1 <- x)
#> [1] 2
#> > (line2 <- 0)
#> [1] 0
#> > (line3 <- line1 + line2)
#> [1] 2
#> > (return(line3))
#> [1] 2
#> [1] 2
Here's another take, printing nicer as your own second proposal :
make_visible2 <- function(f) {
if (typeof(f) %in% c("special", "builtin")) {
stop("make_visible cannot be applied to primitive functions")
}
if (! typeof(f) %in% "closure") {
stop("make_visible only takes functions of type closures as argument")
}
f2 <- f
bod <- body(f)
if(!is.call(bod) || !identical(bod[[1]], quote(`{`))) {
bod <- bquote({
message(deparse(quote(.(bod))))
print(.(bod))
})
} else {
bod[-1] <- lapply(as.list(bod[-1]), function(expr) {
bquote({
message(deparse(quote(.(expr))))
print(.(expr))
})
})
}
body(f2) <- bod
f2
}
foo3 <- make_visible2(foo)
foo3
#> function (x)
#> {
#> {
#> message(deparse(quote(line1 <- x)))
#> print(line1 <- x)
#> }
#> {
#> message(deparse(quote(line2 <- 0)))
#> print(line2 <- 0)
#> }
#> {
#> message(deparse(quote(line3 <- line1 + line2)))
#> print(line3 <- line1 + line2)
#> }
#> {
#> message(deparse(quote(return(line3))))
#> print(return(line3))
#> }
#> }
foo3(2)
#> line1 <- x
#> [1] 2
#> line2 <- 0
#> [1] 0
#> line3 <- line1 + line2
#> [1] 2
#> return(line3)
#> [1] 2
I figured out two different approaches to my own question above. Both of them use something I would call 'deep function hacking' which is probably not a recommended way of doing this - at least it doesn't look like one should be doing this at all. Before playing around I didn't know this was even possible. Probably there are cleaner and more recommended ways of doing this, therefore I leave this questions open for other approaches.
First approach
I call the function of the first approach make_visible. Basically, this function constructs a new function using the body parts of foo and wrapping those with for loops in ( and then in withAutoprint. It is quite hacky, and only works on the first level of a function (it won't show the deeper structure of, for example, functions that use pipes).
make_visible <- function(.fx) {
if (typeof(.fx) %in% c("special", "builtin")) {
stop("`make_visible` cannot be applied to primitive functions")
}
if (! typeof(.fx) %in% "closure") {
stop("`make_visible` only takes functions of type closures as argument")
}
# make environment of .fx parent environment of new function environment
org_e <- environment()
fct_e <- environment(.fx)
parent.env(org_e) <- fct_e
# get formals and body of input function .f
fct_formals <- formals(.fx)
fct_body <- body(.fx)[-1]
# create a minimal example function for `(`
.f1 <- function(x) {
(x)
}
# extract its body
.f1_body <- body(.f1)[-1]
# build a new function .f2 by combining .f and .f1
.f2 <- function() {}
for (i in seq_along(1:length(fct_body))) {
.f1_body[[1]][[2]]<- fct_body[[i]]
body(.f2)[[1+i]] <- .f1_body[[1]]
}
# extract the body of new function .f2
.f2_body <- body(.f2)[-1]
# create a minimal example function .f3 for `withAutoprint`
.f3 <- function() {
withAutoprint({
x
})
}
# insert body part of .f2 into .f3
for (j in seq_along(1:length(.f2_body))) {
body(.f3)[[2]][[2]][[1+j]] <- .f2_body[[j]]
}
# give .f3 the formals of input function
formals(.f3) <- fct_formals
# return .f3 as new function
.f3
}
Which yields the following outcome:
foo2 <- make_visible(foo)
foo2(1)
> (line1 <- x)
> [1] 1
> (line2 <- 0)
> [1] 0
> (line3 <- line1 + line2)
> [1] 1
> (return(line3))
> [1] 1
This approach has a couple of downsides:
1. Wrapping the output of each line into brackets reduced the readability
2. Further, this approach returns a not the value of the original function, but a list with two elements, the original result value and a logical vector visible, which makes it harder to use the output of this function, especially when using it inside a map call.
foo2(1) %>% str
# > (line1 <- x)
# [1] 1
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 1
# > (return(line3))
# [1] 1
# List of 2
# $ value : num 1
# $ visible: logi TRUE
purrr::map(1:3, foo2)
# > (line1 <- x)
# [1] 1
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 1
# > (return(line3))
# [1] 1
# > (line1 <- x)
# [1] 2
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 2
# > (return(line3))
# [1] 2
# > (line1 <- x)
# [1] 3
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 3
# > (return(line3))
# [1] 3
# [[1]]
# [[1]]$value
# [1] 1
#
# [[1]]$visible
# [1] TRUE
#
#
# [[2]]
# [[2]]$value
# [1] 2
#
# [[2]]$visible
# [1] TRUE
#
#
# [[3]]
# [[3]]$value
# [1] 3
#
# [[3]]$visible
# [1] TRUE
Second approach
While make_visible is a direct approach on my idea of rewriting a function by making each line visible and wrapping it in withAutoprint the second approach rethinks the problem. It is a similar 'deep function hack', looping over body parts of the original function, but this time (1) printing them to console, (2) capturing their evaluated output, (3) printing this output to console, and then (4) actually evaluating each body part. Finally the original function is called and returned invisibly.
reveal <- function(.fx) {
if (typeof(.fx) %in% c("special", "builtin")) {
stop("`reveal` cannot be applied to primitive functions")
}
if (! typeof(.fx) %in% "closure") {
stop("`reveal` only takes functions of type closures as argument")
}
# environment handling
# get environment of .fx and make it parent.env of reveal
org_e <- environment()
fct_e <- environment(.fx)
parent.env(org_e) <- fct_e
# get formals of .fx
fct_formals <- formals(.fx)
# get body of .fx without first part {
fct_body <- body(.fx)[-1]
# define new function to return
.f2 <- function() {
# loop over the body parts of .fx
for (.i in seq_along(1:length(fct_body))) {
# print each body part
cat(paste0(as.list(fct_body)[.i],"\n"))
# check whether eval returns output and if not use eval_tidy
if (length(capture.output(eval(fct_body[[.i]]))) == 0) {
# write output of eval as string
out <- capture.output(rlang::eval_tidy(fct_body[[.i]]))
} else {
# write output of eval as string
out <- capture.output(eval(fct_body[[.i]]))
}
# print output of evaluation
cat(out, sep = "\n")
# evaluate
eval(fct_body[[.i]])
}
# get arguments
.args <- match.call(expand.dots = FALSE)[-1]
# run .fx with .args and return result invisibly
invisible(do.call(.fx, as.list(.args)))
}
# replace formals of .f2 with formals of .fx
formals(.f2) <- fct_formals
# replace environment of .f2 with env of reveal to which env of .fx is a parent environment
environment(.f2) <- org_e
# return new function .f2
.f2
}
The output looks similar but somewhat cleaner:
reveal(foo)(1)
> line1 <- x
> [1] 1
> line2 <- 0
> [1] 0
> line3 <- line1 + line2
> [1] 1
> return(line3)
> [1] 1
This second approach is better because it's more readable and it returns the same value as the original function. However, at the moment I havent't been able to make it work inside a map call. This is probably due to messing with the function environments.
foo2 <- reveal(foo)
purrr::map(1:3, foo2)
#> Error in (function (x) : object '.x' not found
The problem
If I have a list of, say, three vectors:
Lv <- list(c(1,2), c(3,3), c(5,3))
it is easy to append an additional and the same element to each vector of the list, as follows:
lapply(Lv, c, 8)
## [[1]]
## [1] 1 2 8
##
## [[2]]
## [1] 3 3 8
##
## [[3]]
## [1] 5 3 8
However, if I try to apply this same technique inside a function in the following way,
append8 <- function(p1, p2, p3, ...) {
Args <- as.list(match.call())[-1]
lapply(Args, c, 8)
}
the result is disastrous:
append8(c(1,2), c(3,3), c(5,3))
## $p1
## $p1[[1]]
## c(1, 2)
##
## $p1[[2]]
## [1] 8
##
## $p2
## $p2[[1]]
## c(3, 3)
##
## $p2[[2]]
## [1] 8
##
## $p3
## $p3[[1]]
## c(5, 3)
##
## $p3[[2]]
## [1] 8
Debugging the function append8, I found that the Args list is composed in an unusual manner
Args
## $p1
## c(1, 2)
##
## $p2
## c(3, 3)
##
## $p3
## c(5, 3)
which, I guess, is due to the R lazy evaluation. Do you know if there is a way to avoid it?
This works. There may be a better way, however. Applying eval to each list element forces the evaluation of the parsed components of the call.
append8 <- function(p1, p2, p3, ...) {
Args <- as.list(match.call())[-1]
l <- lapply(Args, eval)
lapply(l, c, 8)
}
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