I want to discount a number of cashflows and find the ''fair'' interest rate of a financial instrument. That is, I want to set the interest rate in such a way that
$$P=\sum_i^T e^{-ri}c_i$$, where P is some value. As a toy example, I came up with this:
value <- c(1,2,3,4,5,6,7,8,9,10)
discounted_value <- c()
for(i in 1:10){
discounted_value[i] <- value[i]*exp(-r*i)
}
should_be_equal_to <- 50
I want to find a r such that the sum of the vector of discounted_values is equal to 50 (should_be_equal_to). Does anyone have an idea how to solve this? I prefer not to use a number of manual grids for r.
It's like a least square problem. You define a function that calculates the difference between the sum of your predicted value for a given r :
fn <- function(value,r) {
delta = 50 - sum(value*exp(-r*seq_along(value)))
abs(delta)
}
Then you optimize this function, providing boundaries:
optim(par = 0.5,fn=fn, value=value,method="Brent",lower=0,upper=1)
$par
[1] 0.01369665
$value
[1] 2.240363e-07
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
And you can try the optimized parameter:
r = 0.01369665
discounted_value = value*exp(-r*seq_along(value))
sum(discounted_value)
[1] 50
Related
I am working with the R programming language.
I defined the following function:
f1 <- function(x) {
i <<- i+1
vals[[i]] <<- x
final_value = x[1]^2 + x[2]^2
}
and then optimized this function:
i <- 0
vals <- list()
res <- optim(c(1,1), f1, method="CG")
I am trying to understand the outputs of the "optim" (https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/optim) function:
$par
[1] -4.103643e-07 -4.103643e-07
$value
[1] 3.367978e-13
$counts
function gradient
26 11
$convergence
[1] 0
$message
NULL
In particular, I am trying to understand the "count" arguments. Reading the documentation, the following explanation is given:
counts:
A two-element integer vector giving the number of calls to fn and gr respectively. This excludes those calls needed to compute the Hessian, if requested, and any calls to fn to compute a finite-difference approximation to the gradient.
I would have thought that "counts" would refer to the number of iterations it took for the function to be optimized. But when I look at the number of iterations, the total number of iterations does not match the output of "counts":
> vals
[[1]]
[1] 1 1
[[2]]
[1] 1.001 1.000
[[3]]
[1] 0.999 1.000
[[4]]
[1] 1.000 1.001
....
[[68]]
[1] -1.000410e-03 -4.103643e-07
[[69]]
[1] -4.103643e-07 9.995896e-04
[[70]]
[1] -4.103643e-07 -1.000410e-03
For instance, it appears that 70 iterations were used to optimize this function, but the "counts" argument suggests that 26 iterations were used.
Can someone please help me understand what "counts" is referring to and what is the difference between 70 and 26 in this question?
Thanks!
As the documentation states, the function optims does not count all function calls. If the function was called e.g. to compute the Hessian derivative, or an approximation steps, vals will get one more value, but res$counts[["function"]] won't thus this value is smaller (26) compared to the total number of function calls (70). The function you want to optimize is very simple, so there aren't many iterations needed and most calls (70-26) is just administration overhead. The higher the difference, the less fraction of the time you spent on the main part (the actual optimization).
I want to transform my excel solver model into a model in R. I need to find 3 sets of coordinates which minimizes the distance to the 5 other given coordinates. I've made a program which calculates a distance matrix which outputs the minimal distance from each input to the given coordinates. I want to minimize this function by changing the input. Id est, I want to find the coordinates such that the sum of minimal distances are minimized. I tried several methods to do so, see the code below (Yes my distance matrix function might be somewhat cluncky, but this is because I had to reduce the input to 1 variable in order to run some algorithms such as nloprt (would get warnings otherwise). I've also seen some other questions (such as GRG Non-Linear Least Squares (Optimization)) but they did not change/improve the solution.
# First half of p describes x coordinates, second half the y coordinates # yes thats cluncky
p<-c(2,4,6,5,3,2) # initial points
x_given <- c(2,2.5,4,4,5)
y_given <- c(9,5,7,1,2)
f <- function(Coordinates){
# Predining
Term_1 <- NULL
Term_2 <- NULL
x <- NULL
Distance <- NULL
min_prob <- NULL
l <- length(Coordinates)
l2 <- length(x_given)
half_length <- l/2
s <- l2*half_length
Distance_Matrix <- matrix(c(rep(1,s)), nrow=half_length)
# Creating the distance matrix
for (k in 1:half_length){
for (i in 1:l2){
Term_1[i] <- (Coordinates[k]-x_given[i])^2
Term_2[i] <- (Coordinates[k+half_length]-y_given[i])^2
Distance[i] <- sqrt(Term_1[i]+Term_2[i])
Distance_Matrix[k,i] <- Distance[i]
}
}
d <- Distance_Matrix
# Find the minimum in each row, thats what we want to obtain ánd minimize
for (l in 1:nrow(d)){
min_prob[l] <- min(d[l,])
}
som<-sum(min_prob)
return(som)
}
# Minimise
sol<-optim(p,f)
x<-sol$par[1:3]
y<-sol$par[4:6]
plot(x_given,y_given)
points(x,y,pch=19)
The solution however is clearly not that optimal. I've tried to use the nloptr function, but I'm not sure which algorithm to use. Which algorithm can I use or can I use/program another function which solves this problem? Thanks in advance (and sorry for the detailed long question)
Look at the output of optim. It reached the iteration limit and had not yet converged.
> optim(p, f)
$`par`
[1] 2.501441 5.002441 5.003209 5.001237 1.995857 2.000265
$value
[1] 0.009927249
$counts
function gradient
501 NA
$convergence
[1] 1
$message
NULL
Although the result is not that different you will need to increase the number of iterations to get convergence. If that is still unacceptable then try different starting values.
> optim(p, f, control = list(maxit = 1000))
$`par`
[1] 2.502806 4.999866 5.000000 5.003009 1.999112 2.000000
$value
[1] 0.005012449
$counts
function gradient
755 NA
$convergence
[1] 0
$message
NULL
I'm trying to reproduce this vector (time series) calculation code:
gamma.parameters<- fitdistr(may_baseline_3months[may_baseline_3months>0],"gamma")
into a raster calculation code.
What this code originally does is trying to fit a gamma distribution by maximum likelihood estimation to a vector (time series) may_baseline_3months.
And what I want to do is to calculate the same thing but with a raster stack.
I tried doing this with calc() function:
f1<-function(x)
{
library(MASS)
return(fitdistr(x,"gamma"))
}
gamma.parameters<- calc(x = may_baseline_3months,fun = f1)
Error in .calcTest(x[1:5], fun, na.rm, forcefun, forceapply) :
cannot use this function
but it didn't work.
Note: My raster stack has only 4 layer.
EDIT
You can download a example data here spi
The fitdistr is part of the procedure of my main goal. I'm trying to calcule the Standard Precipitation Index. I already did it with a time series of a monthly precipitation of 30 year.
Here is the code for a time series till the line that I'm stock:
data<-read.csv("guatemala_spi.csv",header = T,sep=";")
dates<-data[,1]
rain_1month<-data[,2]
rain_3months<-0
#Setting the first 2 elements to NA because I'm going to calcule the accumulating the rainfall for 3 month
for (i in c(1:2)) {
rain_3months[i]<-NA
}
#Accumulating the rainfall for the rest of the data
number_of_months<-length(rain_1month)
for (j in c(3:number_of_months))
{
rain_3months[j]<-0.0
for (i in c(0:2))
{
rain_3months[j] = rain_3months[j] + rain_1month[j-i]
}
}
#Extracting a time-series for the month of interest (May)
may_rain_3months<-rain_3months[substr(dates,5,6)==”05”]
dates_may<-dates[substr(dates,5,6)==”05”]
number_of_years<-length(dates_may)
#Fitting the gama distribution by maximum likelihood estimation
start_year<-1971
end_year<-2010
start_index<-which(substr(dates_may,1,4)==start_year)
end_index<-which(substr(dates_may,1,4)==end_year)
may_baseline_3months<-may_rain_3months[start_index:end_index]
library(MASS)
gamma.parameters<-fitdistr(may_baseline_3months[may_baseline_3months>0],"gamma")
That last line is the one that I'm having problems to calculate for a raster stack.
Here's what I have so far in raster form:
Example multi-layer raster here (Monthly precipitation 2001 to 2004, 48 layers in total)
#Initiating a dates vector
dates<-c("200101","200102","200103","200104","200105","200106","200107","200108","200109","200110","200111","200112",
"200201","200202","200203","200204","200205","200206","200207","200208","200209","200210","200211","200212",
"200301","200302","200303","200304","200305","200306","200307","200308","200309","200310","200311","200312",
"200401","200402","200403","200404","200405","200406","200407","200408","200409","200410","200411","200412")
#Initiating a NA raster
rain_3months_1layer<-raster(nrow=1600, ncol=1673,extent(-118.4539, -34.80395, -50, 30),res=c(0.05,0.05))
values(rain_3months_1layer)<-NA
#Creating a raster stack NA of 48 layers
rain_3months<-stack(mget(rep( "rain_3months_1layer" , 48 )))
#Reading the data
rain_1month <- stack("chirps_rain_1month.tif")
#Accumulating the rainfall
number_of_months<-nlayers(rain_1month)
for (j in c(3:number_of_months))
{
rain_3months[[j]]<-0.0
for (i in c(0:2))
{
rain_3months[[j]] = rain_3months[[j]] + rain_1month[[j-i]]
}
}
#Extracting the raster for the month of interest (May)
may_rain_3months<-stack(rain_3months[[which(substr(dates,5,6)=="05", arr.ind = T)]])
dates_may<-dates[substr(dates,5,6)=="05"]
number_of_years<-length(dates_may)
#Fitting the gama distribution by maximum likelihood estimation
start_year<-2001
end_year<-2004
start_index<-which(substr(dates_may,1,4)==start_year)
end_index<-which(substr(dates_may,1,4)==end_year)
may_baseline_3months<-stack(may_rain_3months[[start_index:end_index]])
library(MASS)
f1<-function(x)
{
library(MASS)
return(fitdistr(x,"gamma"))
}
gamma.parameters<- calc(x = may_baseline_3months,fun = f1)
I can't make calc() to compute fitdistr() to the raster stack.
You need to make a function that calc can use. Your function f1 returns an object of class fitdistr. The calc function does not know what to do with that:
library(MASS)
set.seed(0)
x <- runif(10)
f1 <- function(x) {
return(fitdistr(x,"gamma"))
}
a <- f1(x)
class(a)
# [1] "fitdistr"
a
# shape rate
# 4.401575 6.931571
# (1.898550) (3.167113)
You need a function that returns numbers. Like f2:
f2 <- function(x) {
fitdistr(x,"gamma")$estimate
}
b <- f2(x)
class(b)
#[1] "numeric"
b
# shape rate
#4.401575 6.931571
Test f2 with calc:
library(raster)
s <- stack(lapply(1:12, function(i) setValues(r, runif(ncell(r)))))
r <- calc(s, f2)
I assume that this answers your questions. I cannot be sure because your question is way too complex. The first thing you need to do with a problems like this is to create a simple example like I have done above.
Next question
Error in stats::optim(x = c(7, 7, 7, 7), par = list(shape = Inf, rate
= Inf), : non-finite value supplied by optim.
That is a different issue, you are providing fitdistr with values it cannot deal with. You can add a try clause to skip over those. You could identify which cells this happens in and what the values are to see if there is something else you should do.
f3 <- function(x) {
x <- try (fitdistr(x,"gamma")$estimate, silent=TRUE )
if (class(x) == 'try-error') { c(-9999, -9999) } else { x }
}
x[1] <- NA
f2(x)
#Error in fitdistr(x, "gamma") : 'x' contains missing or infinite values
f3(x)
#[1] -9999 -9999
Note that you need to make sure that the number of values returned by f3 should always be the same. In this case two values. Here I use -9999 so that you can identify the cells. You can also use NA
I wrote a simple function for maximum likelihood and would like this function to give different result based on the different values of its parameters using for loop in R. That is my function include an expression based on for loop. My function works well and the result are saved in a list. Then, Since I have two different results, I would like to apply the optim function to my function based on each part of my function. For example,
ff <- function(x,mu=c(2,0.5),sd=c(0.2,0.3)){
out <- vector("list",2)
for (i in 1:2){
out[[i]] <- -sum(log(dnorm(x,mu[[i]],sd[[i]]))) ## here I have two different part of my funcitons wrap as one using for loop.
}
return(out)
}
set.seed(123)
x <- rnorm(10,2,0.5)
x
Then the result of my function is:
> ff(x)
[[1]]
[1] 25.33975
[[2]]
[1] 101.4637
Then, since my function has two different parts wrap as one using for loop, I would like to apply the optim function to this function based on each part of it. I tried many own methods and they did not work. Here is one of my tries:
op <- vector("list",2)
for(i in 1:2){
op <- optim(c(0.5,0.5),fn=ff[[i]],i=i)
}
That is, I want the optim function to evaluate my function at the first value of my argument i=1 and then evaluate the function for the second one i=2.
So my funcitons without the wrap is as follows:
ff_1 <- function(x,mu=c(2,0.5),sd=c(0.2,0.3)){
-sum(log(dnorm(x,mu[[1]],sd[[1]])))
return(out)
}
ff_2 <- function(x,mu=c(2,0.5),sd=c(0.2,0.3)){
-sum(log(dnorm(x,mu[[2]],sd[[2]])))
return(out)
}
and I then need to use two different optim functions for each functions.
I search many website and R help sites but I couldnot find a solution to this question.
Any help please?
Try this one, it's just the way of passing the arguments to optim, I suppose
# given data
set.seed(123)
x <- rnorm(10,2,0.5)
# use vector parOpt instead of specifying two; for convience
# with optim
ff <- function(x, parOpt){
out <- -sum(log(dnorm(x, parOpt[1], parOpt[2])))
return(out)
}
# parameters in mu,sd vectors arranged in list
params <- list(set1 = c(2, 0.2), set2 = c(0.5, 0.3))
# output list
out <- list()
for(i in 1:2){
# pass params (mu and sd) to optim, function ff and the data
# note, since function ff has x argument, specify that in optim
out[[i]] <- optim(par = params[[i]], fn=ff ,x=x)
}
Should give something like this:
[[1]]
[[1]]$par
[1] 2.0372546 0.4523918
[[1]]$value
[1] 6.257931
[[1]]$counts
function gradient
55 NA
[[1]]$convergence
[1] 0
[[1]]$message
NULL
[[2]]
[[2]]$par
[1] 2.037165 0.452433
[[2]]$value
[1] 6.257932
[[2]]$counts
function gradient
73 NA
[[2]]$convergence
[1] 0
[[2]]$message
NULL
Hope this helps.
As an alternative, you can find the same solution using the command fitdist of the fitdistrplus package:
library(fitdistrplus)
set.seed(123)
x <- rnorm(10,2,0.5)
mu.start <- c(2,0.5)
sd.start <- c(0.2,0.3)
op <- vector("list",2)
for(i in 1:2){
op[[i]] <- fitdist(x,"norm", start=c(mu.start[i],sd.start[i]))
}
op
The result is:
[[1]]
Fitting of the distribution ' norm ' by maximum likelihood
Parameters:
estimate Std. Error
1 2.0372546 0.1430588
2 0.4523918 0.1011464
[[2]]
Fitting of the distribution ' norm ' by maximum likelihood
Parameters:
estimate Std. Error
1 2.037165 0.1430719
2 0.452433 0.1011694
Here's my setup
obs1<-c(1,1,1)
obs2<-c(0,1,2)
obs3<-c(0,0,3)
absoluteError<-function(obs,x){
return(sum(abs(obs-x)))
}
Example:
> absoluteError(obs2,1)
[1] 2
For a random vector of observations, I'd like to find a minimizer, x, which minimizes the absolute error between the observation values and a vector of all x. For instance, clearly the argument that minimizes absoluteError(obs1,x) is x=1 because this results in an error of 0. How do I find a minimizer for a random vector of observations? I'd imagine this is a linear programming problem, but I've never implemented one in R before.
The median of obs is a minimizer for the absolute error. The following is a sketch of how one might try proving this:
Let the median of a set of n observations, obs, be m. Call the absolute error between obs and m f(obs,m).
Case n is odd:
Consider f(obs,m+delta) where delta is some non zero number. Suppose delta is positive - then there are (n-1)/2 +1 observations whose error is delta more than f(obs,m). The remaining (n-1)/2 observations' error is at most delta less than f(obs,m). So f(obs,m+delta)-f(obs,m)>=delta. (The same argument can be made if delta is negative.) So the median is the only minimizer in this case. Thus f(obs,m+delta)>f(obs,m) for any non zero delta so m is a minimizer for f.
Case n is even:
Basically the same logic as above, except in this case any number between the two inner most numbers in the set will be a minimizer.
I am not sure this answer is correct, and even if it is I am not sure this is what you want. Nevertheless, I am taking a stab at it.
I think you are talking about 'Least absolute deviations', a form of regression that differs from 'Least Squares'.
If so, I found this R code for solving Least absolute deviations regression:
fabs=function(beta0,x,y){
b0=beta0[1]
b1=beta0[2]
n=length(x)
llh=0
for(i in 1:n){
r2=(y[i]-b0-b1*x[i])
llh=llh + abs(r2)
}
llh
}
g=optim(c(1,1),fabs,x=x,y=y)
I found the code here:
http://www.stat.colostate.edu/~meyer/hw12ans.pdf
Assuming you are talking about Least absolute deviations, you might not be interested in the above code if you want a solution in R from scratch rather than a solution that uses optim.
The above code is for a regression line with an intercept and one slope. I modified the code as follows to handle a regression with just an intercept:
y <- c(1,1,1)
x <- 1:length(y)
fabs=function(beta0,x,y){
b0=beta0[1]
b1=0
n=length(x)
llh=0
for(i in 1:n){
r2=(y[i]-b0-b1*x[i])
llh=llh + abs(r2)
}
llh
}
# The commands to get the estimator
g = optim(c(1),fabs,x=x,y=y, method='Brent', lower = (min(y)-5), upper = (max(y)+5))
g
I was not familiar with (i.e., had not heard of) Least absolute deviations until tonight. So, hopefully my modifications are fairly reasonable.
With y <- c(1,1,1) the parameter estimate is 1 (which I think you said is the correct answer):
$par
[1] 1
$value
[1] 1.332268e-15
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
With y <- c(0,1,2) the parameter estimate is 1:
$par
[1] 1
$value
[1] 2
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
With y <- c(0,0,3) the parameter estimate is 0 (which you said is the correct answer):
$par
[1] 8.613159e-10
$value
[1] 3
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
If you want R code from scratch, there is additional R code in the file at the link above which might be helpful.
Alternatively, perhaps it might be possible to extract the relevant code from the source file.
Alternatively, perhaps someone else can provide the desired code (and correct any errors on my part) in the next 24 hours.
If you come up with code from scratch please post it as an answer as I would love to see it myself.
lad=function(x,y){
SAD = function(beta, x, y) {
return(sum(abs(y - (beta[1] + beta[2] * x))))
}
d=lm(y~x)
ans1 = optim(par=c(d$coefficients[1], d$coefficients[2]),method = "Nelder-Mead",fn=SAD, x=x, y=y)
coe=setNames(ans1$par,c("(Intercept)",substitute(x)))
fitted=setNames(ans1$par[1]+ans1$par[2]*x,c(1:length(x)))
res=setNames(y-fitted,c(1:length(x)))
results = list(coefficients=coe, fitted.values=fitted, residuals=res)
class(results)="lad"
return(results)
}