I am working on some text with embedded R code. I am using Sweave to produce PDF documents. I'd like to print the functions as written into my PDF, but print(f) where f is an arbitrary function eliminates some of the key aspects, like the function name. For instance:
f <- function(x, y = 2) {
return(x^y)
}
print(f)
yields this:
> source('~/.active-rstudio-document')
function(x, y = 2) {
return(x^y)
}
Is there some version of print or some similar function that would print something I can cut and paste directly back into R, preserving the function declaration (the f <- part)? Also, and this is kind of an after thought, is there a way to set the maximum width in characters?
There's probably a better way but something like this would work:
f <- function(x, y = 2) {
return(x^y)
}
pretty <- function(fun){
captured <- capture.output(fun)
captured[1] <- paste(as.character(substitute(fun)), "<-", captured[1])
cat(paste(captured, collapse="\n"))
}
pretty(f)
## f <- function(x, y = 2) {
## return(x^y)
## }
Related
I need a function created by a list of commands to fully evaluate so that it is identical to the "manual" version of the function.
Background: I am using ScaleR functions in Microsoft R Server and need to apply a set of transformations as a function. ScaleR is very picky about needing to be passed a function that is phrased exactly as specified below:
functionThatWorks <- function(data) {
data$marital_status_p1_ismarried <- impute(data$marital_status_p1_ismarried)
return(data)
}
I have a function that creates this list of transformations (and hundreds more, hence the need to functionalize its writing).
transformList <- list ("data$ismarried <- impute(data$ismarried)",
"data$issingle <- impute(data$issingle)")
This line outputs the evaluated string that I want to the console, but I am unaware of a way to move it from console output to being used in a function:
cat(noquote(unlist(bquote( .(noquote(transformList[1]))))))
I need to evaluate functionIWant so that it is identical to functionThatWorks.
functionIWant <- function(data){
eval( cat(noquote(unlist(bquote( .(noquote(transformList[1])))))) )
return(data)
}
identical(functionThatWorks, functionIWant)
EDIT: Adding in the answer based on #dww 's code. It works well in ScaleR. It is identical, minus meaningless spacing.
functionIWant <- function(){}
formals(functionIWant) <- alist(data=NULL)
functionIWant.text <- parse(text = c(
paste( bquote( .(noquote(transformList[1]))), ";", "return(data)\n")
))
body(functionIWant) <- as.call(c(as.name("{"), functionIWant.text))
Maybe something like this?
# 1st define a 'hard-coded' function
f1 <- function (x = 2)
{
y <- x + 1
y^2
}
f1(3)
# [1] 16
# now create a similar function from a character vector
f2 <- function(){}
formals(f2) <- alist(x=2)
f2.text <- parse(text = c('y <- x + 1', 'y^2'))
body(f2) <- as.call(c(as.name("{"), f2.text))
f2(3)
# [1] 16
I am creating some functions for myself and I don't know how to proceed in order to use an object (e.g. a value) returned from one function to another one, while the console is still running. As an example:
first <- function(x){
return(x)
}
second <- function(y){
z <- x + y
return(z)
}
So if you call these functions with a '+'...
first(x = 5) +
second(y = 5)
I would expect a value of 10. In this particular case, obviously the function second() can't find the object x, because the latter one was assigned in the first() environment.
This style of programming is similar to ggplot(), for example:
ggplot(aes(x = x, y = y), data = data) +
geom_point()
I know this type of programming implies the use of environments, but I can't get it work. Any suggestions?
Thanks!
EDIT
Looking to ggplot package in github I figured it out, I think:
hh_first <- function(data) {
h <- structure(list(data = data), class = c("hh"))
h
}
"+.hh" <- function(e1, e2) {
add_hh(e1, e2)
}
add_hh <- function(h, object) {
h$data <- paste(h$data, object, sep = "")
h$data
}
hh_second <- function(data) {
data
}
For example...
hh_first('Hi') +
hh_second(', how are you?')
Returns a string 'Hi, how are you?'. The plus operator in this case works with objects of class 'hh'.
Any suggestions regarding the code or perhaps possible errors that this kind of coding may produce are welcome.
Try:
first <- function(x){
return(x)
}
second <- function(x ,y){
z <- x + y
return(z)
}
second(first(5), 5)
OR
myX <- first(5)
second(myX, 5)
OR
library(magrittr) # Which uses pipes, %>%, to pass the results of a function to the first variable of the second function
first(5) %>% second(5)
I am currently dealing with a problem. I am working on a package for some specific distributions where among other things I would like to create a function that will fit an mixture to some data. For this I would like to use for example the fitdistr function. The problem is that I don't know from what distributions and weights and number of components the mixture will be composed of. Hence I need a function that will dynamically create an density function of some specified mixture so the fitdistr function can use it. For example if the user will call:
fitmix(data,dist=c(norm,chisq),params=list(c(mean=0,sd=3),df=2),wights=c(0.5,0.5))
to use ML method the code needs to create an density function
function(x,mean,sd,df) 0.5*dnorm(x,mean,sd)+0.5*dchisq(x,df)
so it can call optim or fitdistr.
An obvious solution is to use a lot of paste+eval+parse but I don't think this is the most elegant solution. A nice solution is probably hiding somewhere in non-standard evaluation and expression manipulation, but I have not enough skills in this problematic.
P.S. the params can be used as starting values for the optimizer.
Building expressions is relatively straight forward in R with functions like as.call and bquote and the fact that functions are first class objects in R. Building functions with dynamic signatures is a bit trickier. Here's a pass at some function that might help
to_params <- function(l) {
z <- as.list(l)
setNames(lapply(names(z), function(x) bquote(args[[.(x)]])), names(z))
}
add_exprs <- function(...) {
x <- list(...)
Reduce(function(a,b) bquote(.(a) + .(b)), x)
}
get_densities <- function(f) {
lapply(paste0("d", f), as.name)
}
weight_expr <- function(w, e) {
bquote(.(w) * .(e))
}
add_params <- function(x, p) {
as.call(c(as.list(x), p))
}
call_with_x <- function(fn) {
as.call(list(fn, quote(x)))
}
fitmix <- function(data, dist, params, weights) {
fb <- Reduce( add_exprs, Map(function(d, p, w) {
weight_expr(w, add_params(call_with_x(d), to_params(p)))
}, get_densities(dist), params, weights))
f <- function(x, args) {}
body(f) <- fb
f
}
Note that I changed the types of some of your parameters. The distributions should be strings. The parameters should be a list of named vectors. It would work with a call like this
ff <- fitmix(data, dist=c("norm","chisq"), params=list(c(mean=0,sd=3),c(df=2)),
weights=c(0.5,0.5))
It returns a function that takes an x and a list of named arguments. You could call it like
ff(0, list(mean=3, sd=2, df=2))
# [1] 0.2823794
which returns the same value as
x <- 0
0.5 * dnorm(x, mean = 3, sd = 2) + 0.5 * dchisq(x, df = 2)
# [1] 0.2823794
I am trying to produce different uniform numbers using the Lehmar random number generator. I believe I have done this but I have a problem in producing different numbers each time I execute this function. Below is the code I am trying to do and I will explain the problem further underneath it.
MODULUS <- 2147483647
MULTIPLIER <- 48271
put_Seed <- function(x)
{
x <- (if ( x > 0)
{
x%%MODULUS
}
else
{
1000*as.numeric(Sys.time())
}
)
}
T_val <- function(Rand)
{
Q <- floor(MODULUS / MULTIPLIER)
R <- MODULUS%%MULTIPLIER;
floor(MULTIPLIER*(Rand%%Q) - R*(Rand/Q))
}
New_Random_Seed <- function(T_value_i)
{
Random_Seed <- (if (T_value_i > 0)
{
T_value_i;
}
else
{
T_value_i + MODULUS
})
}
Random <- function(New_Seed)
{
New_Seed/MODULUS
}
uniform_num <- function(a, b, r)
{
a + (b - a) * r
}
Random_Seed <- put_Seed(123456789)
uni_num <- function(k)
{
Random_Seed <- put_Seed(k)
T_value <- T_val(Random_Seed)
Random_Seed <- New_Random_Seed(T_value)
uniform_num(0, 1, Random(Random_Seed))
}
test1 <- uni_num(Random_Seed)
test2 <- uni_num(Random_Seed)
test3 <- uni_num(Random_Seed)
#Results
#test1 = 0.05380306
#test2 = 0.05380306
#test3 = 0.05380306
What I am trying to do is whenever I run the uni_num function that each time, the Random_Seed gets updated and the uniform_num(0, 1, Random(Random_Seed)) line produces a random uniform number between 0 and 1 each time the function is executed. The code works for 1 repetition but if I try to use the function again the Random_Seed has not being updated and hence the function will produce the same random number as before. This is undesirable as I wish to produce different random number's each time by having the Random_Seed updated after each repetition. Forgive me if there is a simple solution but my head is wrecked from trying to find an answer. Cheers :)
In this function:
uni_num <- function(k)
{
Random_Seed <- put_Seed(k)
T_value <- T_val(Random_Seed)
Random_Seed <- New_Random_Seed(T_value)
uniform_num(0, 1, Random(Random_Seed))
}
The target of the assignment Random_Seed <- is in the environment of the function body, and not the global environment. Thus, when you make a second call, Random_Seed in the global environment has not been modified, and you get the same results.
To write to the global environment instead, use <<-:
Random_Seed <<- New_Random_Seed(T_value)
It looks like this is the only assignment that must be modified, as New_Random_Seed returns a value and doesn't require modification of this global object. In addition, the first assignment to Random_Seed in uni_num might as well be in the function body environment.
Note that it's bad form for a function to write to the global environment. There's always a better way. But this will work for your example code.
The function testfun1, defined below, does what I want it to do. (For the reasoning of all this, see the background info below the code example.) The question I wanted to ask you is why what I tried in testfun2 doesn't work. To me, both appear to be doing the exact same thing. As shown by the print in testfun2, the evaluation of the helper function inside testfun2 takes place in the correct environment, but the variables from the main function environment get magically passed to the helper function in testfun1, but not in testfun2. Does anyone of you know why?
helpfun <- function(){
x <- x^2 + y^2
}
testfun1 <- function(x,y){
xy <- x*y
environment(helpfun) <- sys.frame(sys.nframe())
x <- eval(as.call(c(as.symbol("helpfun"))))
return(list(x=x,xy=xy))
}
testfun1(x = 2,y = 1:3)
## works as intended
eval.here <- function(fun){
environment(fun) <- parent.frame()
print(environment(fun))
eval(as.call(c(as.symbol(fun))))
}
testfun2 <- function(x,y){
print(sys.frame(sys.nframe()))
xy <- x*y
x <- eval.here("helpfun")
return(list(x=x,xy=xy))
}
testfun2(x = 2,y = 1:3)
## helpfun can't find variable 'x' despite having the same environment as in testfun1...
Background info: I have a large R code in which I want to call helperfunctions inside my main function. They alter variables of the main function environment. The purpose of all this is mainly to unclutter my code. (Main function code is currently over 2000 lines, with many calls to various helperfunctions which themselves are 40-150 lines long...)
Note that the number of arguments to my helper functions is very high, so that the traditional explicit passing of function arguments ( "helpfun(arg1 = arg1, arg2 = arg2, ... , arg50 = arg50)") would be cumbersome and doesnt yield the uncluttering of the code that I am aiming for. Therefore, I need to pass the variables from the parent frame to the helper functions anonymously.
Use this instead:
eval.here <- function(fun){
fun <- get(fun)
environment(fun) <- parent.frame()
print(environment(fun))
fun()
}
Result:
> testfun2(x = 2,y = 1:3)
<environment: 0x0000000013da47a8>
<environment: 0x0000000013da47a8>
$x
[1] 5 8 13
$xy
[1] 2 4 6