I have a function called in the example fn_example_1 that needs to change with a parameter that comes from another function (n).
It needs to have a fixed part that never changes, and a variable part that gets longer with n, as an example:
# this is the function that needs to change
fn_example_1 <- function(x, mod) {
# -- this part is fixed
mod$a <- x^2 # fixed
# -- this part can change with n
mod$b[5,5, k] <- x + 1 # variable
mod$b[6, 6, k] <- x + 1 # variable
# mod$b[7,7, k] <- x + 1 # if n = 3 ecc..
# k is an arg from a third function, more on that later..
mod
}
This is what I have in mind, basically a wrapper function that gives back a different version of fn_example_1 that depens on n.
fn_wrap_example <- function(fn, n) {
# something
# something
# I've thought about a long if else, of course with a max value for n.
return(fn)
}
fn_wrap_example(fn_example_1, n = 2) # call to the wrapper
It is crucial that fn_wrap_example returns a function, this will be an argument to a third function. As a semplification n can have a max value, ie: 20.
The key is that fn_example_1 is a function that changes with n.
Here is how you can modify a function in your wrapper:
fn_factory <- function(n) {
fn <- function(x, mod) {
# -- this part is fixed
mod$a <- x^2 # fixed
x #place holder
# k is an arg from a third function, more on that later..
mod
}
ins <- switch(n,
"1" = quote(mod$b[5,5, k] <- x + 1),
"2" = quote(mod$b[6, 6, k] <- x + 1)
)
body(fn)[[3]] <- ins
return(fn)
}
fn_factory(2)
#function (x, mod)
#{
# mod$a <- x^2
# mod$b[6, 6, k] <- x + 1
# mod
#}
#<environment: 0x0000000008334eb8>
I seriously doubt you need this, but it can of course be done.
What you are looking for is called a closure.
https://www.r-bloggers.com/closures-in-r-a-useful-abstraction/
http://adv-r.had.co.nz/Functional-programming.html
Simple example:
power <- function(exponent) {
function(x) {
x ^ exponent
}
}
square <- power(2)
square(2)
Related
I was given a task to write a function, which I name: my_mode_k.
The input is consisted of two variables:
(x, k)
as x, is a vector of natural numbers with the length of n. the greatest object of x can be k, given that k < n.
my_mode_k output is the highest frequency object of x. if there's more then one object in the vector that are common in x the same number of times - then the function will output the minimum object between them.
for example:
my_mode_k(x = c(1, 1, 2, 3, 3) , k =3)
1
This is code I wrote:
my_mode_k <- function(x, k){
n <- length(x)
x_lemma <- rep(0, k)
for(i in 1:n){
x_lemma[i] < x_lemma[i] +1
}
x_lem2 <- 1
for( j in 2:k){
if(x_lemma[x_lem2] < x_lemma[j]){
x_lem2 <- j
}
}
x_lem2
}
which isn't working properly.
for example:
my_mode_k(x = c(2,3,4,3,2,2,5,5,5,5,5,5,5,5), k=5)
[1] 1
as the function is supposed to return 5.
I don't understand why and what is the intuition to have in order to even know if a function is working properly (It took me some time to realize that it's not executing the needed task) - so I could fix the mistake in it.
Here are a few steps on how you can achieve this.
k <- 5
input <- c(2,3,4,3,3,3,3,3,3,3,2,2,5,5,5,5,5,5,5,5)
# Calculate frequencies of elements.
tbl <- table(input[input <= k])
# Find which is max. Notice that it returns the minimum of there is a tie.
tbl.max <- which.max(tbl)
# Find which value is your result.
names(tbl.max)
input <- c(2,2,3,3,3,5,5,5)
names(which.max(table(input[input <= k])))
# 3
input <- c(2,2,5,5,5,3,3,3)
names(which.max(table(input[input <= k])))
# 3
Assume I have a function which uses a loop over integer i. Now something goes wrong and I assume the error happens when i=5. Now I can step through every single step (what I did up to now).
But now I read about the condition and text argument of browser and debug:
text a text string that can be retrieved when the browser is
entered.
condition a condition that can be retrieved when the browser
is entered.
Is it possible to use the arguments in a way it works as I want?
Here is an example. The debugger / browser should only start after i=5 is reached:
fun <- function(x, y, n) {
result <- 0
for (i in 1:n) {
# browser(condition = (i == 5)) # does not work
result <- result + i * ( x + y)
}
return(result)
}
x <- 2
y <- 3
n <- 10
# debug(fun, condition = (i == 5)) # does not work
debug(fun)
r <- fun(x, y, n)
print(r)
The solution
if (i == 5) { # inside loop of fun()
browser()
}
is working, but I thougt there might be something better (No extra code inside the function)
You can use the argument expr in browser():
fun <- function(x, y, n) {
result <- 0
for (i in 1:n) {
browser(expr = {i == 5})
result <- result + i * ( x + y)
}
return(result)
}
It will then only open the environment where browser() was called from if the expression evaluates to TRUE.
If you want to use debug():
debug(fun, condition = i == 5)
and then call the function:
fun <- function(x, y, n) {
result <- 0
for (i in 1:n) {
result <- result + i * ( x + y)
}
return(result)
}
fun(x, y, n)
Use advanced features of trace().
First, identify the line of your function to debug, following the help page instructions for the argument at =, leading to at = list(c(3, 4))
> as.list(body(fun))
[[1]]
`{`
[[2]]
result <- 0
[[3]]
for (i in 1:n) {
result <- result + i * (x + y)
}
[[4]]
return(result)
> as.list(body(fun)[[3]])
[[1]]
`for`
[[2]]
i
[[3]]
1:n
[[4]]
{
result <- result + i * (x + y)
}
Next, specify a conditional break point by providing as the tracer= argument an unevaluated expression that invokes the browser when a specific condition is met, tracer = quote(if (i == 3) browser())
So
> trace(fun, tracer = quote(if (i == 3) browser()), at=list(c(3, 4)), print=FALSE)
[1] "fun"
> r <- fun(x, y, n)
Called from: eval(expr, p)
Browse[1]>
debug: {
result <- result + i * (x + y)
}
Browse[2]> i
[1] 3
Browse[2]> result
[1] 15
Browse[2]>
I'm trying to adjust the names of an argument inside a function. I want to create a procedure that takes the body of a function, looks for x, changes every x into x0, and then restores the function to what it was before. To provide an example:
f = function(x, y) -x^2 + x + -y^2 + y
# Take old names
form_old = names(formals(f))
# Make new names
form_new = paste0(form_old, 0)
# Give f new formals
formals(f) = setNames(vector("list", length(form_new)), form_new)
# Copy function body
bod = as.list(body(f))
for (i in 1:length(form_new)) {
bod = gsub(form_old[i], form_new[i], bod)
}
# return from list to call ?
body(f) = as.call(list(bod))
f(1, 1) # produces an error
So far, this code will change all variable names from x to x0 and from y to y0. However, the final output of bod is a character vector and not a call. How can I now change this back to a call?
Thanks in advance!
Surely there is a better way to do what you are trying to do that doesn't require modifying functions. That being said, you definetly don't want to be replacing variables by regular expressions, that could have all sorts of problems. Generally, trying to manipulate code as strings is going to lead to problems, for example, a function like tricky <- function(x, y) { tst <- "x + y"; -xx*x + yy*y }, where there are strings and variable names overlap, will lead to the wrong results.
Here is a function that takes a recursive approach (Recall) to traverse the expression tree (recursion could be avoided using a 'stack' type structure, but it seems more difficult to me).
## Function to replace variables in function body
## expr is `body(f)`, keyvals is a lookup table for replacements
rep_vars <- function(expr, keyvals) {
if (!length(expr)) return()
for (i in seq_along(expr)) {
if (is.call(expr[[i]])) expr[[i]][-1L] <- Recall(expr[[i]][-1L], keyvals)
if (is.name(expr[[i]]) && deparse(expr[[i]]) %in% names(keyvals))
expr[[i]] <- as.name(keyvals[[deparse(expr[[i]])]])
}
return( expr )
}
## Test it
f <- function(x, y) -x^2 + x + -y^2 + y
newvals <- c('x'='x0', 'y'='y0') # named lookup vector
newbod <- rep_vars(body(f), newvals)
newbod
# -x0^2 + x0 + -y0^2 + y0
## Rename the formals, and update the body
formals(f) <- pairlist(x0=bquote(), y0=bquote())
body(f) <- newbod
## The new 'f'
f
# function (x0, y0)
# -x0^2 + x0 + -y0^2 + y0
f(2, 2)
# [1] -4
With a more difficult function, where you want to avoid modifying strings or the other variables named yy and xx for example,
tricky <- function(x, y) { tst <- "x + y"; -xx*x + yy*y }
formals(tricky) <- pairlist(x0=bquote(), y0=bquote())
body(tricky) <- rep_vars(body(tricky), newvals)
tricky
# function (x0, y0)
# {
# tst <- "x + y"
# -xx * x0 + yy * y0
# }
#
There are a few ways to go here. Following your code, I would go with something like this:
f = function(x, y) -x^2 + x + -y^2 + y
# Take old names
form_old = names(formals(f))
# Make new names
form_new = paste0(form_old, 0)
deparse(body(f)) -> bod
for (i in 1:length(form_new)) {
bod = gsub(form_old[i], form_new[i], bod, fixed = TRUE)
}
formals(f) = setNames(vector("list", length(form_new)), form_new)
body(f) <- parse(text = bod)
f(1, 1)
I am very new to R. I am trying to create a function where the user is able to input expressions into arguments. These inputs are then used in plot3d through the rgl package. The function I have so far is :
flight_sim <- function(xval, yval, zval)
{
# Evaluate arguments and convert them into expressions
eval(parse(text = zval))
z <- data.frame(zval)
eval(parse(text = xval))
x <- data.frame(xval)
eval(parse(text = yval))
y <- data.frame(yval)
flight_path <- as.data.frame(cbind(x,y,z))
}
I have a readline() and switch() command :
cat('Select the flight path you wish to plot from the list below :
1. Helix
2. Conical
3. Spherical
4. Define your own flight path...')
userplot <- readline('Enter number here : ') # Allow user to enter choice from above
switch(userplot,"1"=flight_sim( sin(z), 1-cos(z), seq(0,20, pi/32) ),
"2"=flight_sim( z*cos(6*z), z*sin(6*z), seq(0,10, pi/64) ),
"3"=flight_sim( sin(z)*cos(20*z), sin(z)*sin(20*z), seq(0,pi,pi/399)),
"4"=custom())
Where custom() just prompts the user via readline() to enter x, y and z values, which is then followed by eval() and parse() and it works fine.
The problem I've been having is that x and y need to be functions of z, and this causes an error :
Error in parse(text = xval) : object 'z' not found
I thought by making the flight_sim function evaluate the zval argument first that it would fix it, however as I'm new to R I'm just getting more and more lost.
I hope what I have explained here makes some sense. I appreciate any help that can be provided.
Nothing is being passed as text in your example so using parse() doesn't seem necessary. If you want to delay evaulation, the best way would be to use substitute to grab the parameters as promises and then evaluate them in the context of your fliht_sim function. Here's what that would look like
flight_sim <- function(xval, yval, zval) {
z <- eval(substitute(zval))
x <- eval(substitute(xval))
y <- eval(substitute(yval))
data.frame(x,y,z)
}
userplot="2"
x <- switch(userplot,"1"=flight_sim( sin(z), 1-cos(z), seq(0,20, pi/32) ),
"2"=flight_sim( z*cos(6*z), z*sin(6*z), seq(0,10, pi/64) ),
"3"=flight_sim( sin(z)*cos(20*z), sin(z)*sin(20*z), seq(0,pi,pi/399)),
"4"=custom())
head(x)
# x y z
# 1 0.00000000 0.00000000 0.00000000
# 2 0.04697370 0.01424932 0.04908739
# 3 0.08162934 0.05454298 0.09817477
# 4 0.09342212 0.11383519 0.14726216
# 5 0.07513972 0.18140332 0.19634954
# 6 0.02405703 0.24425508 0.24543693
If I'm interpreting your question correctly, it seems like you'd need to redefine your function. To the best of my knowledge, you can't define an argument in the function definition as a function of another argument. You'd need to do that inside the body of the function. So you'd want something like this:
flight_sim <- function(userplot) {
if (userplot == "1") {
z <- seq(0, 20, pi / 32)
x <- sin(z)
y <- 1 - cos(z)
} else if (userplot == "2") {
z <- seq(0, 10, pi / 64)
x <- z * cos(6 * z)
y <- z * sin(6 * z)
} else if (userplot == "3") {
z <- seq(0, pi, pi / 399)
x <- sin(z) * cos(20 * z)
y <- sin(z) * sin(20 * z)
} else if (userplot == "4") {
x <- readline("Please enter a function for the x-value: ")
y <- readline("Please enter a function for the y-value: ")
z <- readline("Please enter a function for the z-value: ")
eval(parse(text = z)) # have to evaluate z first since x and y are functions of z
eval(parse(text = x))
eval(parse(text = y))
} else {
valid_response <- FALSE
while (!valid_response) {
userplot <- readline("Please enter a valid response (1-4): ")
if (userplot %in% 1:4) {
valid_response <- TRUE
flight_sim(userplot)
}
}
}
dat <- data.frame(x, y, z)
return(dat)
}
cat('Select the flight path you wish to plot from the list below :
1. Helix
2. Conical
3. Spherical
4. Define your own flight path...')
userplot <- readline('Enter number here : ') # Allow user to enter choice from above
dat <- flight_sim(userplot)
head(dat)
x y z
1 0.000000000000000000 0.000000000000000000 0.000000000000000000
2 0.046973698885313400 0.014249315773629733 0.049087385212340517
3 0.081629338302900922 0.054542980081485989 0.098174770424681035
4 0.093422122547587999 0.113835185692147969 0.147262155637021552
5 0.075139716235543288 0.181403322008714424 0.196349540849362070
6 0.024057025623845932 0.244255080177979672 0.245436926061702587
In the code above, I've also included one last else statement to catch inappropriate responses from your users. If they enter a choice that could break your code, it will now catch that and ask them to reenter their response.
I want to create a function that takes 3 arguments: a list of values and two cutoff values (a high and a low). Then I want it to how many of the values in the list are within the range of the two cutoff values.
So far I have tried:
count <- function(y, x1, x2){
tmp1 <- length(y)
tmp2 <- length(y>x1)
tmp3 <- length(tmp2<=x2)
return(tmp3)
}
and
count <- function(y, x1, x2){
results <- list()
for (i in y) {
if(y > x1 & y <= x2) {
results <- results+1
}
}
return(results)
}
none of them work. Can some help me correct my code?
Simplify it down. Take the sum of a vectorized logical operation
f <- function(x, y, z) sum(x > y & x < z)
f(1:10, 3, 7)
# [1] 3
But the data.table authors are one step ahead of you. They've written a function between(). I believe there is also one in the dplyr package as well.
library(data.table)
between
# function (x, lower, upper, incbounds = TRUE)
# {
# if (incbounds)
# x >= lower & x <= upper
# else x > lower & x < upper
# }
# <bytecode: 0x44fc790>
# <environment: namespace:data.table>
So for the same result as above you can simply do
sum(between(1:10, 3, 7, FALSE))
# [1] 3