Matrix from matlab code into R code - r

The code in matlab is created to make a probability of ecosystem functioning out of loss of species in an ecosystem. Now, this code have to be translated into R. But I have problem to translate a matrix manipulation made in matlab.
In Matlab, this is the code that I have tried to translate into R code:
for j=1:N+1
multi_matrix4(:,j)=matrix(:,1);
end
In R, I have put this code within the for-loop:
+ multi.matrix4 <- matrix[,1,drop=FALSE]
+ multi.matrix4 <- multi.matrix4[,j,drop=FALSE]
+ class(multi.matrix4)
This is the message from R, that comes beneath the for-loop:
Error: subscript out of bounds
My question is:
How to use R for this kind of manipulation of matrices??????
The matlab-code without the last graphs is:
clear all
% No of permutations
sim=1000;
% Total No of ecosystem functions
N=3;
%Total dimensions
J=3;
% Total No of species in pool
total_species=4;
% No of species drawn from pool
species=4;
multi_matrix=zeros(total_species,N);
% "Threshold"
t=.5;
result=zeros(sim,J);
for i=1:sim
% %Uniformly increasing trait values
for j=1:N
matrix=rand(total_species,2);
matrix(:,1)=linspace(0,1,total_species);
matrix=sortrows(matrix,2);
multi_matrix4(:,j)=matrix(:,1);
end
%Complete covariance
matrix=rand(total_species,2);
matrix(:,1)=linspace(0,1,total_species);
matrix=sortrows(matrix,2);
for j=1:N+1
multi_matrix4(:,j)=matrix(:,1);
end
% Excess of high trait values
for j=1:N
matrix=rand(total_species,2);
X=1:total_species;X=X';
matrix(:,1)=1-exp(-0.02*X.^2);
matrix=sortrows(matrix,2);
multi_matrix4(:,j)=matrix(:,1);
end
% Deficiency of high trait values
for j=1:N
matrix=rand(total_species,2);
X=1:total_species;X=X';
% matrix(:,1)=exp((X./22.6).^3)-1;
matrix(:,1)=exp((X./13.55).^3)-1;
matrix=sortrows(matrix,2);
multi_matrix4(:,j)=matrix(:,1);
end
% Reading empirical data
warning off
% [NUMERIC,txt]=xlsread('Plant_6.xls','Sheet1');
Exp07_2 = [ 0 0.72 0.70 ; 1 1 0 ; 0.62 0 1 ; 0.36 0.69 0.61]
multi_matrix(1:total_species,1:N)=Exp07_2;
random=rand(1,N);
multi_matrix(total_species+1,1:N)=random;
multi_matrix2=sortrows(multi_matrix',total_species+1);
multi_matrix3=multi_matrix2';
multi_matrix4=multi_matrix3(1:total_species,:);
warning on
% adding a sorting column
random2=rand(total_species,1);
multi_matrix4(:,N+1)=random2;
sort_multi_matrix=sortrows(multi_matrix4,N+1);
% loop adding one function at a time
for j=1:J
loss_matrix=sort_multi_matrix(1:species,1:j);
max_value=loss_matrix>=t;
B=any(max_value',2);
C=all(B);
result(i,j)=sum(C);
end
end
% reporting
res=mean(result);
res'
The R-code looks like this:
rm()
#No of permutation
sims <- 1000;
#Total number of ecosystem functions
N <- 3
#Total dimensions
J <- 3
#Total number of species in pool
total.species <- 4
#No of species drawn from pool
species <- 4
multi.matrix <- matrix(0, nrow=total.species, ncol=N)
class(multi.matrix)
# $Threshold$
t <- .5;
# The results are to be put in a matrix
result <- matrix(0, nrow=sims, ncol=J)
for (i in 1 : sims)
{
#Uniformly increasing trait values
for (j in 1 : N)
{
matrix <- matrix(runif(total.species*2),total.species)
class(matrix)
matrix[,1] <- seq(0,1, len=total.species) # test 2
class(matrix)
matrix <- matrix[order(matrix( ,2)),]
class(matrix)
# multi.matrix4[,j,drop=FALSE] = matrix[,1,drop=FALSE]
multi.matrix4 <- matrix[,1,drop=FALSE]
multi.matrix4 <- multi.matrix4[,j,drop=FALSE]
class(multi.matrix4)
}
# Complete covariance
matrix <- matrix(runif(total.species*2),total.species)
class(matrix)
matrix[,1] <- seq(0, 1, len=total.species)
class(matrix)
matrix <- matrix[order(matrix( ,2)),]
class(matrix)
for (j in 1 : N + 1)
{multi.matrix4 <- matrix[,1,drop=FALSE]
multi.matrix4 <- multi.matrix4[,j,drop=FALSE]
class(multi.matrix4)
}
# Excess of high trait values
for (j in 1 : N)
{matrix <- matrix(runif(total.species*2),total.species)
class(matrix)
X <- 1 : total.species
X <- t(X)
matrix[,1] <- c(1 - exp(-0.02 %*% X^2)) # Hie... p. 8
matrix <- matrix[order(matrix( ,2)),]
# multi.matrix4[,j,drop=FALSE] <- matrix[,1,drop=FALSE]
# multi.matrix4[,j,drop=FALSE] <- matrix[,1]
multi.matrix4 <- matrix[,1,drop=FALSE]
multi.matrix4 <- multi.matrix4[,j,drop=FALSE]
class(multi.matrix4)
}
# Deficiency of high trait values
for (j in 1 : N)
{matrix <- matrix(runif(total.species*2),total.species)
class(matrix)
X <- 1 : total.species
X <- t(X)
# matrix[1:4,1] <- c(exp((X/22.6)^3)-1)
matrix[1:4,1] <- c(exp((X/13.55)^3)-1)
class(matrix)
matrix <- matrix[order(matrix( ,2))]
class(matrix)
# multi.matrix4[,j,drop=FALSE] <- matrix[,1,drop=FALSE]
# multi.matrix4[,j,drop=FALSE] <- matrix[,1]
# multi.matrix4[,j] <- matrix[,1,drop=FALSE]
# class(multi.matrix4)
multi.matrix4 <- matrix[,1,drop=FALSE]
multi.matrix4 <- multi.matrix4[,j,drop=FALSE]
class(multi.matrix4)
}
# Reading empirical data
Exp_07_2 <- file(description = "Exp_07_2", open = "r", blocking = TRUE, encoding = getOption("encoding"), raw = FALSE)
Exp_07_2 <- matrix(scan(Exp_07_2),nrow=4,byrow=TRUE)
read.matrix <- function(Exp_07_2){
as.matrix(read.table(Exp_07_2))
}
Exp_07_2
class(Exp_07_2)
multi.matrix <- matrix(c(Exp_07_2),ncol=3)
class(multi.matrix)
multi.matrix <- multi.matrix(1:total.species,1:N)
class(multi.matrix)
random <- runif(N)
multi.matrix2 <- t(multi.matrix)[order(t(multi.matrix)[,1], t(multi.matrix)[,2], t(multi.matrix)[,3], t(multi.matrix)[,4]),]
class(multi.matrix2)
multi.matrix3 <- t(multi.matrix2)
class(multi.matrix3)
multi.matrix4 <- multi.matrix3[1:total.species,,drop=FALSE]
class(multi.matrix4)
# Adding a sorting column
random2 <- runif(total.species,1)
random2 <- multi.matrix4[,N+1,drop=FALSE]
sort.multi.matrix <- multi.matrix4(order(multi.matrix4[,1], multi.matrix4[,2], multi.matrix4[,3],multi.matrix4[,4]),N+1,drop=FALSE)
# loop adding one function at a time
for (j in 1 : J)
{loss.matrix <- sort.multi.matrix[nrow=species,ncol=j,drop=FALSE]
class(loss.matrix)
max.value <- loss.matrix >= t
c(B) <- any(t(max.value),2)
c(C) <- all(c(B))
result(i,j) <- c(sum(C))
}
}
# Reporting
res <- mean(result)
res
t(res)

Though I don't have Matlab and R at hand i suspect this is what is causing the problem:
In R you try to assign to a location in the matrix that does not exist, result: it fails
In Matlab you tried to assign to a location in the matrix that did not exist, result: it forgives your strange choice, expands your matrix and succeeds.
Assuming this is the problem, the solution is simple:
When creating the matrix in R, make sure that it is big enough to
contain all the things you want to add to it later.
This is called initalization, and is in most cases best practice. Even in Matlab it is generally recommended to initialize your variables properly in advance where possible rather then let them grow as you go.

Related

R function writing - getting error: NaNs producedError in tsort[U + 1]only 0's may be mixed with negative subscripts

I am creating an R function that calculates a bootstrapped bias corrected and accelerated interval, (not using any pre-installed packages) My code seems to be working but am struggling actually writing the code for the lower and upper limits of the interval. Any suggestions would be helpful.
BCa <- function(stat,X,k,level=0.95,...){
if(!is.numeric(k)||k<=0){
stop("The number of bootstrap resamples 'k' must be a numeric value greater than 0")
}
t.star <- stat(X,...)
t.k <- rep(NA,k)
for(i in 1:k){
Xi <- sample(X,replace=TRUE)
t.k[i] <- stat(Xi,...)
}
z0 <- qnorm(mean(t.k<t.star))
n <- length(X)
t.minus.j <- rep(NA,n)
for(j in 1:n){
Xj <- X[-j]
t.minus.j[j]<- stat(Xj,...)
}
t.bar.minus <- mean(t.minus.j)
t.diff <- t.bar.minus - t.minus.j
a <- ((sum(t.diff^3))/(6*(t.diff^2)^3/2))
alpha <- 1-level
tsort <- sort(t.k, decreasing = FALSE)
L <- pnorm(z0 + ((z0+qnorm(alpha/2))/((1-a)*z0+qnorm(alpha/2))))
U <- qnorm(z0 + ((z0+qnorm(alpha/2))/((1-a)*z0+qnorm(alpha/2))))
if(!is.integer(L)){
L <- floor(L*(k+1))
}
if(!is.integer(U)){
U <- ceiling(U*(k+1))
}
lower.limit <- tsort[L]
upper.limit <- tsort[U+1]
return(list(t.star=t.star,ci=c(lower.limit,upper.limit)))
}

Portfolio Optimisation under weight constraints

With a lot of help from contributors to StackOverflow I have managed to put together a function to derive the weights of a 2-asset portfolio which maximises the Sharpe ratio. No short sales are allowed and the sum of weights add to 1. What I would like to do now is to constrain asset A to not being more or less than 10% from a user defined weight. As an example I would like to constrain the weight of asset A to be no less than 54% or more than 66% (i.e 60% +/- 10%). So on the below example I would end up with weights of (0.54,0.66) instead of the unsconstrained (0.243,0.7570) .I assume this can be done by tweaking bVect but I am not so sure how to go about it. Any help would be appreciated.
asset_A <- c(0.034320510,-0.001209628,0.031900161,0.023163947,-0.001872938,-0.010322489,0.006090395,-0.003270854,0.017778990,0.017204915)
asset_B <- c(0.047103261,0.055175057,0.021019816,0.020602347,0.007281368,-0.006547404,0.019155238,0.005494798,0.025429958,0.014929124)
require(quadprog)
HR_solve <- function(asset_A,asset_B) {
vol_A <- sd(asset_A)
vol_B <- sd(asset_B)
cor_AB <- cor(cbind(asset_A,asset_B),method="pearson")
ret_A_B <- as.matrix(c(mean(asset_A),mean(asset_B)))
vol_AB <- c(vol_A,vol_B)
covmat <- diag(as.vector(vol_AB))%*%cor_AB%*%diag(as.vector(vol_AB))
aMat <- cbind(rep(1,nrow(covmat)),diag(1,nrow(covmat)))
bVec <- c(1,0,0)
zeros <- array(0, dim = c(nrow(covmat),1))
minw <- solve.QP(covmat, zeros, aMat, bVec, meq = 1 ,factorized = FALSE)$solution
rp <- as.numeric(t(minw) %*% ret_A_B)
sp <- sqrt(t(minw) %*% covmat %*% minw)
wp <- t(matrix(minw))
sret <- sort(seq(t(minw) %*% ret_A_B,max(ret_A_B),length.out=100))
aMatt <- cbind(ret_A_B,aMat)
for (ri in sret[-1]){
bVect <- c(ri,bVec)
result <- tryCatch({solve.QP(covmat, zeros, aMatt, bVect, meq = 2,factorized = FALSE)},
warning = function(w){ return(NULL) } , error = function(w){ return(NULL)}, finally = {} )
if (!is.null(result)){
wp <- rbind(wp,as.vector(result$solution))
rp <-c(rp,t(as.vector(result$solution) %*% ret_A_B))
sp <- c(sp,sqrt(t(as.vector(result$solution)) %*% covmat %*% as.vector(result$solution))) }
}
HR_weights <- wp[which.max(rp/sp),]
as.matrix(HR_weights)
}
HR_solve(asset_A,asset_B)
[,1]
[1,] 0.2429662
[2,] 0.7570338
I think you should take a look at the link below.
http://economistatlarge.com/portfolio-theory/r-optimized-portfolio/r-code-graph-efficient-frontier
I think you'll learn a lot from that. I'll post the code here, in case the link gets shut down sometime in the future.
# Economist at Large
# Modern Portfolio Theory
# Use solve.QP to solve for efficient frontier
# Last Edited 5/3/13
# This file uses the solve.QP function in the quadprog package to solve for the
# efficient frontier.
# Since the efficient frontier is a parabolic function, we can find the solution
# that minimizes portfolio variance and then vary the risk premium to find
# points along the efficient frontier. Then simply find the portfolio with the
# largest Sharpe ratio (expected return / sd) to identify the most
# efficient portfolio
library(stockPortfolio) # Base package for retrieving returns
library(ggplot2) # Used to graph efficient frontier
library(reshape2) # Used to melt the data
library(quadprog) #Needed for solve.QP
# Create the portfolio using ETFs, incl. hypothetical non-efficient allocation
stocks <- c(
"VTSMX" = .0,
"SPY" = .20,
"EFA" = .10,
"IWM" = .10,
"VWO" = .30,
"LQD" = .20,
"HYG" = .10)
# Retrieve returns, from earliest start date possible (where all stocks have
# data) through most recent date
returns <- getReturns(names(stocks[-1]), freq="week") #Currently, drop index
#### Efficient Frontier function ####
eff.frontier <- function (returns, short="no", max.allocation=NULL,
risk.premium.up=.5, risk.increment=.005){
# return argument should be a m x n matrix with one column per security
# short argument is whether short-selling is allowed; default is no (short
# selling prohibited)max.allocation is the maximum % allowed for any one
# security (reduces concentration) risk.premium.up is the upper limit of the
# risk premium modeled (see for loop below) and risk.increment is the
# increment (by) value used in the for loop
covariance <- cov(returns)
print(covariance)
n <- ncol(covariance)
# Create initial Amat and bvec assuming only equality constraint
# (short-selling is allowed, no allocation constraints)
Amat <- matrix (1, nrow=n)
bvec <- 1
meq <- 1
# Then modify the Amat and bvec if short-selling is prohibited
if(short=="no"){
Amat <- cbind(1, diag(n))
bvec <- c(bvec, rep(0, n))
}
# And modify Amat and bvec if a max allocation (concentration) is specified
if(!is.null(max.allocation)){
if(max.allocation > 1 | max.allocation <0){
stop("max.allocation must be greater than 0 and less than 1")
}
if(max.allocation * n < 1){
stop("Need to set max.allocation higher; not enough assets to add to 1")
}
Amat <- cbind(Amat, -diag(n))
bvec <- c(bvec, rep(-max.allocation, n))
}
# Calculate the number of loops
loops <- risk.premium.up / risk.increment + 1
loop <- 1
# Initialize a matrix to contain allocation and statistics
# This is not necessary, but speeds up processing and uses less memory
eff <- matrix(nrow=loops, ncol=n+3)
# Now I need to give the matrix column names
colnames(eff) <- c(colnames(returns), "Std.Dev", "Exp.Return", "sharpe")
# Loop through the quadratic program solver
for (i in seq(from=0, to=risk.premium.up, by=risk.increment)){
dvec <- colMeans(returns) * i # This moves the solution along the EF
sol <- solve.QP(covariance, dvec=dvec, Amat=Amat, bvec=bvec, meq=meq)
eff[loop,"Std.Dev"] <- sqrt(sum(sol$solution*colSums((covariance*sol$solution))))
eff[loop,"Exp.Return"] <- as.numeric(sol$solution %*% colMeans(returns))
eff[loop,"sharpe"] <- eff[loop,"Exp.Return"] / eff[loop,"Std.Dev"]
eff[loop,1:n] <- sol$solution
loop <- loop+1
}
return(as.data.frame(eff))
}
# Run the eff.frontier function based on no short and 50% alloc. restrictions
eff <- eff.frontier(returns=returns$R, short="no", max.allocation=.50,
risk.premium.up=1, risk.increment=.001)
# Find the optimal portfolio
eff.optimal.point <- eff[eff$sharpe==max(eff$sharpe),]
# graph efficient frontier
# Start with color scheme
ealred <- "#7D110C"
ealtan <- "#CDC4B6"
eallighttan <- "#F7F6F0"
ealdark <- "#423C30"
ggplot(eff, aes(x=Std.Dev, y=Exp.Return)) + geom_point(alpha=.1, color=ealdark) +
geom_point(data=eff.optimal.point, aes(x=Std.Dev, y=Exp.Return, label=sharpe),
color=ealred, size=5) +
annotate(geom="text", x=eff.optimal.point$Std.Dev,
y=eff.optimal.point$Exp.Return,
label=paste("Risk: ",
round(eff.optimal.point$Std.Dev*100, digits=3),"\nReturn: ",
round(eff.optimal.point$Exp.Return*100, digits=4),"%\nSharpe: ",
round(eff.optimal.point$sharpe*100, digits=2), "%", sep=""),
hjust=0, vjust=1.2) +
ggtitle("Efficient Frontier\nand Optimal Portfolio") +
labs(x="Risk (standard deviation of portfolio)", y="Return") +
theme(panel.background=element_rect(fill=eallighttan),
text=element_text(color=ealdark),
plot.title=element_text(size=24, color=ealred))
ggsave("Efficient Frontier.png")
Ok I have found a way to do this... if you think there is a more elegant way please let me know...
require(quadprog)
HR_solve <- function(asset_A,asset_B,mean_A,range_A) {
vol_A <- sd(asset_A)
vol_B <- sd(asset_B)
cor_AB <- cor(cbind(asset_A,asset_B),method="pearson")
ret_A_B <- as.matrix(c(mean(asset_A),mean(asset_B)))
vol_AB <- c(vol_A,vol_B)
covmat <- diag(as.vector(vol_AB))%*%cor_AB%*%diag(as.vector(vol_AB))
bVec <- c(1,0,0)
aMat <- cbind(rep(1,nrow(covmat)),diag(1,nrow(covmat)))
zeros <- array(0, dim = c(nrow(covmat),1))
minw <- solve.QP(covmat, zeros, aMat, bVec, meq = 1 ,factorized = FALSE)$solution
rp <- as.numeric(t(minw) %*% ret_A_B)
sp <- sqrt(t(minw) %*% covmat %*% minw)
wp <- t(matrix(minw))
sret <- sort(seq(t(minw) %*% ret_A_B,max(ret_A_B),length.out=1000))
min_A <- mean_A * (1-range_A)
max_A <- mean_A * (1+range_A)
aMatt <- cbind(ret_A_B,aMat,-diag(2))
bVec <- c(1,min_A,0,-max_A,-1)
for (ri in sret[-1]){
bVect <- c(ri,bVec)
result <- tryCatch({solve.QP(covmat, zeros, aMatt, bVect, meq = 2,factorized = FALSE)},
warning = function(w){ return(NULL) } , error = function(w){ return(NULL)}, finally = {} )
if (!is.null(result)){
wp <- rbind(wp,as.vector(result$solution))
rp <-c(rp,t(as.vector(result$solution) %*% ret_A_B))
sp <- c(sp,sqrt(t(as.vector(result$solution)) %*% covmat %*% as.vector(result$solution))) }
}
HR_weights <- wp[which.max(rp/sp),]
as.matrix(HR_weights)
}
Just change aMat and bVec:
# sset A to be no less than 54% or more than 66%
aMat <- cbind(rep(1,nrow(covmat)),diag(1,nrow(covmat)),c(1,0),c(-1,0))
bVec <- c(1,0,0,.54,-.66)

Portfolio Optimization SOLVE.QP inequality constraints

My name is Grégory and I am trying to compute a Minimum Variance portfolio with the following constraints:
Sum of the weights lower or equal to 1 (the portfolio can be fully invested, but it's not an obligation)
Sum of the weights higher or equal to 0 (the portfolio can be fully in cash, but it's not an obligation)
0<= Asset weight <= 5% (no short-sales are allowed, and the maximum asset weight is 5%)
MV<-function (Returns, percentage = TRUE, ...)
{
if (is.null(dim(Returns))) {
stop("Argument for 'Returns' must be rectangular.\n")
}
call <- match.call()
V <- cov(Returns, ...)
V <- make.positive.definite(V)
N <- ncol(Returns)
a1 <- rep(-1, N)
b1 <- -1
a2 <- diag(N)
b2 <- rep(0, N)
c1<- -diag(N) ## This has been added to the model (to say: min 5%)
c2<-rep(-0.05,N) ## This has been added to the model (to say: min 5%)
c3<- rep(1,N)
c4<- 0
Amat <- cbind(a1,c3,a2,c1) ### Corresponds to the matrix defining the different constraints
Bvec <- c(b1,c4,b2,c2) ### Corresponds to the vector of constraints
Dvec <- rep(0, N) ### Set to 0 because the first term of the routine must be equal to 0
#meq<- c(1,1,rep(1,N), rep(1,N))
opt <- solve.QP(Dmat = 2 * V, dvec = Dvec, Amat = Amat, bvec = Bvec, meq =0)
w_mv <- opt$solution
names(w_mv) <- colnames(Returns)
if (percentage)
w_mv <- w_mv * 100
return(w_mv)
}
When I look at the MV portfolio weights, all the asset weights are equal to 0, so I don't know where the error comes from.
I would be very grateful if you could help me.
Many thanks in advance,
Kind regards,
Grégory
Take a look at this script.
library(stockPortfolio) # Base package for retrieving returns
library(ggplot2) # Used to graph efficient frontier
library(reshape2) # Used to melt the data
library(quadprog) #Needed for solve.QP
# Create the portfolio using ETFs, incl. hypothetical non-efficient allocation
stocks <- c(
"VTSMX" = .0,
"SPY" = .20,
"EFA" = .10,
"IWM" = .10,
"VWO" = .30,
"LQD" = .20,
"HYG" = .10)
# Retrieve returns, from earliest start date possible (where all stocks have
# data) through most recent date
returns <- getReturns(names(stocks[-1]), freq="week") #Currently, drop index
#### Efficient Frontier function ####
eff.frontier <- function (returns, short="no", max.allocation=NULL,
risk.premium.up=.5, risk.increment=.005){
# return argument should be a m x n matrix with one column per security
# short argument is whether short-selling is allowed; default is no (short
# selling prohibited)max.allocation is the maximum % allowed for any one
# security (reduces concentration) risk.premium.up is the upper limit of the
# risk premium modeled (see for loop below) and risk.increment is the
# increment (by) value used in the for loop
covariance <- cov(returns)
print(covariance)
n <- ncol(covariance)
# Create initial Amat and bvec assuming only equality constraint
# (short-selling is allowed, no allocation constraints)
Amat <- matrix (1, nrow=n)
bvec <- 1
meq <- 1
# Then modify the Amat and bvec if short-selling is prohibited
if(short=="no"){
Amat <- cbind(1, diag(n))
bvec <- c(bvec, rep(0, n))
}
# And modify Amat and bvec if a max allocation (concentration) is specified
if(!is.null(max.allocation)){
if(max.allocation > 1 | max.allocation <0){
stop("max.allocation must be greater than 0 and less than 1")
}
if(max.allocation * n < 1){
stop("Need to set max.allocation higher; not enough assets to add to 1")
}
Amat <- cbind(Amat, -diag(n))
bvec <- c(bvec, rep(-max.allocation, n))
}
# Calculate the number of loops
loops <- risk.premium.up / risk.increment + 1
loop <- 1
# Initialize a matrix to contain allocation and statistics
# This is not necessary, but speeds up processing and uses less memory
eff <- matrix(nrow=loops, ncol=n+3)
# Now I need to give the matrix column names
colnames(eff) <- c(colnames(returns), "Std.Dev", "Exp.Return", "sharpe")
# Loop through the quadratic program solver
for (i in seq(from=0, to=risk.premium.up, by=risk.increment)){
dvec <- colMeans(returns) * i # This moves the solution along the EF
sol <- solve.QP(covariance, dvec=dvec, Amat=Amat, bvec=bvec, meq=meq)
eff[loop,"Std.Dev"] <- sqrt(sum(sol$solution*colSums((covariance*sol$solution))))
eff[loop,"Exp.Return"] <- as.numeric(sol$solution %*% colMeans(returns))
eff[loop,"sharpe"] <- eff[loop,"Exp.Return"] / eff[loop,"Std.Dev"]
eff[loop,1:n] <- sol$solution
loop <- loop+1
}
return(as.data.frame(eff))
}
# Run the eff.frontier function based on no short and 50% alloc. restrictions
eff <- eff.frontier(returns=returns$R, short="no", max.allocation=.50,
risk.premium.up=1, risk.increment=.001)
# Find the optimal portfolio
eff.optimal.point <- eff[eff$sharpe==max(eff$sharpe),]
# graph efficient frontier
# Start with color scheme
ealred <- "#7D110C"
ealtan <- "#CDC4B6"
eallighttan <- "#F7F6F0"
ealdark <- "#423C30"
ggplot(eff, aes(x=Std.Dev, y=Exp.Return)) + geom_point(alpha=.1, color=ealdark) +
geom_point(data=eff.optimal.point, aes(x=Std.Dev, y=Exp.Return, label=sharpe),
color=ealred, size=5) +
annotate(geom="text", x=eff.optimal.point$Std.Dev,
y=eff.optimal.point$Exp.Return,
label=paste("Risk: ",
round(eff.optimal.point$Std.Dev*100, digits=3),"\nReturn: ",
round(eff.optimal.point$Exp.Return*100, digits=4),"%\nSharpe: ",
round(eff.optimal.point$sharpe*100, digits=2), "%", sep=""),
hjust=0, vjust=1.2) +
ggtitle("Efficient Frontier\nand Optimal Portfolio") +
labs(x="Risk (standard deviation of portfolio)", y="Return") +
theme(panel.background=element_rect(fill=eallighttan),
text=element_text(color=ealdark),
plot.title=element_text(size=24, color=ealred))
ggsave("Efficient Frontier.png")
There is a good explanation of how this works at the link below.
http://economistatlarge.com/portfolio-theory/r-optimized-portfolio

double for loop in Binomial Tree in R

I want set up a model for interest rate in binomial tree. The interest rate is path dependent. I want return interest rate (discount factor and payoff) at every step in all scenarios(2^N). The reason I want to return every single interest rate is that I want use the interest rate is compute discount factor. I know how to do this in a complex way. Here I want to use a double loop (or something simpler) to get the results.
w is for "0" or "1" dummy variable matrix representing all scenarios.
r is interest rate. if there is a head(1), then r1=r0+u=r0+0.005; if there is a tail(0), then r1=r0-d.
D is discount factor. D1=1/(1+r0), D2=D1/(1+r1)...
P is payoff.
In this case, period N is 10. therefore, I can compute step by step. However,if N gets larger and larger, I cannot use my method. I want a simple way to compute this. Thank you.
#Real Price
N <- 10
r0 <- 0.06
K <- 0.05
u <- 0.005
d <- 0.004
q <- 0.5
w <- expand.grid(rep(list(0:1),N))
r <- D <- P <- matrix(0,0,nrow=2^N,ncol=N)
for(i in 1:dim(w)[1])
{
r[i,1] <- r0 + u*w[i,1] - d*(1-w[i,1])
r[i,2] <- r[i,1] + u*w[i,2] - d*(1-w[i,2])
r[i,3] <- r[i,2]+u*w[i,3]-d*(1-w[i,3])
r[i,4] <- r[i,3]+u*w[i,4]-d*(1-w[i,4])
r[i,5] <- r[i,4]+u*w[i,5]-d*(1-w[i,5])
r[i,6] <- r[i,5]+u*w[i,6]-d*(1-w[i,6])
r[i,7] <- r[i,6]+u*w[i,7]-d*(1-w[i,7])
r[i,8] <- r[i,7]+u*w[i,8]-d*(1-w[i,8])
r[i,9] <- r[i,8]+u*w[i,9]-d*(1-w[i,9])
r[i,10] <- r[i,9]*+u*w[i,10]-d*(1-w[i,10])
D[i,1] <- 1/(1+r0)
D[i,2] <- D[i,1]/(1+r[i,1])
D[i,3] <- D[i,2]/(1+r[i,2])
D[i,4] <- D[i,3]/(1+r[i,3])
D[i,5] <- D[i,4]/(1+r[i,4])
D[i,6] <- D[i,5]/(1+r[i,5])
D[i,7] <- D[i,6]/(1+r[i,6])
D[i,8] <- D[i,7]/(1+r[i,7])
D[i,9] <- D[i,8]/(1+r[i,8])
D[i,10] <- D[i,9]/(1+r[i,9])
P[i,1] <- D[i,1]*pmax(K-r0,0)*(0.5^N)
P[i,2] <- D[i,2]*pmax(K-r[i,1],0)*(0.5^N)
P[i,3] <- D[i,3]*pmax(K-r[i,2],0)*(0.5^N)
P[i,4] <- D[i,4]*pmax(K-r[i,3],0)*(0.5^N)
P[i,5] <- D[i,5]*pmax(K-r[i,4],0)*(0.5^N)
P[i,6] <- D[i,6]*pmax(K-r[i,5],0)*(0.5^N)
P[i,7] <- D[i,7]*pmax(K-r[i,6],0)*(0.5^N)
P[i,8] <- D[i,8]*pmax(K-r[i,7],0)*(0.5^N)
P[i,9] <- D[i,9]*pmax(K-r[i,8],0)*(0.5^N)
P[i,10] <- D[i,10]*pmax(K-r[i,9],0)*(0.5^N)
}
true.price <- sum(P)
#> true.price
# > true.price
# [1] 0.00292045
You can just use a nested loop, looping over 2:(ncol(w)) within the i loop:
for(i in 1:nrow(w)) {
r[i, 1] <- r0 + u*w[i, 1] - d*(1-w[i, 1])
D[i, 1] <- 1/(1+r0)
P[i, 1] <- D[i, 1]*pmax(K-r0, 0)*(0.5^N)
for (j in 2:(ncol(w))) {
r[i,j] <- r[i, j-1] + u*w[i, j] - d*(1-w[i, j])
D[i,j] <- D[i, j-1]/(1+r[i, j-1])
P[i,j] <- D[i, j]*pmax(K-r[i, j-1], 0)*(0.5^N)
}
}
true.price <- sum(P)

Logarithmic mean of vector

To follow the exact methodology presented in an article I would like to calculate the Logarithmic mean of a data vector. I did not find any functions for this in R, or any previous discussions. The case for 2 numbers is clear, but I could not work out the most efficient method to calculate the log mean for a large vector of numbers. Any suggestions?
# Calculating different types of means
# some data
dat <- c(0.008845299, 0.040554701)
# arithmetic mean
arith.m <- mean(dat)
# logarithmic mean
# http://en.wikipedia.org/wiki/Logarithmic_mean
log.m <- (dat[1] - dat[2])/(log(dat[1])-log(dat[2]))
# geometric mean
# http://stackoverflow.com/questions/2602583/geometric-mean-is-there-a-built-in
geo_mean <- function(data) {
log_data <- log(data)
gm <- exp(mean(log_data[is.finite(log_data)]))
return(gm)
}
geo.m <- geo_mean(dat)
# show arithmetic > logarithmic > geometric
arith.m; log.m; geo.m
# how to calculate logarithmic mean for a vector?
dat.n <- c(0.008845299, 0.040554701, 0.047645299, 0.036654701, 0.017345299, 0.018754701, 0.032954701, 0.043145299, 0.026845299, 0.033054701, 0.025554701)
UPDATE with calculation that strips out 0 values (BUT, as pointed out below is this valid?):
# add a very low number (generally considered zero in R)
nzero <- 1.940656e-324
dat.n <- c(dat.n, nzero)
# arithmetic mean
arith.m <- mean(dat.n)
geo_mean <- function(data) {
log_data <- log(data)
gm <- exp(mean(log_data[is.finite(log_data)]))
return(gm)
}
geo.m <- geo_mean(dat.n)
lmv <- function(x){
ddlog <- function(x){
d <- rep(0, length(x))
for (i in 1:length(x)){
d[i] <- prod(x[i] - x[-i])
}
sum(log(x)[is.finite(log(x))]/d[is.finite(log(x))])
}
n <- length(x[which(x>0)]) - 1
((-1)^(n+1)*n*ddlog(x))^(-1/n)
}
log.m <- lmv(dat.n)
# show arithmetic > logarithmic > geometric
arith.m; log.m; geo.m
Followed by wiki (generalized to (n+1) values):
http://en.wikipedia.org/wiki/Divided_difference#Expanded_form
http://en.wikipedia.org/wiki/Logarithmic_mean#Mean_value_theorem_of_differential_calculus_2
ddlog <- function(x){
d <- rep(0, length(x))
for (i in 1:length(x)){
d[i] <- prod(x[i] - x[-i])
}
sum(log(x)/d)
}
# ddlog is to get divided difference of the logarithm.
lmv <- function(x){
n <- length(x) - 1
((-1)^(n+1)*n*ddlog(x))^(-1/n)
}
R > a <- c(0.008845299, 0.040554701, 0.047645299, 0.036654701, 0.017345299, 0.018754701, 0.032954701, 0.043145299, 0.026845299, 0.033054701, 0.025554701)
R >
R > lmv(a)
[1] 0.0277
Try this:
> -diff(dat.n)/-diff(log(dat.n))
[1] 0.02082356 0.04400483 0.04191009 0.02580711 0.01804083 0.02519117 0.03782146 0.03435320 0.02984241
[10] 0.02914404

Resources