I have quite simple question yet I cannot seem to solve it.
I'm trying to find a parameter with optim() r function.
Here is the case:
library(rootSolve)
d <- read.table(text="indx rate n d
1 0.12 158 14
2 0.095 135 9
3 0.057 123 4
4 0.033 115 5
5 0.019 90 4", header=T)
d$real <- with(d, d/n)
opt <- d[ ,c("rate","real", "n")]
# this is close to the correct solution!
scaler <- apply(opt, 1, function(z) uniroot.all(
function(alpha) z[2] - (1 / (1 + alpha * ( (1 - z[1]) / z[1] )) ), interval = c(0,10)))
# check for solution (not fully correct!)
round(crossprod(scaler * opt$real, opt$n)/sum(opt$n), 3) == round(crossprod(round(opt$rate, 3), opt$n)/sum(opt$n), 3)
# using optim() - completely wrong results
infun <- function(data, alpha){ l <- with(data,
( rate - (1 / ( 1 + alpha[1] * ( (1 - real)/real ))) )); return( -sum( l ) ) }
opt_out <- optim(c(0,0), infun, data=opt, method = "BFGS", hessian = TRUE)
with(opt, (1 / ( 1 + opt_out$par[1] * ( (1 - real)/real ))))
You are trying, with your code, to get an unique alpha for all, but you want to have five values ..
So, you are leaded to make a sum .. but if you have negative and positive values, your sum could go near zero even with individual terms far from 0 ..
Moreover, your infun function is not in accordance with your previous function ..
What you can do is something like that :
infun <- function(alpha){ l <- with(cbind(d, alpha), ( real - (1 / ( 1 +
alpha * ( (1 - rate)/rate ))) )); return( sum(abs(l)) ) }
param <- c(5,5,5,5,5)
opt_out <- optim(par = scaler, infun, method = "BFGS", hessian = TRUE)
And in order to check the result you should have written :
with( cbind(opt,opt_out$par), real -1 / ( 1 + opt_out$par * ( (1 - rate)/rate )))
To get the true solution, you can do (after a very litle mathematics on a paper) :
sol <- -((opt[,2]-1)/(opt[,2]))*(opt[,1]/(1-opt[,1]))
and test it :
with( cbind(opt,sol), real -1 / ( 1 + opt_out$par * ( (1 - rate)/rate )))
Related
fellow programmers. I'm studying a book on numerical solutions for economics (Judd 1998). I'm trying to reproduce a problem from that same book in R so I can use the optim package to see if I can get similar results.
The problem established by the author is this one: and his results were these.
I have tried to transcribe this problem to R, which resulted in this code chunk:
DisutilityJudd <- function(L){
if(L == 0){
return(0)
}else{
return(0.1)
}
}
AgentUtilityJudd <- function(w, L){
(-exp(-2*w) + 1) - DisutilityJudd(L)
}
reservation.utility.judd <- AgentUtilityJudd(1, 1)
MaxEffortUtility <- function(w1, w2, L = 1){
0.8 * AgentUtilityJudd(w1, L) + 0.2 * AgentUtilityJudd(w2, L)
}
LeastEffortUtility <- function(w1, w2, L = 0){
0.4 * AgentUtilityJudd(w1, L) + 0.6 * AgentUtilityJudd(w2, L)
}
UtilityDifferenceJudd <- function(w1, w2){
MaxEffortUtility(w1, w2) - LeastEffortUtility(w1, w2)
}
PenaltyFunctionJudd <- function(w1, w2, P = 100000){
if(length(w1) == 2){
y <- -1 * (0.8 * (2 - w1[1]) - 0.2 * w1[2] - P *
(pmax(0, -MaxEffortUtility(w1[1], w1[1]) - reservation.utility.judd))^2 -
P * (pmax(0, -UtilityDifferenceJudd(w1[1], w1[1])))^2)
}else{
y <- -1 * (0.8 * (2 - w1) - 0.2 * w2 - P *
(pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd))^2 -
P * (pmax(0, -UtilityDifferenceJudd(w1, w2)))^2)
}
return(y)
}
There were no errors, but the results generated by my code were nowhere near to what I was expecting:
optim(c(1.1, 0.5), PenaltyFunctionJudd)
$par
[1] 1.343909e+49 -2.370681e+51
$value
[1] -4.633849e+50
$counts
function gradient
501 NA
$convergence
[1] 1
$message
NULL
Perhaps there is a problem to my penalty function. I'm assuming that it is due to the pmax function. Could somebody help me identify it? Thank you, I appreciate your attention.
Edit: a typo.
I believe you meant w1[2] in when if(length(w1) == 2) is true.
I have modified your code, without touching how you define the previous function. It is not clear if it the result expected : what does IV(-1) mean, is it the result minus 1 ? a power if 10 ?
PenaltyFunctionJudd <- function(w1, w2, P = 1e5){
if(length(w1) > 1){
w2 <- w1[2]
w1 <- w1[1]
}
# cat("length is 2 \n")
y <- 0.8 * (2 - w1) - 0.2 * w2 - P *
( pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd) )^2 -
P * ( pmax(0, -UtilityDifferenceJudd(w1, w2)) )^2
# cat("pmax1 :", pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd), "\n")
# cat("pmax2 :", pmax(0, -UtilityDifferenceJudd(w1, w2)), "\n")
return(y)
}
optim(c(1.1, 0.5), PenaltyFunctionJudd, control = list(fnscale = -1) )
optim(c(11, 5), PenaltyFunctionJudd, method = "BFGS", control = list(fnscale = -1, maxit = 100) )
You can use cat or print to check your values (here I noticed some Inf and 0 the leaded me to notice code error).
Friendly warning : provided you defined correctly the previous function, there is lot of instability in optimisation (problem badly set ? More penalty needed ?). Indeed when running twice or more the algorithm parameters fluctuate a lot...
I have two equations. They are as follows:
( 1 - 0.25 ^ {1/alpha} ) * lambda = 85
( 1 - 0.75 ^ {1/alpha} ) * lambda = 11
I would like to compute the values of alpha and lambda by solving the above two equations. How do I do this using R?
One approach is to translate it into an optimization problem by introducing an loss function:
loss <- function(X) {
L = X[1]
a = X[2]
return(sum(c(
(1 - 0.25^(1/a))*L - 85,
(1 - 0.75^(1/a))*L - 11
)^2))
}
nlm(loss, c(-1,-1))
If the result returned from nlm() has a minimum near zero, then estimate will be a vector containing lambda and alpha. When I tried this, I got an answer that passed the sniff test:
> a = -1.28799
> L = -43.95321
> (1 - 0.25^(1/a))*L
[1] 84.99999
> (1 - 0.75^(1/a))*L
[1] 11.00005
#olooney's answer is best.
Another way to solve these equations is to use uniroot function. We can cancel the lambda values and can use the uniroot to find the value of alpha. Then substitute back to find lambda.
f <- function(x) {
(11/85) - ((1 - (0.75) ^ (1/x)) / (1 - (0.25) ^ (1/x)) )
}
f_alpha <- uniroot(f, lower = -10, upper = -1, extendInt = "yes")
f_lambda <- function(x) {
11 - ((1 - (0.75) ^ (1/f_alpha$root)) * x)
}
lambda = uniroot(f_lambda, lower = -10, upper = -2, extendInt = "yes")$root
sprintf("Alpha equals %f", f_alpha$root)
sprintf("Lambda equals %f", lambda)
results in
[1] "Alpha equals -1.287978"
[1] "Lambda equals -43.952544"
I have problems with the coding of a function to optimize in which there are two summations and one production, all with different indexing. I split the code into two functions for simplicity.
In the first function j goes from 0 to k:
w = function(n,k,gam){
j = 0:k
w = (1 / factorial(k)) * n * sum(choose(k, j * gam))
return(w)}
In the second function k goes from 0 to n (that is fixed to 10); instead the production goes from 1 to length(x):
f = function(gam,del){
x = mydata #vector of 500 elements
n = 10
k = 0:10
for (i in 0:10)
pdf = prod( sum( w(n, k[i], gam) * (1 / del + (n/x)^(n+1))
return(-pdf)}
When I try the function I obtain the following error:
Error in 0:k : argument of length 0
Edit: This is what I am tryig to code
where I want to maximize L(d,g) using optim and:
and n is fixed to a specific value.
Solution
Change for (i in 0:10) to for ( i in 1:11 ). Note: When I copied and ran your code I also noticed some unrelated bracket/parentheses omissions you may need to fix also.
Explanation
Your problem is that R uses a 1-based indexing system rather than a 0-based one like many other programming languages or some mathematical formulae. If you run the following code you'll get the same error, and it pinpoints the problem:
k = 0:10
for ( i in 0:10 ) {
print(0:k[i])
}
Error in 0:k[i] : argument of length 0
You get an error on the first iteration because there is no 0 element of k. Compare that to the following loop:
k = 0:10
for ( i in 1:11 ) {
print(0:k[i])
}
[1] 0
[1] 0 1
[1] 0 1 2
[1] 0 1 2 3
[1] 0 1 2 3 4
[1] 0 1 2 3 4 5
[1] 0 1 2 3 4 5 6
[1] 0 1 2 3 4 5 6 7
[1] 0 1 2 3 4 5 6 7 8
[1] 0 1 2 3 4 5 6 7 8 9
[1] 0 1 2 3 4 5 6 7 8 9 10
Update
Your comment to the answer clarifies some additional information you need:
Just to full understand everything, how do I know in a situation like
this that R is indexing the production on x and the summation on k?
The short answer is that it depends on how you nest your loops and function calls. In more detail:
When you call f(), you start a for loop over the elements of k, so R is indexing the block of code within the for loop (everything in the braces in my re-formatted version of f() below) "on" k. For every element in k, you assign prod(...) to pdf (Side note: I don't know why you're re-writing over pdf in every iteration of this loop)
sum( w(n, k[i], gam) * gamma(1 / del + k[i]) * s^(n + 1)) produces a vector of length max(length(w(n, k[i], gam)), length(s)) (side note: Beware of recycling! -- see Section 2.2 of "An Introduction to R"); prod(sum( w(n, k[i], gam) * gamma(1 / del + k[i]) * s^(n + 1))) effectively indexes over the elements of that vector
w(n, k[i], gam) * gamma(1 / del + k[i]) * s^(n + 1) produces a vector of length max(length(w(n, k[i], gam)), length(s)); sum( w(n, k[i], gam) * gamma(1 / del + k[i]) * s^(n + 1)) effectively indexes over the elements of that vector
Etc.
What you're indexing over, explicitly or implicitly through vectorized operations, depends on which level of nested loops or function calls you're talking about. You may need some careful thinking and planning about when you want to index over what, which will tell you how you need to nest things. Put the operation whose indices should vary fastest on the innermost call. For example, in effect, prod(1:3 + sum(1:3)) will index over sum(1:3) to produce that sum first then index over 1:3 + sum(1:3) to produce the product. I.e., sum(1:3) = 1 + 2 + 3 = 6, then prod(1:3 + sum(1:3)) = (1 + 6) * (2 + 6) * (3 + 6) = 7 * 8 * 9 = 504. It's just like how parentheses work in mathematics.
Also, another side note, I wouldn't refer to global variables from within a function as you do in f() -- I've highlighted below in your code where you do that and offered an alternative that doesn't do it.
f = function(gam, del){
x = mydata # don't refer to a global variable "mydata", make it an argument
n = 10
s = n / x
k = 1:11
for (i in 1:11){
pdf = prod( sum( w(n, k[i], gam) * gamma(1 / del + k[i]) * s^(n + 1)))
}
return(-pdf)
}
# Do this instead
# (though there are still other things to fix,
# like re-writing over "pdf" eleven times and only using the last value)
f = function(gam, del, x, n = 10) {
s = n / x
s = n / x
k = 0:10
for (i in 1:11){
pdf = prod( sum( w(n, k[i], gam) * gamma(1 / del + k[i]) * s^(n + 1)))
}
return(-pdf)
}
Since it's a short question I'll leave out regular background information (if you need, I'll add it).
Finally there is a data frame called Coefficients
Serial_number Fixed_effects_beta_0 Fixed_effects_beta_1 Fixed_effects_beta_2 Fixed_effects_beta_3 Random_effects_beta_0 Random_effects_beta_1 Random_effects_beta_2 Random_effects_beta_3 p0_fixed p1_fixed p2_fixed p3_fixed p0_random p1_random p2_random p3_random Fitted_Voltage
1 912009913 1.238401 13.19572 -0.08379988 1.366747 -0.039642999 -0.40767221 -0.25476169 -0.11315457 -11.92334 0.1177605 -0.0003777831 4.328852e-07 0.56414753 -0.006946270 2.736287e-05 -3.583906e-08 352.9476
(...)
and for each row I want to apply the function
inverse = function (f, lower = lower_limit, upper = 450) {
function (y) uniroot((function (x) f(x) - y), lower = lower_limit, upper = upper)[1]
# function (y) polyroot((function (x) f(x) - y), lower = lower_limit, upper = upper)[1]
}
function_to_observe = inverse((function(x=150)
exp(
exp(
sum(
Coefficients[running_row,"p0_fixed"] * x^0,
Coefficients[running_row,"p1_fixed"] * x^1,
Coefficients[running_row,"p2_fixed"] * x^2,
Coefficients[running_row,"p3_fixed"] * x^3
))
)
)
, 50, 450)
by making use of values stored in each row and in certain columns of the data frame as follows:
for(i in 1:nrow(Coefficients)){
Coefficients[i,"Fitted_Voltage"]<- function_to_observe(150)
}
Unfortunately this does not work since Coefficients[i,"Fitted_Voltage"]<- function_to_observe(150) does not take care of the different rows of Coefficients.
What's a remedy? Whyever I cannot do the following:
for(i in 1:nrow(Coefficients)){
Coefficients[i,"Fitted_Voltage"]<- inverse((function(x=150)
exp(
exp(
sum(
Coefficients[i,"p0_fixed"] * x^0,
Coefficients[i,"p1_fixed"] * x^1,
Coefficients[i,"p2_fixed"] * x^2,
Coefficients[i,"p3_fixed"] * x^3
))
)
)
, 50, 450)
}
This yields:
Error in x[[jj]][iseq] <- vjj :
incompatible types (from closure to double) in subassignment type fix
Thanks a lot in advance for any help!
# Update:
With the help of mathdotrandom I tried a bit and get the following:
lower_limit<- 0
function_to_observe<- inverse((function(x=150)
exp(
exp(
sum(
Coefficients[i,"p0_fixed"] * x^0,
Coefficients[i,"p1_fixed"] * x^1,
Coefficients[i,"p2_fixed"] * x^2,
Coefficients[i,"p3_fixed"] * x^3
))))
, 50, 550
)
inverse = function (f, lower = lower_limit, upper = 450) {
function (y) uniroot((function (x) f(x) - y), lower = lower_limit, upper = upper)[1]
}
for(i in 1:nrow(Coefficients)){
Coefficients[i, "Fitted_Voltage"]<- function_to_observe(150)
}
Coefficients["Fitted_Voltage"]
which yields reasonable values:
Fitted_Voltage
1 352.9476
2 352.9476
3 352.9476
4 352.9476
5 352.9476
6 352.9476
7 352.9476
8 352.9476
9 352.9476
10 352.9476
11 352.9476
12 352.9476
13 352.9476
14 352.9476
15 352.9476
Though I do not understand the syntax I guess this is correct since it does what it should.
function(x=150) does not run the function but sets x as a default parameter of 150. So you try to put a function definition into your data.frame. Thats why it complains about the type closure(function). Easiest is to give the function a name and define it outside of the for loop and then call it.
If you really want to use it as lambda function checkout this question and lebatsnok answer: lambda-like functions in R?
The inverse function should not return a function but a number. The uniroot function expects a function, so f should be a function as you did. R will actually lookup the value of i or running_row from above if you don't put it as a parameter.
Coefficients <- data.frame("Fitted_Voltage"=c(0,0), "p0_fixed"=c(10^-1, 10^-2),
"p1_fixed"=c(10^-2, 10^-3), "p2_fixed"=c(10^-3, 10^-4),
"p3_fixed"=c(10^-4, 10^-5))
f <- function(x=150)exp(exp(sum(Coefficients[running_row,"p0_fixed"] * x^0,
Coefficients[running_row,"p1_fixed"] * x^1,
Coefficients[running_row,"p2_fixed"] * x^2,
Coefficients[running_row,"p3_fixed"] * x^3)))
inverse = function (f, lower_limit, upper = 450) {
y = (f(lower_limit) + f(upper))/2
uniroot(function(x)(f(x)-y), lower = lower_limit, upper = upper)[1]
}
for(running_row in 1:nrow(Coefficients)){
Coefficients[i, "Fitted_Voltage"] <- inverse(f,-1,1)
}
But your function is always positive because you used exp and exp(x) >0 forall x, so uniroot can not find a zero of that function. Also polyroot can only find zeros of polynomials but you are using an exponentail function. Are you sure that your function should look like: e^(e^(c_0 + c_1*x + c_2*x^2 + c_3*x^3))?
I subtract a value in inverse to make it have a root but i dont know if this makes any sense in your context. Also because of double exponential the function gets big really fast, so even for small Coefficients it returns Infinity for lower limit 50 and upper 450, so i needed to do -1 and 1 as limits to get some results. But this should be somehow similar to how you want it.
Following mathdotrandom's suggestion. You can define function outside. Try this:
inner.f <- function(x=150, i){
exp(
exp(
sum(
Coefficients[i,"p0_fixed"] * x^0,
Coefficients[i,"p1_fixed"] * x^1,
Coefficients[i,"p2_fixed"] * x^2,
Coefficients[i,"p3_fixed"] * x^3
))
)
}
then (if you want x to be set to 150)
Coefficients[i,"Fitted_Voltage"]<- inverse(inner.f(150, i), 50, 450)
My apologies, for being unclear earlier. I now understand the function a bit more, but could use some assistance on a few aspects.
I would like to get back a relationship of conversion ( X ) versus volume ( V ), or the other way around would be fine as well. It would seem to me that the traditional "times" term is what I want to replace with an X sequence from 0 - 1, X is conversion remember so bounded by 0 and 1.0
Below, rw is the reaction rate, and is a function of the partial pressures at any given moment, which are described as P.w, P.x, P.y, and P.z which themselves are functions of the initial conditions (P.w0, v.0) and the conversion, again X.
Thank you in advance
rm(list = ls())
weight <- function( Vols, State, Pars ) {
with(as.list(c(State, Pars)), {
y = 1
delta = 2
ya.0 = 0.4
eps = ya.0 * delta
temp = 800
R = 8.314
k.2 = exp( (35000 / ( R*temp )) - 7.912 )
K.3 = exp( 4.084 / temp - 4.33 )
P.w <- P.w0 * ( 1 - X ) * y / ( 1 + eps * X )
P.x <- P.w0 * ( 1 - 2*X ) * y / ( 1 + eps * X )
P.y <- P.w0 * ( 1 + X ) * y / ( 1 + eps * X )
P.z <- P.w0 * ( 1 + 4*X ) * y / ( 1 + eps * X )
r.w <- k.2 * ( K.3 * P.w * P.x ^ 2 - P.y * P.z^4 )
F.w0 <- P.w0 * v.0 / ( R * temp )
dX.dq <- r.w / F.w0
res <- dX.dq
return(list(res))
})
}
pars <- c( y = 1,
P.w0 = 23,
v.0 = 120 )
yini <- c( X = 0 )
vols <- seq( 0 , 100 , by = 1 )
out <- ode( yini , vols , weight , pars )
Just running
vol.func(0,0,params)
i.e., evaluating the gradient at the initial conditions, gives NaN. The proper way to diagnose this is to divide your complex gradient expressions up into separate terms and see which one is causing trouble. I'm not going to go through this in detail, but as #Sixiang.Hu points out in comments above, you're dividing by V in your gradient function, which will cause infinite values if the numerator is finite or NaN values if the numerator is zero ...
More generally, it's not clear whether you understand that the first argument to the gradient function (your vol.func) is supposed to be the current time, not a value of the state variable. Perhaps V is supposed to be your state variable, and X should be a parameter ...?