Is it possible to evaluate a function argument in a subsequent function call multiple times, when the value that I try to capture may change inside the mother function?
The problem I have is similar to the example below.
I have a mother function f1() with a child function rnorm() inside a for loop.
The child function should receive a different argument in each iteration of the loop (i.e., rnorm(n = ii), but I want to control this at the level of the mother function.
f1 <- function(I, n = 1) {
res <- vector("list", length = I)
for (ii in seq_len(I)) {
res[[ii]] <- rnorm(n = n)
}
return(res)
}
f1(I = 2, n = 1)
f1(I = 2, n = ii) # desired, but obviously doesn't work
I tried to play around with eval(), quote(), get(), etc. but to no avail.
You want non-standard evaluation, which means you need to modify the expression based on a function parameter (typically using substitute) before it is evaluated.
f1 <- function(I, n = 1) {
nval <- substitute(n)
res <- vector("list", length = I)
if (is.numeric(nval)) {
for (ii in seq_len(I)) {
res[[ii]] <- rnorm(n = n)
}
}
if (is.name(nval)) {
for (ii in seq_len(I)) {
res[[ii]] <- eval(substitute(rnorm(n = nval), list(nval = nval)))
}
}
return(res)
}
f1(I = 2, n = 1)
#[[1]]
#[1] 0.4600974
#
#[[2]]
#[1] -0.6399949
f1(I = 2, n = ii)
#[[1]]
#[1] 0.4554501
#
#[[2]]
#[1] 0.7048373 1.0351035
I think your example is just poor software design. I strongly advise against doing it.
A much better approach would be this:
f1 <- function(I, n) {
res <- vector("list", length = I)
if (missing(n)) {
for (ii in seq_len(I)) {
res[[ii]] <- rnorm(n = ii)
}
} else {
for (ii in seq_len(I)) {
res[[ii]] <- rnorm(n = n)
}
}
return(res)
}
f1(I = 2, n = 1)
f1(I = 2)
Related
Hi so I have the following function:
kde.cv = function(X,s) {
l = length(X)
log.fhat.vector = c()
for (i in 1:l) {
current.log.fhat = log ( kde(X[i],X[-i],s) )
log.fhat.vector[i] = current.log.fhat
}
CV.score = sum(log.fhat.vector)
return(CV.score)
}
I'd like to vectorize this without using any for loops or apply statements, can't seem to get around doing so. Help would be appreciated. Thanks.
EDIT: Given the responses, here are my answers to the questions posed.
Given requests for clarification, I will elaborate on the function inputs and on the user defined function inside the function given. So X here is a dataset in the form of a vector, specifically, a vector of length 7 in the dataset I used as an input to this function. The X I used this function for is c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041). s is a single scalar point set at 0.2 for the use of this function. kde is a user - defined function that I wrote. Here is the implementation:
kde = function(x,X,s){
l = length(x)
b = matrix(X,l,length(X),byrow = TRUE)
c = x - b
phi.matrix = dnorm(c,0,s)
d = rowMeans(phi.matrix)
return(d)
}
in this function, X is the same vector of data points used in kde.cv. s is also the same scalar value of 0.2 used in kde.cv. x is a vector of evaluation points for the function, I used seq(-2.5, -0.5, by = 0.1).
Here is an option using sapply
kde.cv = function(X,s)
sum(sapply(1:length(X), function(i) log(kde(X[i], X[-i], s))))
For convenience, please provide a more complete example. For example, the kde() function. Is that a customized function?
Alternative to sapply, you can try Vectorize(). There are some examples you can find on stack overflow.
Vectorize() vs apply()
Here is an example
f1 <- function(x,y) return(x+y)
f2 <- Vectorize(f1)
f1(1:3, 2:4)
[1] 3 5 7
f2(1:3, 2:4)
[1] 3 5 7
and the second example
f1 <- function(x)
{
new.vector<-c()
for (i in 1:length(x))
{
new.vector[i]<-sum(x[i] + x[-i])
}
return(sum(new.vector))
}
f2<-function(x)
{
f3<-function(y, i)
{
u<-sum(y[i]+y[-i])
return(u)
}
f3.v<-Vectorize(function(i) f3(y = x, i=i))
new.value<-f3.v(1:length(x))
return(sum(new.value))
}
f1(1:3)
[1] 24
f2(1:3)
[1] 24
Note: Vectorize is a wrapper for mapply
EDIT 1
According to the response, I edited your kde.cv function.
kde.cv = function(X,s) {
l = length(X)
log.fhat.vector = c()
for (i in 1:l) {
current.log.fhat = log ( kde(X[i],X[-i],s) )
log.fhat.vector[i] = current.log.fhat
}
CV.score = sum(log.fhat.vector)
return(CV.score)
}
kde = function(x,X,s){
l = length(x)
b = matrix(X,l,length(X),byrow = TRUE)
c = x - b
phi.matrix = dnorm(c,0,s)
d = rowMeans(phi.matrix)
return(d)
}
##### Vectorize kde.cv ######
kde.cv.v = function(X,s)
{
log.fhat.vector = c()
kde.v<-Vectorize(function(i) kde(X[i], X[-i], s))
CV.score <- sum(log(kde.v(1:length(X))))
return(CV.score)
}
X<-c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041)
s<-0.2
x<-seq(-2.5, -0.5, by = 0.1)
kde.cv(X, s)
[1] -10.18278
kde.cv.v(X, s)
[1] -10.18278
EDIT 2
Well, I think the following function may match your requirement. BTW, since the little x is not used in your kde.cv, I just edited both two functions
kde.cv.2 <- function(X,s)
{
log.fhat.vector<-log(kde.2(X, s))
CV.score = sum(log.fhat.vector)
return(CV.score)
}
kde.2<-function(X, s)
{
l <- length(X)
b <- matrix(rep(X, l), l, l, byrow = T)
c <- X - b
diag(c) <- NA
phi.matrix <- dnorm(c, 0, s)
d <- rowMeans(phi.matrix, na.rm = T)
return(d)
}
X<-c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041)
s<-0.2
kde.cv(X,s)
[1] -10.18278
kde.cv.2(X, s)
[1] -10.18278
I'm trying to loop through integers 1:1000 comparing the result of a function I've created with an R function. Specifically, I have:
floor.log2 = function(n) {
x = 1
i = 0
while (x <= n) {
x = 2*x
i = i + 1
}
print(i-1)
}
And I want to compare with:
floor(log(n, base = 2))
Every comparison loop I've created ends up printing each index 1:1000 - what is a succinct way to compare results for 1:1000 in these functions without R printing the indices?
I would modify the existing function you wrote to:
floor.log2 = function(n) {
x = 1
i = 0
while (x <= n) {
x = 2*x
i = i + 1
}
return(i-1)
}
To test:
iter <- 100 # How long you would like to test for
vec1 <- c() # Container of your custom function
vec2 <- c() # Container for the comparison function
for(i in 1:iter) {
vec1[i] <- floor.log2(i)
vec2[i] <- floor(log(i, base = 2))
}
Finally:
all(vec1 == vec2)
I have a custom class object (list of tuples).
I have defined <.myclass >.myclass and ==.myclass on it as well.
Now I have a
a <- obj1 # of myclass
b <- obj2 # of myclass
c <- obj3 # of myclass
L <- list(list(a,12,1),list(b,215,23),list(c,21,9))
I want to sort L, on index 1. i.e. I have b < c < a then, I want sorted L in this form list(list(b,215,23),list(c,21,9),list(a,12,1))
How do I achieve this?
In my searches, I found how to sort on particular index, and using that I wrote the following function
magic_sort <- function(lst, sortind, dec = T) {
return(lst[order(sapply(lst,'[[',sortind), decreasing = dec)])
}
But when I give index 1 to it, to sort on obj1, it fails with
> magic_sort(L,1)
Error in order(sapply(lst, "[[", sortind), decreasing = dec) :
unimplemented type 'list' in 'orderVector1'
Is there any fix for this? In general, can I have functions like sort, minimum and so on, based on custom definition of comparison operators?
Edit: Following perhaps will help understand the structure better: http://pastebin.com/0M7JRLTu
Edit 2:
library("sets")
a <- list()
class(a) <- "dfsc"
a[[1]] <- tuple(1L, 2L, "C", "a", "B")
b <- list()
class(b) <- "dfsc"
b[[1]] <- tuple(1L, 2L, "A", "b", "B")
c <- list()
class(c) <- "dfsc"
c[[1]] <- tuple(1L, 2L, "A", "a", "B")
L <- list()
L[[1]] <- list(a, 12, 132)
L[[2]] <- list(b, 21, 21)
L[[3]] <- list(c, 32, 123)
`<.dfsc` <- function(c1, c2) {
return(lt_list(toList(c1),toList(c2)))
}
`==.dfsc` <- function(c1, c2) {
return(toString(c1) == toString(c2))
}
`>.dfsc` <- function(c1, c2) {
return(!((c1 < c2) || (c1 == c2)))
}
lt_list <- function(l1, l2) {
n1 <- length(l1)
n2 <- length(l2)
j = 1
while(j <= n1 && j <= n2) {
if (l1[[j]] != l2[[j]]) {
return (l1[[j]] < l2[[j]])
}
j = j + 1
}
return(n1 < n2)
}
toString.dfsc <- function(x) {
code_string <- ""
#for(ii in x[[1]]) {
for(ii in x) {
code_string <- paste(code_string,"(",ii[[1]],",",ii[[2]],",",ii[[3]],",",ii[[4]],",",ii[[5]],")", sep = "")
}
return(code_string)
}
Now I want the L desired to be list(list(c,_,_),list(b,_,_),list(a,_,_))
This answer from Aaron demonstrates, exactly, what is needed to apply a customized sort on a classed object. As Roland notes, you -actually- need to sort "L" and, thus, that is where the focus on custom sort should be. To provide flexibility specifying on which index of "L" 's elements to sort, a way would be to store an extra attr on "L":
Turn "L" to an appropriate object:
class(L) = "myclass"
attr(L, "sort_ind") = 1L
Ops methods need to be defined (extract the relevant element of your data):
"<.myclass" = function(x, y)
{
i = attr(x, "sort_ind") ## also check if 'x' and 'y' have the same 'attr(, "sort_ind")'
x[[1]][[i]] < y[[1]][[i]]
}
"==.myclass" = function(x, y)
{
i = attr(x, "sort_ind")
x[[1]][[i]] == y[[1]][[i]]
}
">.myclass" = function(x, y)
{
i = attr(x, "sort_ind")
x[[1]][[i]] > y[[1]][[i]]
}
And a subset method:
"[.myclass" = function(x, i)
{
y = .subset(x, i)
attributes(y) = attributes(x)
return(y)
}
The above methods are necessary (perhaps, except "<") to be defined since a call to sort/order will end up calling rank which needs .gt in order to subset accordingly each element and compare.
Finally, a get/set function for sauce:
sort_ind = function(x) attr(x, "sort_ind")
"sort_ind<-" = function(x, value)
{
attr(x, "sort_ind") = value
return(x)
}
And:
order(L)
#[1] 3 2 1
sort_ind(L) = 3
order(L)
#[1] 2 3 1
A method for sort can be, also, created to wrap all the above:
sort.myclass = function(x, sort_ind = attr(x, "sort_ind"), ...)
{
sort_ind(x) = sort_ind
NextMethod()
}
sort(L)
sort(L, sort_ind = 1)
(I assumed that your toList function would look like something toList = function(x) x[[1L]])
I wanted to make use of internal and supposedly more efficient sort, but doesn't seem like this sort has facility to take custom comparison operator. So I ended up using implementation of quicksort to sort lists of lists at arbitrary index, assuming comparison exists between the elements at that index.
part_qsort <- function(l, idx, low, high) {
lst <- l
pivot <- lst[[high]][[idx]]
i <- low - 1
for(j in low:(high-1)) {
if ((lst[[j]][[idx]] < pivot) || (lst[[j]][[idx]] == pivot)) {
i <- i + 1
swap(lst[[i]],lst[[j]])
}
}
swap(lst[[(i+1)]],lst[[high]])
eval.parent(substitute(l <- lst))
return(i+1)
}
# recursive calls to quicksort
qsort <- function(l,idx,low,high) {
if (low < high) {
lst <- l
pi <- part_qsort(lst,idx,low,high)
qsort(lst, idx, low, pi-1)
qsort(lst, idx, pi+1, high)
eval.parent(substitute(l <- lst))
}
}
Another thing to look into can be library("rlist") which seems to have a bunch of functions implemented on lists.
I am trying to create new functions from a list of function and a list of parameters to be passed to these functions, but am unable to do so so far. Please see the example below.
fun_list <- list(f = function(x, params) {x+params[1]},
z = function(a, params) {a * params[1] * params[2]})
params_list <- list(f = 1, z = c(3, 5))
# goal is to create 2 new functions in global environment
# fnew <- function(x) {x+1}
# znew <- function(a) {a*3*5}
# I've tried
for(x in names(fun_list)){
force(x)
assign(paste0(x, "new"), function(...) fun_list[[x]] (..., params = params_list[[x]]))
}
The goal is to do this dynamically for arbitrary functions and parameters.
Well, force() doesn't work in a for-loop because for loops do not create new environments. Based on a previous question of mine, I created a capture() function
capture <- function(...) {
vars <- sapply(substitute(...()), deparse);
pf <- parent.frame();
Map(assign, vars, mget(vars, envir=pf, inherits = TRUE), MoreArgs=list(envir=pf))
}
this allows
for(x in names(fun_list)) {
f = local({
capture(x);
p = params_list[[x]];
f = fun_list[[x]];
function(x) f(x, p)
})
assign(paste0(x, "new"), f)
}
where we create a local, private environment for the functions to store their default parameter values.
Which gives
fnew(2)
# [1] 3
znew(2)
# [1] 30
How about this:
for(x in names(fun_list)) {
formals(fun_list[[x]])$params <- params_list[[x]]
assign(paste0(x, "new"), fun_list[[x]])
}
This is similar in spirit:
ps <- list(fp=1,zp=c(3,5))
f0s <- substitute(list(f=function(x)x+fp,z=function(a)a*zp1*zp2),as.list(unlist(ps)))
f0s # list(f = function(x) x + 1, z = function(a) a * 3 * 5)
fs <- eval(f0s)
fs$f(1) # 2
To do the fancy thing described in the OP, you'd probably have to mess with formals.
I'm trying to implement the R function ecdf().
I'm considering two cases: one with t 1-dimensional, the other with t as a vector.
#First case
my.ecdf<-function(x,t) {
indicator<-ifelse(x<=t,1,0)
out<-sum(indicator)/length(x)
out
}
#Second case
my.ecdf<-function(x,t) {
out<-length(t)
for(i in 1:length(t)) {
indicator<-ifelse(x<=t[i],1,0)
out[i]<-sum(indicator)/length(t)
}
out
}
How can I check whether I'm doing the right thing with the R function ecdf() or not? This function take as argument just x, therefore I can't specify the value of t.
You could just plot the results and see that it gives something very similar:
# slightly improved version of my.ecdf
my.ecdf<-function(x,t) {
out<-numeric(length(t))
for(i in 1:length(t)) {
indicator <- as.numeric(x<=t[i])
out[i] <- sum(indicator)/length(t)
}
out
}
# test 1
x <- rnorm(1000)
plot(ecdf(x))
lines(seq(-4, 4, length=1000),
my.ecdf(x, seq(-4, 4, length=1000)),
col='red')
# test 2
x <- rexp(1000)
plot(ecdf(x))
lines(seq(0, 8, length=1000),
my.ecdf(x, seq(0, 8, length=1000)),
col='red')
A general tip - you can view the source code of any function by typing its name into the console without parentheses or arguments:
edcf
function (x)
{
x <- sort(x)
n <- length(x)
if (n < 1)
stop("'x' must have 1 or more non-missing values")
vals <- unique(x)
rval <- approxfun(vals, cumsum(tabulate(match(x, vals)))/n,
method = "constant", yleft = 0, yright = 1, f = 0, ties = "ordered")
class(rval) <- c("ecdf", "stepfun", class(rval))
assign("nobs", n, envir = environment(rval))
attr(rval, "call") <- sys.call()
rval
}