Consider the following code
i = 3
j = i
i = 4 # j != i
However, what I want is
i = 3
f <- function(x, j=i)
x * j
i = 4
f(4) # 16, but i want it to be 12
In case you are wondering why I want to do this you could consider this code - the application is a multiple decrements model. The diagonals of a transition matrix are the sum of the other decrements in that row. I would like to define the decrements I need than calculate the other functions using those decrements. In this case, I only need uxt01 and uxt10 and from these I want to produce the functions uxt00 and uxt11. I wanted something that scales to higher dimensions.
Qxt <- matrix(c(uxt00=function(t=0,x=0) 0,
uxt01=function(t=0,x=0) 0.05,
uxt10=function(t=0,x=0) 0.07
uxt11=function(t=0,x=0) 0), 2, 2, byrow=TRUE)
Qxt.diag <- function(Qxt) {
ndecrements <- length(Qxt[1,])
for(index in seq(1, N, N+1)) { # 1, 4
Qxt[[index]] <- function(t=0, x=0, i=index, N=ndecrements) {
row <- ceiling(index/ndecr)
row.decrements <- seq( (row - 1)*N + 1, (row)*N)
other.decrements <- row.decrements[which(row.decrements != i]
-sum(unlist(lapply(Qxt.fns[[other.decrements]],
function(f) f(t,x))))
}
}
Qxt.fns
}
This can be done by assigning the default expression for the formal parameter j manually, after creating the function:
i <- 3;
f <- function(x,j) x*j;
f;
## function(x,j) x*j
formals(f);
## $x
##
##
## $j
##
##
formals(f)$j <- i;
f;
## function (x, j = 3)
## x * j
formals(f);
## $x
##
##
## $j
## [1] 3
##
i <- 4;
f(4);
## [1] 12
This is only possible because R is an awesome language and provides you complete read/write access to all three special properties of functions, which are:
The parse tree that comprises the body: body().
The formal parameters and their default values (which are themselves parse trees): formals().
The enclosing environment (which is used to implement closures): environment().
Assign it to a different variable if you want to reuse i:
default_value = i
f = function(x, j = default_value)
x * j
i = 4
f(4) # 12
of course, you should not let this variable just lying around — that’s as bad as the original code. You can make it “private” to the function, though, by defining both together in a local environment:
f = local({
default_value = i
function(x, j = default_value)
x * j
})
Related
Suppose I have a function with a kink. I want to derive a kink point, which in this case is 0.314. I tried optim but it does not work.
Here is an example. In general, I want to derive c. Of course, I could use brute force, but it is slow.
# function with a kink
f <- function(x, c){
(x >= 0 & x < c) * 0 + (x >= c & x <=1) * (sin(3*(x-c))) +
(x < 0 | x > 1) * 100
}
# plot
x_vec <- seq(0, 1, .01)
plot(x_vec, f(x_vec, c = pi/10), "l")
# does not work
optim(.4, f, c = pi/10)
This function has no unique minimum.
Here, a trick is to transform this function a little bit, so that its kink becomes a unique minimum.
g <- function (x, c) f(x, c) - x
x_vec <- seq(0, 1, 0.01)
plot(x_vec, g(x_vec, c = pi/10), type = "l")
# now works
optim(0.4, g, c = pi/10, method = "BFGS")
#$par
#[1] 0.3140978
#
#$value
#[1] -0.3140978
#
#$counts
#function gradient
# 34 5
#
#$convergence
#[1] 0
#
#$message
#NULL
Note:
In mathematics, if we want to find something, we have to first define it precisely. So what is a "kink" exactly? In this example, you refer to the parameter c = pi / 10. But what is it in general? Without a clear definition, there is no algorithm/function to get it.
I am in the process of transforming a traditional loop to a foreach loop for solving the shoelace formula problem in R; however, I am not getting the right accumulation with the foreach loop.
library("foreach")
x = c(0, 4, 4, 0)
# coordinates of points
y = c(0, 0, 4, 4)
# coordinates of points
points <- length(x)
area <- 0
# Accumulates area in the loop
i <- 0
j <- points
# using foreach loop
area <- foreach(i = seq(x), .combine = "+") %do% {
(x[[j]] + x[[i]]) * (y[[j]] - y[[i]])
j <- i
}
area # 10
This is just 1 + 2 + 3 + 4. It has not taken into account the points in x and y.
# using traditional loop
area <- vector("list", length(x))
for (i in seq_along(x)) {
area[[i]] <- (x[[j]] + x[[i]]) * (y[[j]] - y[[i]])
j <- i
}
area
# [[1]]
# [1] 0
# [[2]]
# [1] 0
# [[3]]
# [1] -32
# [[4]]
# [1] 0
The sum is 32 units, which is correct.
What am I doing wrong with the foreach loop? Thank you.
foreach is returning the last calculated expression, as in regular functions.
So, you can do:
area <- foreach(i = seq(x)) %do% {
j0 <- j
j <- i
(x[[j0]] + x[[i]]) * (y[[j0]] - y[[i]])
}
I have written a function in R like this:
foo <- function(a, b = 1) {
...
}
But now I want to change the default argument b, like:
foo(b = 2)
This is a function of a in principle. But R doesn't allow this, which throws me an error.
How can I fix it?
Your code in foo(b = 2) is function application: if everything works as expected, it will give you a value rather than a function.
You can modify the default values of arguments using formals:
foo <- function(a, b = 1) {
a + b
}
formals(foo)$b <- 2
foo
#function (a, b = 2)
# {
# a + b
# }
If you don't want to modify your foo directly, there are several options:
1) Copy first, change later
foa <- foo
formals(foa)$b <- 42
One might think of using "formals<-" as a shortcut but that can be complicated as you need to supply the full list of arguments (using alist rather than list because the former can take an empty argument):
"formals<-"(foo, , list(b=2)) # trying it with `list`
function (b = 2) # we lost one argument!
{
a + b
}
"formals<-"(foo, , alist(a=, b=42)) # this one is better!
function (a, b = 42)
{
a + b
}
2) Use purr::partial or function(a) foo(a,b=42) as recommended in the other answer.
3) And a third way ... one can actually write a very simple function (I'll call it p2) that changes some of the default arguments of a function and returns the changed function:
p2 <- function(f, l){
formals(f)[names(l)] <- l
f
}
p2(foo, list(b=42)) # changing a default: function (a, b = 42) a+b
p2(foo, alist(b=)) # removing a default: function (a, b) a+b
p2(foo, list(c="bingo") # adding an argument: function (a, b = 2, c = "bingo") a+b
A modified version:
p3 <- function(f, ...){
l <- as.list(sys.call())[-(1L:2L)] # code from `alist`
formals(f)[names(l)] <- l
f
}
Now the usage becomes shorter:
p3(foo, b=43) # function (a, b = 43) a+b
p3(foo, b=) # function(a,b) a+b
Note that p2 and p3 won't work properly with generic functions such as mean and min. This is probably the reason why the code in purrr:partial is so much more complicated.
You can call foo as so: foo(a, b = whatever)
If you need to change the default b to the same value really often, you could make a new foo-related function.
You could either define a new function:
# partially substitute in a `b` value
goo <- purrr::partial(foo, b = 2, .first = FALSE)
# or, a bit more explicitly,
hoo <- function(a) {foo(a, b = 2)}
or construct a function builder/factory, that allows you to build as many foo-related functions as you like
foo_builder <- function(b = 1) {
function(a) {
# your definition of foo goes here
blah <- blah_f(a, b)
}
}
Now you can pass in a b value to foo_builder and it will return the equivalent function to foo(a, b = whatever_you_passed_to_foo_builder)
goo <- foo_builder(2)
goo(a = ...)
For example,
foo_builder <- function(b = 1){
function(a){
message(b)
a + b
}
}
Now when the internal function is defined by foo_builder, it takes the value of b that is available to the foo_builder environment. This is 1 by default, but can be changed.
For example,
# default
foo_builder()(1)
1
[1] 2
# with b=2 in the closure returned by foo_builder
b <- 2
fb <- foo_builder(b)
fb(1)
2
[1] 3
A commenter suggested that you ought to force the evaluation of b when you make closures this way; because of the following:
b <- 2
fb <- foo_builder(b)
b <- 3
fb(1)
# 3
# [1] 4
So maybe rewrite the foo_builder:
foo_builder <- function(b = 1){
force(b)
function(a){
message(b)
a + b
}
}
For tutorial purposes, I'd like to be able to print or display matrices and vectors side-by-side, often to illustrate the result of a matrix equation, like $A x = b$.
I could do this using SAS/IML, where the print statement takes an arbitrary collection of (space separated) expressions, evaluates them and prints the result, e.g.,
print A ' * ' x '=' (A * x) '=' b;
A X #TEM1001 B
1 1 -4 * 0.733 = 2 = 2
1 -2 1 -0.33 1 1
1 1 1 -0.4 0 0
Note that quoted strings are printed as is.
I've searched, but can find nothing like this in R. I imagine something like this could be done by a function showObj(object, ...) taking its list of arguments, formatting each to a block of characters, and joining them side-by-side.
Another use of this would be a compact way of displaying a 3D array as the side-by-side collection of its slices.
Does this ring a bell or does anyone have a suggestion for getting started?
I have created a very simple function that can print matrices and vectors with arbitrary character strings (typically operators) in between. It allows for matrices with different numbers of rows and treats vectors as column matrices. It is not very elaborate, so I fear there are many examples where it fails. But for an example as simple as the one in your question, it should be enough.
format() is used to convert the numbers to characters. This has the advantage that all the rows of the matrix have the same width and are thus nicely aligned when printed. If needed, you could add some of the arguments of format() also as arguments mat_op_print() to make the configurable. As an example, I have added the argument width that can be used to control the minimal width of the columns.
If the matrices and vectors are name in the function call, these names are printed as headers in the first line. Otherwise, only the numbers are printed.
So, this is the function:
mat_op_print <- function(..., width = 0) {
# get arguments
args <- list(...)
chars <- sapply(args, is.character)
# auxilliary function to create character of n spaces
spaces <- function(n) paste(rep(" ", n), collapse = "")
# convert vectors to row matrix
vecs <- sapply(args, is.vector)
args[vecs & !chars] <- lapply(args[vecs & !chars], function(v) matrix(v, ncol = 1))
# convert all non-characters to character with format
args[!chars] <- lapply(args[!chars], format, width = width)
# print names as the first line, if present
arg_names <- names(args)
if (!is.null(arg_names)) {
get_title <- function(x, name) {
if (is.matrix(x)) {
paste0(name, spaces(sum(nchar(x[1, ])) + ncol(x) - 1 - nchar(name)))
} else {
spaces(nchar(x))
}
}
cat(mapply(get_title, args, arg_names), "\n")
}
# auxiliary function to create the lines
get_line <- function(x, n) {
if (is.matrix(x)) {
if (nrow(x) < n) {
spaces(sum(nchar(x[1, ])) + ncol(x) - 1)
} else {
paste(x[n, ], collapse = " ")
}
} else if (n == 1) {
x
} else {
spaces(nchar(x))
}
}
# print as many lines as needed for the matrix with most rows
N <- max(sapply(args[!chars], nrow))
for (n in 1:N) {
cat(sapply(args, get_line, n), "\n")
}
}
And this is an example of how it works:
A = matrix(c(0.5, 1, 3, 0.75, 2.8, 4), nrow = 2)
x = c(0.5, 3.7, 2.3)
y = c(0.7, -1.2)
b = A %*% x - y
mat_op_print(A = A, " * ", x = x, " - ", y = y, " = ", b = b, width = 6)
## A x y b
## 0.50 3.00 2.80 * 0.5 - 0.7 = 17.090
## 1.00 0.75 4.00 3.7 -1.2 13.675
## 2.3
Also printing the slices of a 3-dimensional array side-by-side is possible:
A <- array(1:12, dim = c(2, 2, 3))
mat_op_print(A1 = A[, , 1], " | ", A2 = A[, , 2], " | ", A3 = A[, , 3])
## A1 A2 A3
## 1 3 | 5 7 | 9 11
## 2 4 6 8 10 12
Here is my code:
Step1: Define a inverse function which I will use later
inverse = function (f, lower = -100, upper = 100) {
function (y) uniroot((function (x) f(x) - y), lower = lower, upper = upper)[1]
}
Step2: Here is my functions and their inverse:
F1<-function(x,m1,l,s1,s2){l*pnorm((x-m1)/s1)+(1-l)*pnorm((x+m1)/s2)}
F1_inverse = inverse(function(x) F1(x,1,0.1,2,1) , -100, 100)
F2<-function(x,m2,l,s1,s2){l*pnorm((x-m2)/s1)+(1-l)*pnorm((x+m2)/s2)}
F2_inverse = inverse(function(x) F1(x,1,0.1,2,1) , -100, 100)
Step3: Here is my final function which combines the above functions (I am sure the function is correct):
copwnorm<-function(x,y,l,mu1,mu2,sd1,sd2) {
(l*dnorm(((F1_inverse(pnorm(x))$root-mu1)/sd1))*
dnorm(((F2_inverse(pnorm(y))$root-mu2)/sd1)))
}
Step4: I want to create a contour plot for the function in Stepenter code here3:
x<-seq(-2,2,0.1)
y<-seq(-2,2,0.1)
z<-outer(x,y,copwnorm)
contour(x,y,z,xlab="x",ylab="y",nlevels=15)
Here is the problem comes in, when I tried to apply function outer(x,y,copwnorm), it gives me an error:invalid function value in 'zeroin'. May I ask how to solve this problem?
I believe it is a very commom misconception to assume that outer(x, y, FUN) calls the function parameter (FUN) once for each required pair x[i] and y[j]. Actually, outer calls FUN only once, after creating all possible pairs, combining every element of x with every element of y, in a manner similar to the function expand.grid.
I'll show that with an example: consider this function, which is a wrapper for the product and print a message every time it's called:
f <- function(x,y)
{
cat("f called with arguments: x =", capture.output(dput(x)), "y =", capture.output(dput(y)), "\n")
x*y
}
This function is "naturally" vectorized, so we can call it with vector arguments:
> f(c(1,2), c(3,4))
f called with arguments: x = c(1, 2) y = c(3, 4)
[1] 3 8
Using outer:
> outer(c(1,2), c(3,4), f)
f called with arguments: x = c(1, 2, 1, 2) y = c(3, 3, 4, 4)
[,1] [,2]
[1,] 3 4
[2,] 6 8
Notice the combinations generated.
If we can't guarantee that the function can handle vector arguments, there is a simple trick to ensure the function gets called only once for each pair in the combinations: Vectorize. This creates another function that calls the original function once for each element in the arguments:
> Vectorize(f)(c(1,2),c(3,4))
f called with arguments: x = 1 y = 3
f called with arguments: x = 2 y = 4
[1] 3 8
So we can make a "safe" outer with it:
> outer(c(1,2), c(3,4), Vectorize(f))
f called with arguments: x = 1 y = 3
f called with arguments: x = 2 y = 3
f called with arguments: x = 1 y = 4
f called with arguments: x = 2 y = 4
[,1] [,2]
[1,] 3 4
[2,] 6 8
In this case, the results are the same because f was written in a vectorized way, i.e., because "*" is vectorized. But if your function is not written with this in mind, using it directly in outer may fail or (worse) may give wrong results.