I want to acquire the optimized allocation of a set of the asset, so I use the package fPortfolio and BLCOP. Here is my code,
library(xts);library(fPortfolio);library(BLCOP)
sh_return <- xts(ret[,-1],order.by = as.Date(ret[,1]))
prior_mean <- colMeans(sh_return)
prior_mean
prior_cov_matrix <- cov(sh_return)
## onstruct the confidenec interval
pick_matrix <- matrix(0,2,ncol(sh_return))
colnames(pick_matrix) <- colnames(sh_return)
pick_matrix[1,1:4] <- 1
pick_matrix[2,c(1,2,5,ncol(sh_return)-1)] <- c(0.5,0.6,-1,0.8)
pick_matrix
# views
q <- c(0.4,0.32)
confidence <- c(90,95)
views <- BLViews(pick_matrix,q,confidence,assetNames = colnames(sh_return))
views
# posterior
tau <- 0.3
posterior <- posteriorEst(views,tau=tau,prior_mean,prior_cov_matrix)
# optimazation
optimal_portfolio <- optimalPortfolios.fPort(posterior,inputData = NULL,spec = NULL,constraints = "LongOnly",optimizer = "tangencyPortfolio",numSimulations = 100)
And the error turns out:
Error in if (STATUS != 0) { : argument is of length zero
The problem is, when I check the source code, it seems fine to me and there is no such STATUS that exists. Therefore, I have no idea how this code could go wrong like this. Any idea could be helpful.
Or if you want to test the data, here is the code from the source file of the package, the same error exists:
entries <- c(0.001005,0.001328,-0.000579,-0.000675,0.000121,0.000128,
-0.000445, -0.000437, 0.001328,0.007277,-0.001307,-0.000610,
-0.002237,-0.000989,0.001442,-0.001535, -0.000579,-0.001307,
0.059852,0.027588,0.063497,0.023036,0.032967,0.048039,-0.000675,
-0.000610,0.027588,0.029609,0.026572,0.021465,0.020697,0.029854,
0.000121,-0.002237,0.063497,0.026572,0.102488,0.042744,0.039943,
0.065994 ,0.000128,-0.000989,0.023036,0.021465,0.042744,0.032056,
0.019881,0.032235 ,-0.000445,0.001442,0.032967,0.020697,0.039943,
0.019881,0.028355,0.035064 ,-0.000437,-0.001535,0.048039,0.029854,
0.065994,0.032235,0.035064,0.079958 )
varcov <- matrix(entries, ncol = 8, nrow = 8)
mu <- c(0.08, 0.67,6.41, 4.08, 7.43, 3.70, 4.80, 6.60) / 100
pick <- matrix(0, ncol = 8, nrow = 3, dimnames = list(NULL, letters[1:8]))
pick[1,7] <- 1
pick[2,1] <- -1; pick[2,2] <- 1
pick[3, 3:6] <- c(0.9, -0.9, .1, -.1)
confidences <- 1 / c(0.00709, 0.000141, 0.000866)
views <- BLViews(pick, c(0.0525, 0.0025, 0.02), confidences, letters[1:8])
posterior <- posteriorEst(views, tau = 0.025, mu, varcov )
optimalPortfolios.fPort(posterior, optimizer = "tangencyPortfolio")
Related
Consider the following model for the evolution of an asset's price:
This what I have done (in R). I could not find a function that randomly outputs +1 or -1, so I decided to adapt the inbuilt rbinom function.
## This code is in R
rm(list = ls())
library(dplyr)
library(dint)
library(magrittr)
library(stats)
path =
function(T, mu, sigma, p, x0) {
x = rep(NA, T)
x[1] = x0
for(i in 2:T){
z = if_else(rbinom(1,1,p) == 0, -1, 1)
x[i] = x[i-1] * exp(mu + sigma*z)
}
return(x)
}
## Just some testing
x_sim = path(T = 4, mu = 0, sigma = 0.01, p = 0.5, x0 = 100)
## Actual answer
Np = 10000
mc = matrix(nrow = 17, ncol = Np)
for(j in 1:Np){
mc[,j] = path(T = 17, mu = 0, sigma = 0.01, p = 0.5, x0 = 100)
}
test = mc[2:nrow(mc), ] >= 100
sum_test = colSums(test)
comp = sum(sum_test >= 1)/length(sum_test)
prob = 1 - comp
Does this make sense? Any help/tips/advice would be much appreciated. Thanks!
Staying close to your code, I came up with this. Intuitively, if you think about it, the probability should be rather low due to the parameters and I get a probability of about 6.7% which is roughly what I get if I run your code with the parameters from the assignment.
simpath <- function(t, mu, sigma, p, x0, seed){
# set seed
if(!missing(seed)){
set.seed(seed)
}
# set up matrix for storing the results
res <- matrix(c(1:t, rep(NA, t*2)), ncol = 3)
colnames(res) <- c('t', 'z_t', 'x_t')
res[, 'z_t'] <- sample(c(1, -1), size = t, prob = c(p, 1-p), replace = TRUE)
res[1, 3] <- x0
for(i in 2:t){
res[i, 3] <- res[i-1, 3] * exp(mu+sigma*res[i, 2])
}
return(res)
}
x_sim <- simpath(t = 4, mu = 0, sigma = 0.01, p = 0.5, x0 = 100, seed = 123)
x_sim2 <- simpath(t = 36, mu = 0, sigma = 0.03, p = 0.5, x0 = 100, seed = 123)
## Actual answer
Np <- 100000
mc <- matrix(nrow = 36, ncol = Np)
for (j in 1:Np){
mc[, j] <- simpath(t = 36, mu = 0, sigma = 0.03, p = 0.5, x0 = 100)[, 3]
}
test <- mc > 100
sum_test <- colSums(test)
comp = sum(sum_test == 0)/length(sum_test)
prob = comp
> prob
[1] 0.06759
I am trying to run this code but I keep receiving an error message saying
Error in dim(data) <- dim : invalid first argument
sigma <- matrix(c(1.0, 0,
0, 1.0), nrow = 2)
mu1 <- c(0.5,1.5)
mu2 <- c(1,2)
mu3 <- c(1.5,2.5)
sim=100
t2err=0
for (i in 1:sim){
x1 <- data.frame(mvrnorm(n = 10, mu = mu1, Sigma = sigma),
subjects = c(rep('1', 10)))
x2 <- data.frame(mvrnorm(n = 10, mu = mu2, Sigma = sigma),
subjects = c(rep('2', 10)))
x3 <- data.frame(mvrnorm(n = 10, mu = mu3, Sigma = sigma),
subjects = c(rep('3', 10)))
x <- rbind(x1,x2,x3)
## p-value ##
if (((summary(manova(as.matrix(cbind(x[,1:2])~x$subjects)),'Wilks'))$stats[1,6]) > 0.05) (t2err=t2err+1)
}
cat("Power rate in percentage is",(1-(t2err/sim))*100,"%")
Does anyone know what went wrong? because when I do the same thing with only x1 instead of x=(x1,x2,x3), everything seems to be okay.
Thank you.
It seems you have a problem with the if statement line, I have rectified the line with below one:
if (((summary(manova(as.matrix(x[,1:2])~ x$subjects),'Wilks'))$stats[1,6]) > 0.05) (t2err=t2err+1)
you don't need cbind over there plus as.matrix should be wrapped over x[,1:2] not on the entire formula, which might happened because of wrong order of parenthesis.
If you replace code with above line, it should work.
I’m trying to write simulation code, that generates data and runs t-test selection (discarding those predictors whose t-test p-value exceeds 0.05, retaining the rest) on it. The simulation is largely an adaptation of Applied Econometrics with R by Kleiber and Zeileis (2008, pp. 183–189).
When running the code, it usually fails. Yet with certain seeds (e.g. 1534) it produces plausible output. If it does not produce output (e.g. 1911), it fails due to: "Error in x[, ii] : subscript out of bounds", which traces back to na.omit.data.frame(). So, for some reason, the way I attempt to handle the NAs seems to fail, but I'm unable to figure out in how so.
coef <- rep(coef[,3], length.out = pdim+1)
err <- as.vector(rnorm(nobs, sd = sd))
uX <- c(rep(1, times = nobs))
pX <- matrix(scale(rnorm(nobs)), byrow = TRUE, ncol = pdim, nrow = nobs)
X <- cbind(uX, pX)
y <- coef %*% t(X) + err
y <- matrix(y)
tTp <- (summary(lm(y ~ pX)))$coefficients[,4]
tTp <- tTp[2:length(tTp)]
TTT <- matrix(c(tTp, rep(.7, ncol(pX)-length(tTp))))
tX <- matrix(NA, ncol = ncol(pX), nrow = nrow(pX))
for(i in 1:ncol(pX)) {ifelse(TTT[i,] < ALPHA, tX[,i] <- pX[,i], NA)}
tX <- matrix(Filter(function(x)!all(is.na(x)), tX), nrow = nobs)
TTR <- lm(y ~ tX)
The first block is unlikely to the cause of the error. It merely generates the data and works well on its own and with other methods, like PCA, as well. The second block pulls the p-values from the regression output; removes the p-value of the intercept (beta_0); and fills the vector with as many 7s as necessary to have the same length as the number of variables, to ensure the same dimension for matrix calculations. Seven is arbitrary and could be any number larger than 0.05 to not pass the test of the loop. This becomes – I believe – necessary, if R discards predictors due to multicollinearity.
The final block creates an empty matrix of the original dimensions; inserts the original data, if the t-test p-value is lower than 0.05, else retains the NA; while the penultimate line removes all columns containing NAs ((exclusively NA or one NA is the same here) taken from mnel’s answer to Remove columns from dataframe where ALL values are NA); lastly, the modified data is again put in the shape of a linear regression.
Does anyone know what causes this behavior or how it would work as intended? I would expect it to either work or not, but not kind of both. Ideally, the former.
A working version of the code is:
set.seed(1534)
Sim_TTS <- function(nobs = c(1000, 15000), pdim = pdims, coef = coef100,
model = c("MLC", "MHC"), ...){
DGP_TTS <- function(nobs = 1000, model = c("MLC", "MHC"), coef = coef100,
sd = 1, pdim = pdims, ALPHA = 0.05)
{
model <- match.arg(model)
if(model == "MLC") {
coef <- rep(coef[,1], length.out = pdim+1)
err <- as.vector(rnorm(nobs, sd = sd))
uX <- c(rep(1, times = nobs))
pX <- matrix(scale(rnorm(nobs)), byrow = TRUE, ncol = pdim, nrow = nobs)
X <- cbind(uX, pX)
y <- coef %*% t(X) + err
y <- matrix(y)
tTp <- (summary(lm(y ~ pX)))$coefficients[,4]
tTp <- tTp[2:length(tTp)]
TTT <- matrix(c(tTp, rep(.7, ncol(pX)-length(tTp))))
tX <- matrix(NA, ncol = ncol(pX), nrow = nrow(pX))
for(i in 1:ncol(pX)) {ifelse(TTT[i,] < ALPHA, tX[,i] <- pX[,i], NA)}
tX <- matrix(Filter(function(x)!all(is.na(x)), tX), nrow = nobs)
TTR <- lm(y ~ tX)
} else {
coef <- rep(coef[,2], length.out = pdim+1)
err <- as.vector(rnorm(nobs, sd = sd))
uX <- c(rep(1, times = nobs))
pX <- matrix(scale(rnorm(nobs)), byrow = TRUE, ncol = pdim, nrow = nobs)
X <- cbind(uX, pX)
y <- coef %*% t(X) + err
y <- matrix(y)
tTp <- (summary(lm(y ~ pX)))$coefficients[,4]
tTp <- tTp[2:length(tTp)]
TTT <- matrix(c(tTp, rep(.7, ncol(pX)-length(tTp))))
tX <- matrix(NA, ncol = ncol(pX), nrow = nrow(pX))
for(i in 1:ncol(pX)) {ifelse(TTT[i,] < ALPHA, tX[,i] <- pX[,i], NA)}
tX <- matrix(Filter(function(x)!all(is.na(x)), tX), nrow = nobs)
TTR <- lm(y ~ tX)
}
return(TTR)
}
PG_TTS <- function(nrep = 1, ...)
{
rsq <- matrix(rep(NA, nrep), ncol = 1)
rsqad <- matrix(rep(NA, nrep), ncol = 1)
pastr <- matrix(rep(NA, nrep), ncol = 1)
vmat <- cbind(rsq, rsqad, pastr)
colnames(vmat) <- c("R sq.", "adj. R sq.", "p*")
for(i in 1:nrep) {
vmat[i,1] <- summary(DGP_TTS(...))$r.squared
vmat[i,2] <- summary(DGP_TTS(...))$adj.r.squared
vmat[i,3] <- length(DGP_TTS(...)$coefficients)-1
}
return(c(mean(vmat[,1]), mean(vmat[,2]), round(mean(vmat[,3]))))
}
SIM_TTS <- function(...)
{
prs <- expand.grid(pdim = pdim, nobs = nobs, model = model)
nprs <- nrow(prs)
pow <- matrix(rep(NA, 3 * nprs), ncol = 3)
for(i in 1:nprs) pow[i,] <- PG_TTS(pdim = prs[i,1],
nobs = prs[i,2], model = as.character(prs[i,3]), ...)
rval <- rbind(prs, prs, prs)
rval$stat <- factor(rep(1:3, c(nprs, nprs, nprs)),
labels = c("R sq.", "adj. R sq.", "p*"))
rval$power <- c(pow[,1], pow[,2], pow[,3])
rval$nobs <- factor(rval$nobs)
return(rval)
}
psim_TTS <- SIM_TTS()
tab_TTS <- xtabs(power ~ pdim + stat + model + nobs, data = psim_TTS)
ftable(tab_TTS, row.vars = c("model", "nobs", "stat"), col.vars = "pdim")}
FO_TTS <- Sim_TTS()
FO_TTS
}
Preceeded by:
pdims <- seq(12, 100, 4)
coefLC12 <- c(0, rep(0.2, 4), rep(0.1, 4), rep(0, 4))/1.3
rtL <- c(0.2, rep(0, 3))/1.3
coefLC100 <- c(coefLC12, rep(rtL, 22))
coefHC12 <- c(0, rep(0.8, 4), rep(0.4, 4), rep(0, 4))/1.1
rtH <- c(0.8, rep(0, 3))/1.1
coefHC100 <- c(coefHC12, rep(rtH, 22))
coef100 <- cbind(coefLC100, coefHC100)
I’m aware that model selection via the significance of individual predictors is not recommended, but that is the whole point – it is meant to be compared to more sophisticated methods.
I am trying to reproduce some results from the book "Financial Risk Modelling and Portfolio Optimisation with R" and I get an error that I can't seem to get my head around.
I get the following error in the COPPosterior function:
error in abs(alpha) : non-numeric argument to mathematical function
Is anyone able to see why I get the error?
The error is from the following script:
library(urca)
library(vars)
library(fMultivar)
## Loading data set and converting to zoo
data(EuStockMarkets)
Assets <- as.zoo(EuStockMarkets)
## Aggregating as month-end series
AssetsM <- aggregate(Assets, as.yearmon, tail, 1)
head(AssetsM)
## Applying unit root tests for sub-sample
AssetsMsub <- window(AssetsM, start = start(AssetsM),
end = "Jun 1996")
## Levels
ADF <- lapply(AssetsMsub, ur.df, type = "drift",
selectlags = "AIC")
ERS <- lapply(AssetsMsub, ur.ers)
## Differences
DADF <- lapply(diff(AssetsMsub), ur.df, selectlags = "AIC")
DERS <- lapply(diff(AssetsMsub), ur.ers)
## VECM
VEC <- ca.jo(AssetsMsub, ecdet = "none", spec = "transitory")
summary(VEC)
## Index of time stamps in back test (extending window)
idx <- index(AssetsM)[-c(1:60)]
ANames <- colnames(AssetsM)
NAssets <- ncol(AssetsM)
## Function for return expectations
f1 <- function(x, ci, percent = TRUE){
data <- window(AssetsM, start = start(AssetsM), end = x)
Lobs <- t(tail(data, 1))
vec <- ca.jo(data, ecdet = "none", spec = "transitory")
m <- vec2var(vec, r = 1)
fcst <- predict(m, n.ahead = 1, ci = ci)
LU <- matrix(unlist(fcst$fcst),
ncol = 4, byrow = TRUE)[, c(2, 3)]
RE <- rep(0, NAssets)
PView <- LU[, 1] > Lobs
NView <- LU[, 2] < Lobs
RE[PView] <- (LU[PView, 1] / Lobs[PView, 1] - 1)
RE[NView] <- (LU[NView, 1] / Lobs[NView, 1] - 1)
names(RE) <- ANames
if(percent) RE <- RE * 100
return(RE)
}
ReturnEst <- lapply(idx, f1, ci = 0.5)
qv <- zoo(matrix(unlist(ReturnEst),
ncol = NAssets, byrow = TRUE), idx)
colnames(qv) <- ANames
tail(qv)
library(BLCOP)
library(fPortfolio)
## Computing returns and EW-benchmark returns
R <- (AssetsM / lag(AssetsM, k = -1) -1.0) * 100
## Prior distribution
## Fitting of skewed Student's t distribution
MSTfit <- mvFit(R, method = "st")
mu <- c(MSTfit#fit[["beta"]])
S <- MSTfit#fit[["Omega"]]
skew <- c(MSTfit#fit[["alpha"]])
df <- MSTfit#fit[["df"]]
CopPrior <- mvdistribution("mvst", dim = NAssets, mu = mu,
Omega = S, alpha = skew, df = df)
## Pick matrix and view distributions for last forecast
RetEstCop <- ReturnEst[[27]]
RetEstCop
PCop <- matrix(0, ncol = NAssets, nrow = 3)
colnames(PCop) <- ANames
PCop[1, ANames[1]] <- 1
PCop[2, ANames[2]] <- 1
PCop[3, ANames[4]] <- 1
Sds <- apply(R, 2, sd)
RetViews <- list(distribution("norm", mean = RetEstCop[1],
sd = Sds[1]),
distribution("norm", mean = RetEstCop[2],
sd = Sds[2]),
distribution("norm", mean = RetEstCop[4],
sd = Sds[4])
)
CopViews <- COPViews(pick = PCop, viewDist = RetViews,
confidences = rep(0.5, 3),
assetNames = ANames)
## Simulation of posterior
NumSim <- 10000
CopPost <- COPPosterior(CopPrior, CopViews,
numSimulations = NumSim)
print(CopPrior)
print(CopViews)
slotNames(CopPost)
look at the structure of MSTfit:
str(MSTfit)
You can see that if you want the estimated alpha value, you need to access it via:
MSTfit#fit$estimated[['alpha']]
rather than
MSTfit#fit[['alpha']]
Please forgive my lack of knowledge,.I would be very thankful for some help.
Here is my problem:
I was using optim to estimate parameters of a model and I get this error message
"Error in optim(x0, fn = riskll, method = "L-BFGS-B", lower = lbs, upper = ubs, :
L-BFGS-B needs finite values of 'fn'"
Below is the R code I have written.
library('GeneralizedHyperbolic')
data=read.table(file="MSCI_USA.csv",sep=',',header=T)
data=data[1:8173,]
#starting value
x0 <- c(-0.011,0.146, 0.013, 0.639, 0.059,0.939, -0.144 , 1.187, 1.601, -0.001)
#lower bound and upper bound
lbs <- c(-5, -5, -5, -0.99999, 0.00001, 0, -1, 0.1, 1.2000001, -2)
ubs<- c( 5, 5, 10, 0.99999, 5, 2, 0, 3, 1000, 10)
#the likelihood function
riskll <- function(data,para) {
m0 <- para[1]
m1 <- para[2]
omega <- para[3]
tau <- para[4]
a <- para[5]
b <- para[6]
beta <- para[7]
theta <- para[8]
gamma <- para[9]
phi <- para[10]
T <- nrow(data)
ret <- data[,2];
rate <- data[,3]
exret=100*(ret+1-((rate/100)+1)^(1/365))
h = rep(0,T);
vx = rep(0,T);
h[1] = 10000*exret[1]^2
vx[1] = (exret[1]-m0-(m1+beta*((gamma^0.5)/(gamma^2+beta^2)^0.5))*h[1])/h[1]
for ( i in (2:T) ) {
h[i] = (omega+a*(abs(h[i-1]*vx[i-1])-tau*h[i-1]*vx[i-1])^theta+b*(h[i- 1]^theta))^(1/theta)
vx[i] = (exret[i]-phi*exret[i-1]-m0-(m1+beta*((gamma^0.5)/(gamma^2+beta^2)^0.5))*h[i])/h[i]
}
mu = -1*beta*((gamma^0.5)/(gamma^2+beta^2)^0.5)
delta=((gamma^1.5)/(gamma^2+beta^2)^0.5)
alpha=gamma
beta=beta
param = c(mu, delta, alpha, beta)
riskll <- -1*sum(log(dnig(vx,param=param)))
return(riskll)
}
#optimization
optim(x0,fn=riskll,method ="L-BFGS-B",lower=lbs,upper=ubs, data = data)
I'm not certain, but I'd look carefully at this line:
riskll <- -1*sum(log(dnig(vx,param=param)))
The log function approaches negative infinity as its argument approaches zero. And it's not defined at all for negative arguments. Perhaps the error message is warning you about this possibility.