I'm trying to run the script below and it keeps failing.
###### rm(list=ls())
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 ("VCRA",
"AFFX",
"SGI",
"SAFM",
"SCAI",
"LINC",
"OGS",
"HIIQ",
"FLIR",
"MGEE",
"INTT",
"IPCI",
"DMRC",
"SBGL",
"UNTY",
"AEP",
"NAME",
"ED",
"WEC",
"MMYT",
"AWK",
"DRD",
"ISRG",
"CHUY",
"EDE",
"CHT",
"BGFV",
"VPCOU",
"NJR",
"FC",
"ROVI",
"SO",
"BXLT",
"NATH",
"VRNS",
"XEL",
"MBTF",
"MJCO",
"CMS",
"DLR",
"O",
"ADTN",
"SSS",
"SLP",
"PBY",
"NI",
"ORBC",
"CPB",
"OCLR",
"TLP",
"PROV",
"NWN",
"LNT",
"NTLS",
"PPC",
"NTT",
"WBMD",
"PLCE",
"NEE",
"EE",
"PMBC",
"PACB",
"AVA",
"IESC",
"HOFT",
"QSII",
"LPTH",
"INFY",
"DYAX",
"CPK",
"MMAC",
"CBNJ",
"IDSY",
"ONE",
"ITC",
"HLI",
"VHC",
"CTWS",
"SMBC",
"EQIX",
"LOCO",
"LEI",
"PNM",
"CYBE",
"PSA",
"YOKU",
"BDBD",
"ADMS",
"GMCR",
"DWA",
"LBMH",
"SCG",
"KMB",
"POR",
"ARG",
"ETR",
"WGL",
"CRAY",
"ES")
# Retrieve returns, from earliest start date possible (where all stocks have
# data) through most recent date
returns <- getReturns(stocks, freq="day", start = "2015-02-01", end = "2015-07-30") #Currently, drop index
#### Efficient Frontier function ####
eff.frontier <- function (returns, short="yes", max.allocation=NULL,
risk.premium.up=2.95, risk.increment=.1){
# 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=2.95, risk.increment=.1)
# 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")
transposed_object<-as.data.frame(t(eff.optimal.point))
colnames(transposed_object)<- c("stat")
subset(transposed_object, transposed_object $stat>0.05)
The problem is, one or more of these stocks don't have prices during the period I'm looking at, and this throws an error because no prices = no returns. How can I modify the script to print any stock symbol with no prices, so I can just delete any/all from the list, and re-run the script and have it work the second time?
Thanks to all.
returns <- if( prices = returns) { getReturns(stocks, freq="day", start = "2015-02-01", end = "2015-07-30") } else (no prices = no returns) {add current date};
returns<- returns[-currentdate, ];
then rerun your code. This is an outline of what I would do. Thoughts anyone?
Related
I am trying to construct the minimum variance portfolio from a large set of stocks (890), which also satisfies some additional external constraints. For example I want to check whether the resulting portfolio meets certain sector weight restrictions and if it does not then look for new one that does.
Here is the code I am currently using to find the minimum variance portfolio (using cov.shrink from the corpcor package and solve.QP from the quadprog package):
X <- as.matrix(LogReturn)
# Shrinkage estimator covariance matrix
covar <- cov.shrink(X)
N <- ncol(X)
zeros <- array(0, dim = c(N,1))
# Evaluate the optimization to generate minimum variance portfolio with no short selling and with max allocation of 0.05
aMat <- cbind(1, diag(N))
aMat <- cbind(aMat, -diag(N))
b0 <- c(1, rep(0, N))
b0 <- c(b0, rep(-0.05, N))
res <- solve.QP(covar, zeros, aMat, bvec=b0, meq = 1)
# Return portfolio attributes
y <- X %*% res$solution
port <- list(pw = round(res$solution,3), px = y, pm = mean(y), ps = sd(y))
port
And here is the code I planned to use to check whether the proposed portfolio meets my sector constraints:
Sedol <- cbind(SedolData, round(res$solution,3))
colnames(Sedol) <- c("SEDOL", "Sector", "Country", "Weight")
# Proposed sector data
L <- nrow(SectorKey)
Sector <- cbind(SectorKey, 0)
colnames(Sector) <- c("Name", "Key", "Parent", "Proposed")
bPass <- TRUE
for(i in 1:L){
for (x in 1:N){
if(Sedol[x,2] == Sector[i,2]){
Sector[i,4] <- Sector[i,4] + Sedol[x,4]
}
}
if(abs(Sector[i,3] - Sector[i,4])>0.05){
bPass <- FALSE
}
}
if(bPass == FALSE){
# add cost function?
}
I am quite new to r and I was wondering whether someone could suggest how I should proceed. I was thinking I would iteratively penalise portfolios that do not satisfy my constraints with some sort of cost function, but as I do not how to solve my problem without using solve.QP I am not sure how to go about this.
LogReturns is a matrix of log returns for my 890 stocks with 120 observations.
SedolData is a key for which sector each stock is in and used to find the allocations of the proposed portfolio to each sector (matrix of 890 stocks with key for each sector in column two).
SectorKey is a matrix of sectors with target weights (tolerance 5%).
Any help would be greatly appreciated!
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)
I have written a custom likelihood function that fits a multi-data model that integrates mark-recapture and telemetry data (sensu Royle et al. 2013 Methods in Ecology and Evolution). The likelihood function is designed to be flexible in terms of whether and how many covariates are specified for different linear models in different likelihood components which is determined by values supplied as function arguments (i.e., data matrices "detcovs" and "dencovs" in my code). The likelihood function works when I directly supply it to optimization functions (e.g., optim or nlm), but does not play nice with the mle2 function in the bbmle package. My problem is that I continually run into the following error: "some named arguments in 'start' are not arguments to the specified log-likelihood function". This is my first attempt at writing custom likelihood functions so I'm sure there are general coding conventions of which I'm unaware that make such tasks much more efficient and amendable to the mle2 function. Below is my likelihood function, code creating the staring value objects, and code calling the mle2 function. Any advice how to solve the error problem and general comments on writing cleaner functions is welcome. Many thanks in advance.
Edit: As requested, I have simplified the likelihood function and provided code to simulate reproducible data to which the model can be fit. Included in the simulation code are 2 custom functions and use of the raster function from the raster package. Hopefully, I have sufficiently simplified everything to enable others to troubleshoot. Again, many thanks for your help!
Jared
Likelihood function:
CSCR.RSF.intlik2.EXAMPLE <- function(alpha0,sigma,alphas=NULL,betas=NULL,n0,yscr=NULL,K=NULL,X=X,trapcovs=NULL,Gden=NULL,Gdet=NULL,ytel=NULL,stel=NULL,
dencovs=NULL,detcovs=NULL){
#
# this version of the code handles a covariate on log(Density). This is starting value 5
#
# start = vector of starting values
# yscr = nind x ntraps encounter matrix
# K = number of occasions
# X = trap locations
# Gden = matrix with grid cell coordinates for density raster
# Gdet = matrix with gride cell coordinates for RSF raster
# dencovs = all covariate values for all nGden pixels in density raster
# trapcovs = covariate value at trap locations
# detcovs = all covariate values for all nGrsf pixels in RSF raster
# ytel = nguys x nGdet matrix of telemetry fixes in each nGdet pixels
# stel = home range center of telemetered individuals, IF you wish to estimate it. Not necessary
# alphas = starting values for RSF/detfn coefficients excluding sigma and intercept
# alpha0 = starting values for RSF/detfn intercept
# sigma = starting value for RSF/detfn sigma
# betas = starting values for density function coefficients
# n0 = starting value for number of undetected individuals on log scale
#
n0 = exp(n0)
nGden = nrow(Gden)
D = e2dist(X,Gden)
nGdet <- nrow(Gdet)
alphas = alphas
loglam = alpha0 -(1/(2*sigma*sigma))*D*D + as.vector(trapcovs%*%alphas) # ztrap recycled over nG
psi = exp(as.vector(dencovs%*%betas))
psi = psi/sum(psi)
probcap = 1-exp(-exp(loglam))
#probcap = (exp(theta0)/(1+exp(theta0)))*exp(-theta1*D*D)
Pm = matrix(NA,nrow=nrow(probcap),ncol=ncol(probcap))
ymat = yscr
ymat = rbind(yscr,rep(0,ncol(yscr)))
lik.marg = rep(NA,nrow(ymat))
for(i in 1:nrow(ymat)){
Pm[1:length(Pm)] = (dbinom(rep(ymat[i,],nGden),rep(K,nGden),probcap[1:length(Pm)],log=TRUE))
lik.cond = exp(colSums(Pm))
lik.marg[i] = sum( lik.cond*psi )
}
nv = c(rep(1,length(lik.marg)-1),n0)
part1 = lgamma(nrow(yscr)+n0+1) - lgamma(n0+1)
part2 = sum(nv*log(lik.marg))
out = -1*(part1+ part2)
lam = t(exp(a0 - (1/(2*sigma*sigma))*t(D2)+ as.vector(detcovs%*%alphas)))# recycle zall over all ytel guys
# lam is now nGdet x nG!
denom = rowSums(lam)
probs = lam/denom # each column is the probs for a guy at column [j]
tel.loglik = -1*sum( ytel*log(probs) )
out = out + tel.loglik
out
}
Data simulation code:
library(raster)
library(bbmle)
e2dist <- function (x, y){
i <- sort(rep(1:nrow(y), nrow(x)))
dvec <- sqrt((x[, 1] - y[i, 1])^2 + (x[, 2] - y[i, 2])^2)
matrix(dvec, nrow = nrow(x), ncol = nrow(y), byrow = F)
}
spcov <- function(R) {
v <- sqrt(nrow(R))
D <- as.matrix(dist(R))
V <- exp(-D/2)
cov1 <- t(chol(V)) %*% rnorm(nrow(R))
Rd <- as.data.frame(R)
colnames(Rd) <- c("x", "y")
Rd$C <- as.numeric((cov1 - mean(cov1)) / sd(cov1))
return(Rd)
}
set.seed(1234)
co <- seq(0.3, 0.7, length=5)
X <- cbind(rep(co, each=5),
rep(co, times=5))
B <- 10
co <- seq(0, 1, length=B)
Z <- cbind(rep(co, each=B), rep(co, times=B))
dencovs <- cbind(spcov(Z),spcov(Z)[,3]) # ordered as reading raster image from left to right, bottom to top
dimnames(dencovs)[[2]][3:4] <- c("dencov1","dencov2")
denr.list <- vector("list",2)
for(i in 1:2){
denr.list[[i]] <- raster(
list(x=seq(0,1,length=10),
y=seq(0,1,length=10),
z=t(matrix(dencovs[,i+2],10,10,byrow=TRUE)))
)
}
B <- 20
co <- seq(0, 1, length=B)
Z <- cbind(rep(co, each=B), rep(co, times=B))
detcovs <- cbind(spcov(Z),spcov(Z)[,3]) # ordered as reading raster image from left to right, bottom to top
dimnames(detcovs)[[2]][3:4] <- c("detcov1","detcov2")
detcov.raster.list <- vector("list",2)
trapcovs <- matrix(0,J,2)
for(i in 1:2){
detr.list[[i]] <- raster(
list(x=seq(0,1,length=20),
y=seq(0,1,length=20),
z=t(matrix(detcovs[,i+2],20,20,byrow=TRUE)))
)
trapcovs[,i] <- extract(detr.list[[i]],X)
}
alpha0 <- -3
sigma <- 0.15
alphas <- c(1,-1)
beta0 <- 3
betas <- c(-1,1)
pixelArea <- (dencovs$y[2] - dencovs$y[1])^2
mu <- exp(beta0 + as.matrix(dencovs[,3:4])%*%betas)*pixelArea
EN <- sum(mu)
N <- rpois(1, EN)
pi <- mu/sum(mu)
s <- dencovs[sample(1:nrow(dencovs), size=N, replace=TRUE, prob=pi),1:2]
J <- nrow(X)
K <- 10
yc <- d <- p <- matrix(NA, N, J)
D <- e2dist(s,X)
loglam <- t(alpha0 - t((1/(2*sigma*sigma))*D*D) + as.vector(trapcovs%*%alphas))
p <- 1-exp(-exp(loglam))
for(i in 1:N) {
for(j in 1:J) {
yc[i,j] <- rbinom(1, K, p[i,j])
}
}
detected <- apply(yc>0, 1, any)
yscr <- yc[detected,]
ntel <- 5
nfixes <- 100
poss.tel <- which(s[,1]>0.2 & s[,1]<0.8 & s[,2]>0.2 & s[,2]<0.8)
stel.id <- sample(poss.tel,ntel)
stel <- s[stel.id,]
ytel <- matrix(NA,ntel,nrow(detcovs))
d <- e2dist(stel,detcovs[,1:2])
lam <- t(exp(1 - t((1/(2*sigma*sigma))*d*d) + as.vector(as.matrix(detcovs[,3:4])%*%alphas)))
for(i in 1:ntel){
ytel[i,] <- rmultinom(1,nfixes,lam[i,]/sum(lam[i,]))
}
Specify starting values and call mle2 function:
start1 <- list(alpha0=alpha0,sigma=sigma,alphas=alphas,betas=betas,n0=log(N-nrow(yscr)))
parnames(CSCR.RSF.intlik2.EXAMPLE) <- names(start)
out1 <- mle2(CSCR.RSF.intlik2.EXAMPLE,start=start1,method="SANN",optimizer="optim",
data=list(yscr=yscr,K=K,X=X,trapcovs=trapcovs,Gden=dencovs[,1:2],Gdet=detcovs[,1:2],
ytel=ytel,stel=stel,dencovs=as.matrix(dencovs[,3:4]),detcovs=as.matrix(detcovs[,3:4]))
)
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
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.