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
Related
In R, I can calculate the first-order derivative as the following:
g=expression(x^3+2*x+1)
gPrime = D(g,'x')
x = 2
eval(g)
But I think it's not very readable. I prefer to do something like this:
f = function(x){
x^3+2*x+1
}
fPrime = D(g,'x') #This doesn't work
fPrime(2)
Is that possible? Or is there a more elegant way to do ?
1) D This depends on the particular form of f but for similar ones whose body is one line surrounded by {...} and whose single argument is x and whose operations are in the derivative table this works:
# f is from question
f = function(x){
x^3+2*x+1
}
df <- function(f) {
fun <- function(x) {}
environment(fun) <- environment(f)
body(fun) <- D(body(f)[[2]], "x")
fun
}
df(f)
## function (x)
## 3 * x^2 + 2
2) numDeriv::grad Also consider doing this numerically:
library(numDeriv)
grad(f, 2)
## [1] 14
3) deriv Another approach is to use deriv in the base of R with similar restrictions to (1).
df2 <- function(f) {
fun <- function(x) {
f2 <- deriv(body(f)[[2]], "x", function.arg = TRUE)
attr(f2(x), "gradient")
}
environment(fun) <- environment(f)
fun
}
f2Prime <- df2(f)
f2Prime(2)
## x
## [1,] 14
4) Deriv::Deriv Another apprroach is the Deriv package.
library(Deriv)
Deriv(f, "x")
## function (x)
## 2 + 3 * x^2
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)
Inside an R function, is it possible to detect if the user has assigned the output to an object?
For example, I would like to print on console some information only if the output is not assigned to an object, I am looking for something like this
fun <- function(a){
b <- a^2
if(!<OUTPUT ASSIGNED>) cat('a squared is ', b)
return(invisible(b))
}
So that the result on console would be different whether the function output is assigned or not, e.g:
> fun(5)
> a squared is 25
>
> out <- fun(5)
>
>
Not sure if I've completely thought this one through, but this seems to work for the example you've given. (Note it's important to use = or assign or .Primitive("<-") inside the fun you'd like to subject to this treatment.)
fun <- function(a){
b = a^2 # can't use <- here
if (!identical(Sys.getenv("R_IS_ASSIGNING"), "true")) cat('a squared is ', b)
return(invisible(b))
}
`<-` <- function(a, b) {
Sys.setenv("R_IS_ASSIGNING" = "true")
eval.parent(substitute(.Primitive("<-")(a, b)))
Sys.unsetenv("R_IS_ASSIGNING")
}
fun(5)
#> a squared is 25
out <- fun(6)
out
#> [1] 36
Created on 2019-02-17 by the reprex package (v0.2.1)
If I correctly understand what do you need it's better to use custom print method:
print.squared_value = function(x, ...){
cat('a squared is', x, "\n")
x
}
fun = function(a){
b = a^2
class(b) = union("squared_value", class(b))
b
}
fun(2)
# a squared is 4
UPDATE:
fun = function(a){
b = a^2
invisible(b)
}
h = taskCallbackManager()
# add a callback
h$add(function(expr, value, ok, visible) {
# if it was a call 'fun' without assinment
if(is.call(expr) && identical(expr[[1]], quote(fun))){
cat('a squared is', value, "\n")
}
return(TRUE)
}, name = "simpleHandler")
fun(2)
# a squared is 4
b = fun(2)
b
# [1] 4
# remove handler
removeTaskCallback("R-taskCallbackManager")
If I understood well, this could do the trick:
fun <- function(a){
b <- a^2
if(sum(unlist(lapply(lapply(ls(envir = .GlobalEnv), get), function(x){ identical(x,a^2)})))==0) cat('a squared is ', b)
return(invisible(b))
}
So:
ls(envir=.GlobalEnv) will return all objects in your global environment
lapply(ls(envir = .GlobalEnv), get): will return a list with the content of all objects in your global environment
lapply(lapply(ls(envir = .GlobalEnv), get), function(x){ identical(x,a^2)}): will return a logical list checking if the content of any of all objects in your global environment is identical to the output of your function
sum(unlist(lapply(lapply(ls(envir = .GlobalEnv), get), function(x){ identical(x,a^2)})))==0 if none of the content of any of all objects is identical to hte ouput of your function, then... cat!
I hope this helps you!
Best!
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 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.