[Returnanalytics-commits] r3285 - pkg/PortfolioAnalytics/inst/tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Dec 16 07:39:40 CET 2013
Author: rossbennett34
Date: 2013-12-16 07:39:40 +0100 (Mon, 16 Dec 2013)
New Revision: 3285
Added:
pkg/PortfolioAnalytics/inst/tests/test_roi_gmv_toc.R
pkg/PortfolioAnalytics/inst/tests/test_roi_max_ret.R
pkg/PortfolioAnalytics/inst/tests/test_roi_max_ret_milp.R
pkg/PortfolioAnalytics/inst/tests/test_roi_min_etl.R
pkg/PortfolioAnalytics/inst/tests/test_roi_min_etl_milp.R
pkg/PortfolioAnalytics/inst/tests/test_roi_min_var.R
pkg/PortfolioAnalytics/inst/tests/test_roi_qu.R
Log:
Adding tests to compare ROI to quadprog and Rglpk
Added: pkg/PortfolioAnalytics/inst/tests/test_roi_gmv_toc.R
===================================================================
--- pkg/PortfolioAnalytics/inst/tests/test_roi_gmv_toc.R (rev 0)
+++ pkg/PortfolioAnalytics/inst/tests/test_roi_gmv_toc.R 2013-12-16 06:39:40 UTC (rev 3285)
@@ -0,0 +1,122 @@
+
+library(testthat)
+library(ROI)
+library(ROI.plugin.quadprog)
+library(quadprog)
+library(corpcor)
+library(PerformanceAnalytics)
+
+data(edhec)
+R <- edhec[, 1:5]
+m <- ncol(R)
+
+constraints <- list()
+constraints$min_sum <- 1
+constraints$max_sum <- 1
+constraints$min <- rep(0, m)
+constraints$max <- rep(1, m)
+constraints$turnover_target <- 5
+
+moments <- list()
+moments$mean <- colMeans(R)
+
+lambda <- 1
+target <- NA
+
+# Modify the returns matrix. This is done because there are 3 sets of
+# variables 1) w.initial, 2) w.buy, and 3) w.sell
+R0 <- matrix(0, ncol=ncol(R), nrow=nrow(R))
+returns <- cbind(R, R0, R0)
+V <- cov(returns)
+
+# number of assets
+N <- ncol(R)
+
+# initial weights for solver
+init_weights <- rep(1/ N, N)
+
+# check for a target return constraint
+if(!is.na(target)) {
+ # If var is the only objective specified, then moments$mean won't be calculated
+ if(all(moments$mean==0)){
+ tmp_means <- colMeans(R)
+ } else {
+ tmp_means <- moments$mean
+ }
+} else {
+ tmp_means <- rep(0, N)
+ target <- 0
+}
+Amat <- c(tmp_means, rep(0, 2*N))
+dir <- "=="
+rhs <- target
+meq <- N + 1
+
+# Amat for initial weights
+# Amat <- cbind(diag(N), matrix(0, nrow=N, ncol=N*2))
+Amat <- rbind(Amat, cbind(diag(N), -1*diag(N), diag(N)))
+rhs <- c(rhs, init_weights)
+dir <- c(dir, rep("==", N))
+
+# Amat for turnover constraints
+Amat <- rbind(Amat, c(rep(0, N), rep(-1, N), rep(-1, N)))
+rhs <- c(rhs, -constraints$turnover_target)
+dir <- c(dir, ">=")
+
+# Amat for positive weights
+Amat <- rbind(Amat, cbind(matrix(0, nrow=N, ncol=N), diag(N), matrix(0, nrow=N, ncol=N)))
+rhs <- c(rhs, rep(0, N))
+dir <- c(dir, rep(">=", N))
+
+# Amat for negative weights
+Amat <- rbind(Amat, cbind(matrix(0, nrow=N, ncol=2*N), diag(N)))
+rhs <- c(rhs, rep(0, N))
+dir <- c(dir, rep(">=", N))
+
+# Amat for full investment constraint
+Amat <- rbind(Amat, rbind(c(rep(1, N), rep(0,2*N)), c(rep(-1, N), rep(0,2*N))))
+rhs <- c(rhs, constraints$min_sum, -constraints$max_sum)
+dir <- c(dir, ">=", ">=")
+
+# Amat for lower box constraints
+Amat <- rbind(Amat, cbind(diag(N), diag(0, N), diag(0, N)))
+rhs <- c(rhs, constraints$min)
+dir <- c(dir, rep(">=", N))
+
+# Amat for upper box constraints
+Amat <- rbind(Amat, cbind(-diag(N), diag(0, N), diag(0, N)))
+rhs <- c(rhs, -constraints$max)
+dir <- c(dir, rep(">=", N))
+
+d <- rep(tmp_means, 3)
+
+Amat <- Amat[!is.infinite(rhs), ]
+rhs <- rhs[!is.infinite(rhs)]
+
+result <- solve.QP(Dmat=make.positive.definite(2*lambda*V),
+ dvec=d, Amat=t(Amat), bvec=rhs, meq=meq)
+result
+wts <- result$solution
+wts.final <- wts[(1:N)]
+
+##### ROI #####
+ROI_objective <- Q_objective(Q=make.positive.definite(2*lambda*V),
+ L=rep(-tmp_means, 3))
+
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=Amat, dir=dir, rhs=rhs))
+
+roi.result <- ROI_solve(x=opt.prob, solver="quadprog")
+print.default(roi.result)
+weights <- result$solution[(1:N)]
+
+context("Test solve.QP and ROI_solve for gmv with turnover constraint")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result$objval, result$value)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result$solution[1:m], result$solution[1:m])
+})
+
Added: pkg/PortfolioAnalytics/inst/tests/test_roi_max_ret.R
===================================================================
--- pkg/PortfolioAnalytics/inst/tests/test_roi_max_ret.R (rev 0)
+++ pkg/PortfolioAnalytics/inst/tests/test_roi_max_ret.R 2013-12-16 06:39:40 UTC (rev 3285)
@@ -0,0 +1,67 @@
+
+library(testthat)
+library(ROI)
+library(ROI.plugin.glpk)
+library(Rglpk)
+library(PerformanceAnalytics)
+
+data(edhec)
+R <- edhec[, 1:5]
+m <- ncol(R)
+
+constraints <- list()
+constraints$min_sum <- 1
+constraints$max_sum <- 1
+constraints$min <- rep(0, m)
+constraints$max <- rep(1, m)
+
+moments <- list()
+moments$mu <- colMeans(R)
+
+##### ROI #####
+
+# Box constraints
+bnds <- V_bound(li=seq.int(1L, m), lb=as.numeric(constraints$min),
+ ui=seq.int(1L, m), ub=as.numeric(constraints$max))
+
+# Constraints matrix
+Amat <- rbind(rep(1, m), rep(1, m))
+dir.vec <- c(">=","<=")
+rhs.vec <- c(constraints$min_sum, constraints$max_sum)
+
+# Linear objective
+ROI_objective <- L_objective(L=-moments$mu)
+
+# Set up the optimization problem and solve
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec),
+ bounds=bnds)
+roi.result <- ROI_solve(x=opt.prob, solver="glpk")
+
+##### Rglpk #####
+# Box Constraints
+bnds <- list(lower=list(ind=seq.int(1L, m), val=as.numeric(constraints$min)),
+ upper=list(ind=seq.int(1L, m), val=as.numeric(constraints$max)))
+
+# Constraints matrix
+Amat <- rbind(rep(1, m), rep(1, m))
+dir.vec <- c(">=","<=")
+rhs.vec <- c(constraints$min_sum, constraints$max_sum)
+
+# Linear objective
+objL <- -moments$mu
+
+# Solve
+result <- Rglpk_solve_LP(objL, Amat, dir.vec, rhs.vec)
+
+
+# Check equality
+context("Test Rglpk_solve_LP and ROI_solve for maximimum return")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result$objval, result$optimum)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result$solution, result$solution)
+})
Added: pkg/PortfolioAnalytics/inst/tests/test_roi_max_ret_milp.R
===================================================================
--- pkg/PortfolioAnalytics/inst/tests/test_roi_max_ret_milp.R (rev 0)
+++ pkg/PortfolioAnalytics/inst/tests/test_roi_max_ret_milp.R 2013-12-16 06:39:40 UTC (rev 3285)
@@ -0,0 +1,99 @@
+
+# maximum return with position limit constraints
+library(testthat)
+library(ROI)
+library(ROI.plugin.glpk)
+library(Rglpk)
+library(PerformanceAnalytics)
+
+data(edhec)
+R <- edhec[, 1:5]
+m <- ncol(R)
+
+constraints <- list()
+constraints$min_sum <- 0.99
+constraints$max_sum <- 1.01
+constraints$min <- rep(0.2, m)
+constraints$max <- rep(1, m)
+constraints$max_pos <- 3
+
+moments <- list()
+moments$mu <- colMeans(R)
+moments$mean <- colMeans(R)
+
+target <- NA
+
+max_pos <- constraints$max_pos
+min_pos <- 2
+
+# Number of assets
+N <- ncol(R)
+
+# Upper and lower bounds on weights
+LB <- as.numeric(constraints$min)
+UB <- as.numeric(constraints$max)
+
+##### ROI #####
+
+# Check for target return
+if(!is.na(target)){
+ # We have a target
+ targetcon <- rbind(c(moments$mean, rep(0, N)),
+ c(-moments$mean, rep(0, N)))
+ targetdir <- c("<=", "==")
+ targetrhs <- c(Inf, -target)
+} else {
+ # No target specified, just maximize
+ targetcon <- NULL
+ targetdir <- NULL
+ targetrhs <- NULL
+}
+
+# weight_sum constraint
+Amat <- rbind(c(rep(1, N), rep(0, N)),
+ c(rep(1, N), rep(0, N)))
+
+# Target return constraint
+Amat <- rbind(Amat, targetcon)
+
+# Bounds and position limit constraints
+Amat <- rbind(Amat, cbind(-diag(N), diag(LB)))
+Amat <- rbind(Amat, cbind(diag(N), -diag(UB)))
+Amat <- rbind(Amat, c(rep(0, N), rep(-1, N)))
+Amat <- rbind(Amat, c(rep(0, N), rep(1, N)))
+
+dir <- c("<=", ">=", targetdir, rep("<=", 2*N), "<=", "<=")
+rhs <- c(1, 1, targetrhs, rep(0, 2*N), -min_pos, max_pos)
+
+# Only seems to work if I do not specify bounds
+# bnds <- V_bound(li=seq.int(1L, 2*N), lb=c(as.numeric(constraints$min), rep(0, N)),
+# ui=seq.int(1L, 2*N), ub=c(as.numeric(constraints$max), rep(Inf, N)))
+bnds <- NULL
+
+# Set up the types vector with continuous and binary variables
+types <- c(rep("C", N), rep("B", N))
+
+# Set up the linear objective to maximize mean return
+ROI_objective <- L_objective(L=c(-moments$mean, rep(0, N)))
+
+# Set up the optimization problem and solve
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=Amat, dir=dir, rhs=rhs),
+ bounds=bnds, types=types)
+roi.result <- ROI_solve(x=opt.prob, solver="glpk")
+
+##### Rglpk #####
+
+objL <- c(-moments$mean, rep(0, N))
+
+result <- Rglpk_solve_LP(obj=objL, mat=Amat, dir=dir, rhs=rhs, bounds=bnds, types=types)
+
+context("Test Rglpk_solve_LP and ROI_solve for maximum return with cardinality constraints")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result$objval, result$optimum)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result$solution[1:m], result$solution[1:m])
+})
\ No newline at end of file
Added: pkg/PortfolioAnalytics/inst/tests/test_roi_min_etl.R
===================================================================
--- pkg/PortfolioAnalytics/inst/tests/test_roi_min_etl.R (rev 0)
+++ pkg/PortfolioAnalytics/inst/tests/test_roi_min_etl.R 2013-12-16 06:39:40 UTC (rev 3285)
@@ -0,0 +1,74 @@
+
+# minimum ETL
+library(testthat)
+library(ROI)
+library(ROI.plugin.glpk)
+library(Rglpk)
+library(PerformanceAnalytics)
+
+data(edhec)
+R <- edhec[, 1:5]
+m <- ncol(R)
+n <- nrow(R)
+
+constraints <- list()
+constraints$min_sum <- 1
+constraints$max_sum <- 1
+constraints$min <- rep(0, m)
+constraints$max <- rep(1, m)
+
+moments <- list()
+moments$mu <- colMeans(R)
+
+alpha <- 0.05
+target <- mean(colMeans(R))
+
+##### ROI #####
+
+# Box constraints
+LB <- c(as.numeric(constraints$min), rep(0, n), -1)
+UB <- c(as.numeric(constraints$max), rep(Inf, n), 1)
+bnds <- V_bound(li=seq.int(1L, m+n+1), lb=LB,
+ ui=seq.int(1L, m+n+1), ub=UB)
+
+# Constraint matrix
+Amat <- cbind(rbind(1, 1, moments$mu, coredata(R)), rbind(0, 0, 0, cbind(diag(n), 1)))
+dir.vec <- c(">=", "<=", ">=", rep(">=", n))
+rhs.vec <- c(constraints$min_sum, constraints$max_sum, target, rep(0, n))
+
+# Linear objective
+ROI_objective <- L_objective(c(rep(0, m), rep(1 / (alpha * n), n), 1))
+
+# Set up the optimization problem and solve
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec),
+ bounds=bnds)
+roi.result <- ROI_solve(x=opt.prob, solver="glpk")
+
+##### Rglpk #####
+
+# Box constraints
+bnds <- list(lower=list(ind=seq.int(1L, m), val=as.numeric(constraints$min)),
+ upper=list(ind=seq.int(1L, m), val=as.numeric(constraints$max)))
+
+# Constraint matrix
+Amat <- cbind(rbind(1, 1, moments$mu, coredata(R)), rbind(0, 0, 0, cbind(diag(n), 1)))
+dir.vec <- c(">=", "<=", ">=", rep(">=", n))
+rhs.vec <- c(constraints$min_sum, constraints$max_sum, target, rep(0, n))
+
+# Linear objective
+objL <- c(rep(0, m), rep(1 / (alpha * n), n), 1)
+
+# Solve
+result <- Rglpk_solve_LP(objL, Amat, dir.vec, rhs.vec, bnds)
+
+context("Test Rglpk_solve_LP and ROI_solve for minimum ES")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result$objval, result$optimum)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result$solution[1:m], result$solution[1:m])
+})
+
Added: pkg/PortfolioAnalytics/inst/tests/test_roi_min_etl_milp.R
===================================================================
--- pkg/PortfolioAnalytics/inst/tests/test_roi_min_etl_milp.R (rev 0)
+++ pkg/PortfolioAnalytics/inst/tests/test_roi_min_etl_milp.R 2013-12-16 06:39:40 UTC (rev 3285)
@@ -0,0 +1,120 @@
+
+library(testthat)
+library(ROI)
+library(ROI.plugin.glpk)
+library(Rglpk)
+library(PerformanceAnalytics)
+
+data(edhec)
+R <- edhec[, 1:5]
+m <- ncol(R)
+
+constraints <- list()
+constraints$min_sum <- 0.99
+constraints$max_sum <- 1.01
+constraints$min <- rep(0, m)
+constraints$max <- rep(1, m)
+constraints$max_pos <- 3
+
+moments <- list()
+moments$mean <- colMeans(R)
+
+target <- NA
+alpha <- 0.05
+
+##### Rglpk #####
+# Number of rows
+n <- nrow(R)
+
+# Number of columns
+m <- ncol(R)
+
+max_sum <- constraints$max_sum
+min_sum <- constraints$min_sum
+LB <- constraints$min
+UB <- constraints$max
+max_pos <- constraints$max_pos
+min_pos <- 1
+moments_mean <- as.numeric(moments$mean)
+
+# A benchmark can be specified in the parma package.
+# Leave this in and set to 0 for now
+benchmark <- 0
+
+# Check for target return
+if(!is.na(target)){
+ # We have a target
+ targetcon <- c(moments_mean, rep(0, n+2))
+ targetdir <- "=="
+ targetrhs <- target
+} else {
+ # No target specified, just maximize
+ targetcon <- NULL
+ targetdir <- NULL
+ targetrhs <- NULL
+}
+
+# Set up initial A matrix
+tmpAmat <- cbind(-coredata(R),
+ matrix(-1, nrow=n, ncol=1),
+ -diag(n),
+ matrix(benchmark, nrow=n, ncol=1))
+
+# Add leverage constraints to matrix
+tmpAmat <- rbind(tmpAmat, rbind(c(rep(1, m), rep(0, n+2)),
+ c(rep(1, m), rep(0, n+2))))
+
+# Add target return to matrix
+tmpAmat <- rbind(tmpAmat, as.numeric(targetcon))
+
+# This step just adds m rows to the matrix to accept box constraints in the next step
+tmpAmat <- cbind(tmpAmat, matrix(0, ncol=m, nrow=dim(tmpAmat)[1]))
+
+# Add lower bound box constraints
+tmpAmat <- rbind(tmpAmat, cbind(-diag(m), matrix(0, ncol=n+2, nrow=m), diag(LB)))
+
+# Add upper bound box constraints
+tmpAmat <- rbind(tmpAmat, cbind(diag(m), matrix(0, ncol=n+2, nrow=m), diag(-UB)))
+
+# Add row for max_pos cardinality constraints
+tmpAmat <- rbind(tmpAmat, cbind(matrix(0, ncol=m + n + 2, nrow=1), matrix(-1, ncol=m, nrow=1)))
+tmpAmat <- rbind(tmpAmat, cbind(matrix(0, ncol=m + n + 2, nrow=1), matrix(1, ncol=m, nrow=1)))
+
+# Set up the rhs vector
+rhs <- c( rep(0, n), min_sum, max_sum, targetrhs, rep(0, 2*m), -min_pos, max_pos)
+
+# Set up the dir vector
+dir <- c( rep("<=", n), ">=", "<=", targetdir, rep("<=", 2*m), "<=", "<=")
+
+# Linear objective vector
+objL <- c( rep(0, m), 1, rep(1/n, n) / alpha, 0, rep(0, m))
+
+# Set up the types vector with continuous and binary variables
+types <- c( rep("C", m), "C", rep("C", n), "C", rep("B", m))
+
+bounds <- list( lower = list( ind = 1L:(m + n + 2 + m), val = c(LB, -1, rep(0, n), 1, rep(0, m)) ),
+ upper = list( ind = 1L:(m + n + 2 + m), val = c( UB, 1, rep(Inf, n), 1 , rep(1, m)) ) )
+
+
+result <- Rglpk_solve_LP(obj=objL, mat=tmpAmat, dir=dir, rhs=rhs, types=types, bounds=bounds)
+
+##### ROI #####
+bnds <- V_bound( li = 1L:(m + n + 2 + m), lb = c(LB, -1, rep(0, n), 1, rep(0, m)),
+ ui = 1L:(m + n + 2 + m), ub = c( UB, 1, rep(Inf, n), 1 , rep(1, m)))
+
+ROI_objective <- L_objective(c( rep(0, m), 1, rep(1/n, n) / alpha, 0, rep(0, m)))
+
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=tmpAmat, dir=dir, rhs=rhs),
+ bounds=bnds, types=types)
+roi.result <- ROI_solve(x=opt.prob, solver="glpk")
+
+context("Test Rglpk_solve_LP and ROI_solve for minimum ES with cardinality constraint")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result$objval, result$optimum)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result$solution[1:m], result$solution[1:m])
+})
Added: pkg/PortfolioAnalytics/inst/tests/test_roi_min_var.R
===================================================================
--- pkg/PortfolioAnalytics/inst/tests/test_roi_min_var.R (rev 0)
+++ pkg/PortfolioAnalytics/inst/tests/test_roi_min_var.R 2013-12-16 06:39:40 UTC (rev 3285)
@@ -0,0 +1,79 @@
+
+# minimum variance
+library(testthat)
+library(ROI)
+library(ROI.plugin.quadprog)
+library(quadprog)
+library(PerformanceAnalytics)
+
+data(edhec)
+R <- edhec[, 1:5]
+m <- ncol(R)
+
+constraints <- list()
+constraints$min_sum <- 1
+constraints$max_sum <- 1
+constraints$min <- rep(0, m)
+constraints$max <- rep(1, m)
+
+moments <- list()
+moments$mu <- rep(0, m)
+moments$sigma <- cov(R)
+
+##### ROI #####
+
+# Box constraints
+# bnds <- V_bound(li=seq.int(1L, m), lb=as.numeric(constraints$min),
+# ui=seq.int(1L, m), ub=as.numeric(constraints$max))
+
+# Constraints matrix
+Amat <- rbind(rep(1, m), rep(1, m))
+dir.vec <- c(">=","<=")
+rhs.vec <- c(constraints$min_sum, constraints$max_sum)
+
+# Add min box constraints
+Amat <- rbind(Amat, diag(m))
+dir.vec <- c(dir.vec, rep(">=", m))
+rhs.vec <- c(rhs.vec, constraints$min)
+
+# Add max box constraints
+Amat <- rbind(Amat, -1*diag(m))
+dir.vec <- c(dir.vec, rep(">=", m))
+rhs.vec <- c(rhs.vec, -constraints$max)
+
+# Quadratic objective
+ROI_objective <- Q_objective(Q=2 * moments$sigma, L=moments$mu)
+
+# Set up the optimization problem and solve
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec))
+roi.result <- ROI_solve(x=opt.prob, solver="quadprog")
+
+##### quadprog #####
+
+# Constraints matrix
+Amat <- rbind(rep(1, m), rep(-1, m))
+rhs.vec <- c(constraints$min_sum, -constraints$max_sum)
+
+# Box constraints
+Amat <- rbind(Amat, diag(m), -1*diag(m))
+rhs.vec <- c(rhs.vec, constraints$min, -constraints$max)
+
+# Objectives
+objQ <- 2 * moments$sigma
+objL <- rep(0, m)
+
+# Solve
+result <- solve.QP(objQ, objL, t(Amat), rhs.vec)
+
+# Check for equality
+context("Test solve.QP and ROI_solve for minimum variance problem")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result$objval, result$value)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result$solution, result$solution)
+})
+
Added: pkg/PortfolioAnalytics/inst/tests/test_roi_qu.R
===================================================================
--- pkg/PortfolioAnalytics/inst/tests/test_roi_qu.R (rev 0)
+++ pkg/PortfolioAnalytics/inst/tests/test_roi_qu.R 2013-12-16 06:39:40 UTC (rev 3285)
@@ -0,0 +1,127 @@
+
+# quadratic utility
+library(testthat)
+library(ROI)
+library(ROI.plugin.quadprog)
+library(quadprog)
+library(PerformanceAnalytics)
+
+data(edhec)
+R <- edhec[, 1:5]
+m <- ncol(R)
+
+constraints <- list()
+constraints$min_sum <- 1
+constraints$max_sum <- 1
+constraints$min <- rep(0, m)
+constraints$max <- rep(1, m)
+
+moments <- list()
+moments$mu <- colMeans(R)
+moments$sigma <- cov(R)
+
+lambda <- 0.5
+
+##### ROI #####
+
+# Box constraints
+# bnds <- list(li=seq.int(1L, m), lb=as.numeric(constraints$min)),
+# ui=seq.int(1L, m), ub=as.numeric(constraints$max)))
+
+# Constraints matrix
+Amat <- rbind(rep(1, m), rep(-1, m))
+dir.vec <- c(">=",">=")
+rhs.vec <- c(constraints$min_sum, -constraints$max_sum)
+
+# Add min box constraints
+Amat <- rbind(Amat, diag(m))
+dir.vec <- c(dir.vec, rep(">=", m))
+rhs.vec <- c(rhs.vec, constraints$min)
+
+# Add max box constraints
+Amat <- rbind(Amat, -1*diag(m))
+dir.vec <- c(dir.vec, rep(">=", m))
+rhs.vec <- c(rhs.vec, -constraints$max)
+
+# Quadratic objective
+ROI_objective <- Q_objective(Q=2 * lambda * moments$sigma, L=-moments$mu)
+
+# Set up the optimization problem and solve
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec))
+roi.result <- ROI_solve(x=opt.prob, solver="quadprog")
+
+##### quadprog #####
+
+# Constraints matrix
+Amat <- rbind(rep(1, m), rep(-1, m))
+rhs.vec <- c(constraints$min_sum, -constraints$max_sum)
+
+# Box constraints
+Amat <- rbind(Amat, diag(m), -1*diag(m))
+rhs.vec <- c(rhs.vec, constraints$min, -constraints$max)
+
+# Quadratic and linear bjectives
+objQ <- 2 * lambda * moments$sigma
+objL <- moments$mu
+
+# Solve
+result <- solve.QP(objQ, objL, t(Amat), rhs.vec)
+
+# Check for equality
+# lambda = 0.5
+context("Test solve.QP and ROI_solve for quadratic utility lambda=0.5")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result$objval, result$value)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result$solution, result$solution)
+})
+
+
+# Very small penalty term is equivalent to max return objective
+ROI_objective <- Q_objective(Q=2 * 1e-6 * moments$sigma, L=-moments$mu)
+
+# Set up the optimization problem and solve
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec))
+roi.result.maxret <- ROI_solve(x=opt.prob, solver="quadprog")
+
+objQ <- 2 * 1e-6 * moments$sigma
+result.maxret <- solve.QP(objQ, objL, t(Amat), rhs.vec, 2)
+
+# lambda = 1e-6
+context("Test solve.QP and ROI_solve for quadratic utility lambda=1e-6")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result.maxret$objval, result.maxret$value)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result.maxret$solution, result.maxret$solution)
+})
+
+# Very large penalty term is equivalent to min variance objective
+ROI_objective <- Q_objective(Q=2 * 1e6 * moments$sigma, L=-moments$mu)
+
+# Set up the optimization problem and solve
+opt.prob <- OP(objective=ROI_objective,
+ constraints=L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec))
+roi.result.minvar <- ROI_solve(x=opt.prob, solver="quadprog")
+
+objQ <- 2 * 1e6 * moments$sigma
+result.minvar <- solve.QP(objQ, objL, t(Amat), rhs.vec, 2)
+
+# lambda = 1e6
+context("Test solve.QP and ROI_solve for quadratic utility lambda=1e6")
+
+test_that("Objective values are equal", {
+ expect_equal(roi.result.minvar$objval, result.minvar$value)
+})
+
+test_that("Solutions (optimal weights) are equal", {
+ expect_equal(roi.result.minvar$solution, result.minvar$solution)
+})
+
More information about the Returnanalytics-commits
mailing list