From noreply at r-forge.r-project.org Tue Dec 10 00:03:33 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 10 Dec 2013 00:03:33 +0100 (CET) Subject: [Returnanalytics-commits] r3269 - pkg/PortfolioAnalytics/sandbox Message-ID: <20131209230333.24593186C04@r-forge.r-project.org> Author: peter_carl Date: 2013-12-10 00:03:32 +0100 (Tue, 10 Dec 2013) New Revision: 3269 Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R Log: - switched S&P to total returns from price returns Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-11-26 22:19:50 UTC (rev 3268) +++ pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:03:32 UTC (rev 3269) @@ -11,6 +11,7 @@ require(gdata) require(quantmod) require(RQuantLib) +Sys.setenv(TZ="GMT") ## Factor set of several commonly used factors @@ -18,16 +19,15 @@ # @TODO: Find a source for TR of SP500 ### Equities -# Get S&P price returns from FRED for now, TR later - # @TODO: Get total returns for S&P factor rather than price returns - getSymbols("SP500", src="FRED") # daily price series - index(SP500) = as.Date(as.yearmon(index(SP500)), frac=1) - # Calculate monthly returns - SP500.R=monthlyReturn(SP500) - colnames(SP500.R)="SP500" - # Calculate quarterly returns - SP500.Q.R=quarterlyReturn(SP500) - colnames(SP500.Q.R)="SP500" +# Download the first sheet in the xls workbook directly from the S&P web site: + x = read.xls("http://www.spindices.com/documents/additional-material/monthly.xlsx?force_download=true") + rawdates = x[-1:-4,1] + rawreturns = x[-1:-4,12] + ISOdates = as.Date(as.yearmon(rawdates, "%m/%Y"), frac=1) + totalreturns = as.numeric(as.character((sub("%", "", rawreturns, fixed=TRUE))))/100 + SP500.TR=na.omit(as.xts(totalreturns, order.by=ISOdates)) + colnames(SP500.TR)="SP500TR" + # see parse.SP500TR.R in the FinancialInstrument package's inst/parsers directory for more detail ### Bonds # Calculate total returns from the yeild of the 10 year constant maturity index maintained by the Fed @@ -67,7 +67,9 @@ ### Credit Spread # Yield spread of Merrill Lynch High-Yield Corporate Master II Index minus 10-year Treasury getSymbols("BAMLH0A0HYM2EY",src="FRED") - CREDIT=BAMLH0A0HYM2EY/100-GS10/100 +BAMLH0A0HYM2EY.M=Cl(to.monthly(BAMLH0A0HYM2EY)) +index(BAMLH0A0HYM2EY.M) = as.Date(as.yearmon(index(BAMLH0A0HYM2EY.M)), frac=1) + CREDIT=(BAMLH0A0HYM2EY.M-GS10)/100 colnames(CREDIT)="Credit Spread" CREDIT.Q=CREDIT[endpoints(CREDIT, on="quarters"),] colnames(CREDIT.Q)="Credit Spread" @@ -198,4 +200,27 @@ factors=cbind(SP500.R, GS10.R, USDI.R, TERM, CREDIT, DJUBS.R, dVIX, TED, OIL.R, TB3MS/100) factors=factors["1997::",] factors.Q=cbind(SP500.Q.R, GS10.Q.R, USDI.Q.R, TERM.Q, CREDIT.Q, DJUBS.Q.R, dVIX.Q, TED.Q, OIL.Q.R, TB3MS[endpoints(TB3MS, on="quarters"),]/100) -factors.Q=factors.Q[paste("1997::",lastquarter,sep=""),] \ No newline at end of file +factors.Q=factors.Q[paste("1997::",lastquarter,sep=""),] + +asofdate= tail(index(factors),1) +labels=colnames(factors) +pdf(file=paste("Cumulative Factor Returns as of ", asofdate, ".pdf", sep=""), paper="letter", width=7.5, height=10) +op <- par(no.readonly=TRUE) +layout(matrix(c(1:NCOL(factors)), ncol = 1, byrow = TRUE), widths=1) +op <- par(oma = c(5,0,4,0), mar=c(0,4,0,4)) +for(i in 1:NCOL(factors)){ + xaxis=FALSE + yaxis=TRUE + if(even(i)) + yaxis.right=TRUE + else + yaxis.right=FALSE + if(i==NCOL(factors)) + xaxis = TRUE + chart.TimeSeries(cbind(factors["1997::",i],SMA(na.locf(factors["1997::",i], n=12))), type="l", colorset=c("blue","lightblue"), ylog=FALSE, xaxis=xaxis, main="", ylab="", yaxis=yaxis, yaxis.right=yaxis.right, lwd=2) + text(.9, .70*(par("usr")[4]), adj=c(0,1), cex = 1.1, labels = labels[i]) +} +par(op) +mtext(expression(bold("Monthly Factor Returns")), side=3, outer=TRUE, line=-3, adj=0.1, col="black", cex=1.2) +mtext(paste("As of", asofdate), side=3, outer=TRUE, line=-3, adj=0.9, col="darkgray", cex=0.8) +dev.off() \ No newline at end of file From noreply at r-forge.r-project.org Tue Dec 10 00:22:55 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 10 Dec 2013 00:22:55 +0100 (CET) Subject: [Returnanalytics-commits] r3270 - pkg/PortfolioAnalytics/sandbox Message-ID: <20131209232255.9C2DC186142@r-forge.r-project.org> Author: peter_carl Date: 2013-12-10 00:22:55 +0100 (Tue, 10 Dec 2013) New Revision: 3270 Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R Log: - added spot gold returns - commented quarterly calculations Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:03:32 UTC (rev 3269) +++ pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:22:55 UTC (rev 3270) @@ -16,7 +16,6 @@ ## Factor set of several commonly used factors # @TODO: Find a better source for VIX -# @TODO: Find a source for TR of SP500 ### Equities # Download the first sheet in the xls workbook directly from the S&P web site: @@ -44,45 +43,45 @@ GS10.R <- GS10.pr + lag(GS10,k=1)/12/100 colnames(GS10.R)<-"GS10TR" - GS10.idx =cumprod(1 + na.omit(GS10.R)) - GS10.Q.idx=to.quarterly(GS10.idx) - GS10.Q.R=quarterlyReturn(Cl(GS10.Q.idx)) - colnames(GS10.Q.R)<-"GS10TR" - index(GS10.Q.R) = as.Date(as.yearqtr(index(GS10.Q.R)), frac=1) + # GS10.idx =cumprod(1 + na.omit(GS10.R)) + # GS10.Q.idx=to.quarterly(GS10.idx) + # GS10.Q.R=quarterlyReturn(Cl(GS10.Q.idx)) + # colnames(GS10.Q.R)<-"GS10TR" + # index(GS10.Q.R) = as.Date(as.yearqtr(index(GS10.Q.R)), frac=1) ### Currencies # Trade Weighted U.S. Dollar Index: Major Currencies - TWEXMMTH getSymbols("TWEXMMTH", src="FRED") # index values -# Dates should be end of month, not beginning of the month as reported + # Dates should be end of month, not beginning of the month as reported index(TWEXMMTH) = as.Date(as.yearmon(index(TWEXMMTH)), frac=1) USDI.R=ROC(TWEXMMTH) colnames(USDI.R)="USD Index" - USDI.idx =cumprod(1 + na.omit(USDI.R)) - USDI.Q.idx=to.quarterly(USDI.idx) - USDI.Q.R=quarterlyReturn(Cl(USDI.Q.idx)) - colnames(USDI.Q.R)<-"USD Index" - index(USDI.Q.R) = as.Date(as.yearqtr(index(USDI.Q.R)), frac=1) + # USDI.idx =cumprod(1 + na.omit(USDI.R)) + # USDI.Q.idx=to.quarterly(USDI.idx) + # USDI.Q.R=quarterlyReturn(Cl(USDI.Q.idx)) + # colnames(USDI.Q.R)<-"USD Index" + # index(USDI.Q.R) = as.Date(as.yearqtr(index(USDI.Q.R)), frac=1) ### Credit Spread # Yield spread of Merrill Lynch High-Yield Corporate Master II Index minus 10-year Treasury getSymbols("BAMLH0A0HYM2EY",src="FRED") -BAMLH0A0HYM2EY.M=Cl(to.monthly(BAMLH0A0HYM2EY)) -index(BAMLH0A0HYM2EY.M) = as.Date(as.yearmon(index(BAMLH0A0HYM2EY.M)), frac=1) + BAMLH0A0HYM2EY.M=Cl(to.monthly(BAMLH0A0HYM2EY)) + index(BAMLH0A0HYM2EY.M) = as.Date(as.yearmon(index(BAMLH0A0HYM2EY.M)), frac=1) CREDIT=(BAMLH0A0HYM2EY.M-GS10)/100 colnames(CREDIT)="Credit Spread" - CREDIT.Q=CREDIT[endpoints(CREDIT, on="quarters"),] - colnames(CREDIT.Q)="Credit Spread" + # CREDIT.Q=CREDIT[endpoints(CREDIT, on="quarters"),] + # colnames(CREDIT.Q)="Credit Spread" -### Liquidity? +### Liquidity getSymbols("TB3MS",src="FRED") index(TB3MS) = as.Date(as.yearmon(index(TB3MS)), frac=1) getSymbols("MED3",src="FRED") index(MED3) = as.Date(as.yearmon(index(MED3)), frac=1) TED=MED3/100-TB3MS/100 colnames(TED)="TED Spread" - TED.Q=TED[endpoints(TED, on="quarters"),] - colnames(TED.Q)="TED Spread" + # TED.Q=TED[endpoints(TED, on="quarters"),] + # colnames(TED.Q)="TED Spread" ### Real estate # Use the NAREIT index @@ -112,66 +111,71 @@ # Construct a monthly series from the daily series x.m.xts = to.monthly(x.xts) x.m.xts = ROC(Cl(x.m.xts)) # Calc monthly returns - x.q.xts = to.quarterly(x.xts) - x.q.xts = ROC(Cl(x.q.xts)) # Calc monthly returns + # x.q.xts = to.quarterly(x.xts) + # x.q.xts = ROC(Cl(x.q.xts)) # Calc monthly returns # @ TODO Want to delete the last line off ONLY IF the month is incomplete -# if(tail(index(x.xts),1) != as.Date(as.yearmon(tail(index(x.xts),1)), frac=1)) { - # That test isn't quite right, but its close. It won't work on the first - # day of a new month when the last business day wasn't the last day of - # the month. It will work for the second day. -# x.m.xts = x.m.xts[-dim(x.m.xts)[1],] -# } + # if(tail(index(x.xts),1) != as.Date(as.yearmon(tail(index(x.xts),1)), frac=1)) { + # That test isn't quite right, but its close. It won't work on the first + # day of a new month when the last business day wasn't the last day of + # the month. It will work for the second day. + # x.m.xts = x.m.xts[-dim(x.m.xts)[1],] + # } # Index is set to last trading day of the month. # Reset index to last day of the month to make alignment easier with other monthly series. index(x.m.xts)=as.Date(index(x.m.xts), frac=1) - index(x.q.xts)=as.Date(index(x.q.xts), frac=1) + # index(x.q.xts)=as.Date(index(x.q.xts), frac=1) DJUBS.R = x.m.xts - DJUBS.Q.R = x.q.xts + # DJUBS.Q.R = x.q.xts colnames(DJUBS.R)="DJUBSTR" - colnames(DJUBS.Q.R)="DJUBSTR" + # colnames(DJUBS.Q.R)="DJUBSTR" ### Volatility # as per Lo, the first difference of the end-of-month value of the CBOE Volatility Index (VIX) -# Older VIX data is available at: -# http://www.cboe.com/publish/ScheduledTask/MktData/datahouse/vixarchive.xls -# Daily from 1990-2003 + # Older VIX data is available at: + # http://www.cboe.com/publish/ScheduledTask/MktData/datahouse/vixarchive.xls + # Daily from 1990-2003 x= read.xls( "http://www.cboe.com/publish/ScheduledTask/MktData/datahouse/vixarchive.xls" ) ISOdates = as.Date(x[,1], "%m/%d/%y") # Get dates x.xts = as.xts(as.numeric(as.vector(x[,5])), order.by=ISOdates) x.m.xts = to.monthly(x.xts) - x.q.xts = to.quarterly(x.xts) + # x.q.xts = to.quarterly(x.xts) getSymbols("VIXCLS", src="FRED") # Calculate monthly returns VIX=to.monthly(VIXCLS) - VIX.Q=to.quarterly(VIXCLS) + # VIX.Q=to.quarterly(VIXCLS) VIX=rbind(x.m.xts,VIX) - VIX.Q=rbind(x.q.xts,VIX.Q) + # VIX.Q=rbind(x.q.xts,VIX.Q) index(VIX)=as.Date(index(VIX), frac=1) - index(VIX.Q)=as.Date(index(VIX.Q), frac=1) + # index(VIX.Q)=as.Date(index(VIX.Q), frac=1) dVIX=diff(Cl(VIX)) - dVIX.Q=diff(Cl(VIX.Q)) + # dVIX.Q=diff(Cl(VIX.Q)) colnames(dVIX)="dVIX" - colnames(dVIX.Q)="dVIX" + # colnames(dVIX.Q)="dVIX" ### Term spread # 10 year yield minus 3 month TERM = GS10/100-TB3MS/100 colnames(TERM)="Term Spread" - TERM.Q=TERM[endpoints(TERM, on="quarters"),] - colnames(TERM.Q)="Term Spread" + # TERM.Q=TERM[endpoints(TERM, on="quarters"),] + # colnames(TERM.Q)="Term Spread" ### Gold # Monthly return on gold spot price +# Fred London 3pm Fix: GOLDPMGBD228NLBM + getSymbols("GOLDPMGBD228NLBM",src="FRED") # daily series + GOLD=ROC(Cl(to.monthly(GOLDPMGBD228NLBM))) + index(GOLD) = as.Date(as.yearmon(index(GOLD)), frac=1) + ### Oil # Monthly returns of spot price of West Texas Intermediate getSymbols("OILPRICE", src="FRED") index(OILPRICE) = as.Date(as.yearmon(index(OILPRICE)), frac=1) OIL.R = ROC(OILPRICE) - OIL.Q.R = ROC(Cl(to.quarterly(OILPRICE))) - index(OIL.Q.R) = as.Date(as.yearqtr(index(OIL.Q.R)), frac=1) + # OIL.Q.R = ROC(Cl(to.quarterly(OILPRICE))) + # index(OIL.Q.R) = as.Date(as.yearqtr(index(OIL.Q.R)), frac=1) ### PUT system("wget https://www.cboe.com/micro/put/PUT_86-06.xls") @@ -194,13 +198,13 @@ # need to drop the last row if inter-month -lastquarter=format(as.Date(as.yearqtr(Sys.Date())-.25, frac=1), "%Y-%m") +# lastquarter=format(as.Date(as.yearqtr(Sys.Date())-.25, frac=1), "%Y-%m") factors=cbind(SP500.R, GS10.R, USDI.R, TERM, CREDIT, DJUBS.R, dVIX, TED, OIL.R, TB3MS/100) factors=factors["1997::",] -factors.Q=cbind(SP500.Q.R, GS10.Q.R, USDI.Q.R, TERM.Q, CREDIT.Q, DJUBS.Q.R, dVIX.Q, TED.Q, OIL.Q.R, TB3MS[endpoints(TB3MS, on="quarters"),]/100) -factors.Q=factors.Q[paste("1997::",lastquarter,sep=""),] +# factors.Q=cbind(SP500.Q.R, GS10.Q.R, USDI.Q.R, TERM.Q, CREDIT.Q, DJUBS.Q.R, dVIX.Q, TED.Q, OIL.Q.R, TB3MS[endpoints(TB3MS, on="quarters"),]/100) +# factors.Q=factors.Q[paste("1997::",lastquarter,sep=""),] asofdate= tail(index(factors),1) labels=colnames(factors) From noreply at r-forge.r-project.org Tue Dec 10 00:26:24 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 10 Dec 2013 00:26:24 +0100 (CET) Subject: [Returnanalytics-commits] r3271 - pkg/PortfolioAnalytics/sandbox Message-ID: <20131209232625.0EB5A1869A3@r-forge.r-project.org> Author: peter_carl Date: 2013-12-10 00:26:24 +0100 (Tue, 10 Dec 2013) New Revision: 3271 Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R Log: - added NAREIT index as real estate proxy Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:22:55 UTC (rev 3270) +++ pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:26:24 UTC (rev 3271) @@ -85,6 +85,10 @@ ### Real estate # Use the NAREIT index + x = read.xls("http://returns.reit.com/returns/MonthlyHistoricalReturns.xls", pattern="Date", sheet="Index Data", stringsAsFactors=FALSE) + x.dates = as.Date(as.yearmon(x[,1], format="%b-%y"), frac=1) + REALESTATE.R = xts(x[,2]/100, order.by = x.dates) + colnames(REALESTATE.R) = "NAREIT Returns" ### Commodities ## Use the DJUBS Commodities index From noreply at r-forge.r-project.org Tue Dec 10 00:43:33 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 10 Dec 2013 00:43:33 +0100 (CET) Subject: [Returnanalytics-commits] r3272 - pkg/PortfolioAnalytics/sandbox Message-ID: <20131209234333.2E191184612@r-forge.r-project.org> Author: peter_carl Date: 2013-12-10 00:43:32 +0100 (Tue, 10 Dec 2013) New Revision: 3272 Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R Log: - cleaned up quarterly comments - cleaned up DJUBS download Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:26:24 UTC (rev 3271) +++ pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:43:32 UTC (rev 3272) @@ -13,9 +13,8 @@ require(RQuantLib) Sys.setenv(TZ="GMT") -## Factor set of several commonly used factors +## Set up required directory structure -# @TODO: Find a better source for VIX ### Equities # Download the first sheet in the xls workbook directly from the S&P web site: @@ -24,10 +23,11 @@ rawreturns = x[-1:-4,12] ISOdates = as.Date(as.yearmon(rawdates, "%m/%Y"), frac=1) totalreturns = as.numeric(as.character((sub("%", "", rawreturns, fixed=TRUE))))/100 - SP500.TR=na.omit(as.xts(totalreturns, order.by=ISOdates)) - colnames(SP500.TR)="SP500TR" + SP500.R=na.omit(as.xts(totalreturns, order.by=ISOdates)) + colnames(SP500.R)="SP500TR" # see parse.SP500TR.R in the FinancialInstrument package's inst/parsers directory for more detail + ### Bonds # Calculate total returns from the yeild of the 10 year constant maturity index maintained by the Fed getSymbols("GS10", src="FRED") #load US Treasury 10y yields from FRED @@ -39,16 +39,13 @@ for (i in 1:(NROW(GS10)-1)) { GS10.pr[i+1,1] <- FixedRateBondPriceByYield(yield=GS10[i+1,1]/100, issueDate=Sys.Date(), maturityDate=advance("UnitedStates/GovernmentBond", Sys.Date(), 10, 3), rates=GS10[i,1]/100,period=2)[1]/100-1 } - #total return will be the price return + yield/12 for one month + # total return will be the price return + yield/12 for one month GS10.R <- GS10.pr + lag(GS10,k=1)/12/100 colnames(GS10.R)<-"GS10TR" - # GS10.idx =cumprod(1 + na.omit(GS10.R)) - # GS10.Q.idx=to.quarterly(GS10.idx) - # GS10.Q.R=quarterlyReturn(Cl(GS10.Q.idx)) - # colnames(GS10.Q.R)<-"GS10TR" - # index(GS10.Q.R) = as.Date(as.yearqtr(index(GS10.Q.R)), frac=1) + #@TODO: Calc the same for 2y and 5y + ### Currencies # Trade Weighted U.S. Dollar Index: Major Currencies - TWEXMMTH getSymbols("TWEXMMTH", src="FRED") # index values @@ -57,11 +54,6 @@ USDI.R=ROC(TWEXMMTH) colnames(USDI.R)="USD Index" - # USDI.idx =cumprod(1 + na.omit(USDI.R)) - # USDI.Q.idx=to.quarterly(USDI.idx) - # USDI.Q.R=quarterlyReturn(Cl(USDI.Q.idx)) - # colnames(USDI.Q.R)<-"USD Index" - # index(USDI.Q.R) = as.Date(as.yearqtr(index(USDI.Q.R)), frac=1) ### Credit Spread # Yield spread of Merrill Lynch High-Yield Corporate Master II Index minus 10-year Treasury @@ -70,9 +62,8 @@ index(BAMLH0A0HYM2EY.M) = as.Date(as.yearmon(index(BAMLH0A0HYM2EY.M)), frac=1) CREDIT=(BAMLH0A0HYM2EY.M-GS10)/100 colnames(CREDIT)="Credit Spread" - # CREDIT.Q=CREDIT[endpoints(CREDIT, on="quarters"),] - # colnames(CREDIT.Q)="Credit Spread" + ### Liquidity getSymbols("TB3MS",src="FRED") index(TB3MS) = as.Date(as.yearmon(index(TB3MS)), frac=1) @@ -80,9 +71,8 @@ index(MED3) = as.Date(as.yearmon(index(MED3)), frac=1) TED=MED3/100-TB3MS/100 colnames(TED)="TED Spread" - # TED.Q=TED[endpoints(TED, on="quarters"),] - # colnames(TED.Q)="TED Spread" + ### Real estate # Use the NAREIT index x = read.xls("http://returns.reit.com/returns/MonthlyHistoricalReturns.xls", pattern="Date", sheet="Index Data", stringsAsFactors=FALSE) @@ -90,6 +80,7 @@ REALESTATE.R = xts(x[,2]/100, order.by = x.dates) colnames(REALESTATE.R) = "NAREIT Returns" + ### Commodities ## Use the DJUBS Commodities index # Remove the old file if it exists @@ -101,39 +92,19 @@ system("wget http://www.djindexes.com/mdsidx/downloads/xlspages/ubsci_public/DJUBS_full_hist.xls") if(!file.exists("DJUBS_full_hist.xls")) stop(paste("No spreadsheet exists. Download the spreadsheet to be processed from www.djindexes.com into ", filesroot, "/.incoming", sep="")) - - # Parse the spreadsheet print("Reading sheet... This will take a moment...") x = read.xls("DJUBS_full_hist.xls", sheet="Total Return") x=x[-1:-2,] # Get rid of the headings x=x[-dim(x)[1],] # Get rid of the last line, which contains the disclaimer ISOdates = as.Date(x[,1], "%m/%d/%Y") # Get dates - - # Make an xts object of prices x.xts = as.xts(as.numeric(as.vector(x[,2])), order.by=ISOdates) - - # Construct a monthly series from the daily series x.m.xts = to.monthly(x.xts) x.m.xts = ROC(Cl(x.m.xts)) # Calc monthly returns - # x.q.xts = to.quarterly(x.xts) - # x.q.xts = ROC(Cl(x.q.xts)) # Calc monthly returns - # @ TODO Want to delete the last line off ONLY IF the month is incomplete - # if(tail(index(x.xts),1) != as.Date(as.yearmon(tail(index(x.xts),1)), frac=1)) { - # That test isn't quite right, but its close. It won't work on the first - # day of a new month when the last business day wasn't the last day of - # the month. It will work for the second day. - # x.m.xts = x.m.xts[-dim(x.m.xts)[1],] - # } - - # Index is set to last trading day of the month. - # Reset index to last day of the month to make alignment easier with other monthly series. index(x.m.xts)=as.Date(index(x.m.xts), frac=1) - # index(x.q.xts)=as.Date(index(x.q.xts), frac=1) DJUBS.R = x.m.xts - # DJUBS.Q.R = x.q.xts colnames(DJUBS.R)="DJUBSTR" - # colnames(DJUBS.Q.R)="DJUBSTR" + ### Volatility # as per Lo, the first difference of the end-of-month value of the CBOE Volatility Index (VIX) @@ -158,6 +129,7 @@ colnames(dVIX)="dVIX" # colnames(dVIX.Q)="dVIX" + ### Term spread # 10 year yield minus 3 month TERM = GS10/100-TB3MS/100 @@ -165,6 +137,7 @@ # TERM.Q=TERM[endpoints(TERM, on="quarters"),] # colnames(TERM.Q)="Term Spread" + ### Gold # Monthly return on gold spot price # Fred London 3pm Fix: GOLDPMGBD228NLBM @@ -177,39 +150,34 @@ # Monthly returns of spot price of West Texas Intermediate getSymbols("OILPRICE", src="FRED") index(OILPRICE) = as.Date(as.yearmon(index(OILPRICE)), frac=1) - OIL.R = ROC(OILPRICE) - # OIL.Q.R = ROC(Cl(to.quarterly(OILPRICE))) - # index(OIL.Q.R) = as.Date(as.yearqtr(index(OIL.Q.R)), frac=1) + ### PUT -system("wget https://www.cboe.com/micro/put/PUT_86-06.xls") -x = read.xls("PUT_86-06.xls") -x=na.omit(x[-1:-4,1:2]) -ISOdates = as.Date(x[,1], "%d-%b-%Y") # Get dates -PUT1 = xts(as.numeric(as.vector(x[,2])), order.by=ISOdates) +# Monthly returns of PUT Index + # Retrieve in two pieces; first the historical from 1986 to 2006 + system("wget https://www.cboe.com/micro/put/PUT_86-06.xls") + x = read.xls("PUT_86-06.xls") + x=na.omit(x[-1:-4,1:2]) + ISOdates = as.Date(x[,1], "%d-%b-%Y") # Get dates + PUT1 = xts(as.numeric(as.vector(x[,2])), order.by=ISOdates) + # Next is current from 2007 on + system("wget https://www.cboe.com/publish/ScheduledTask/MktData/datahouse/PUTDailyPrice.csv") + y=read.csv("PUTDailyPrice.csv") + y=y[-1:-4,] + ISOdates = as.Date(y[,1], "%m/%d/%Y") # Get dates + PUT2 = xts(as.numeric(as.vector(y[,2])), order.by=ISOdates) + # Combine the two series + PUT = rbind(PUT1,PUT2) + colnames(PUT)="Close" + PUT = ROC(Cl(to.monthly(PUT))) + index(PUT) = as.Date(as.yearmon(index(PUT)), frac=1) + # need to drop the last row if inter-month -system("wget https://www.cboe.com/publish/ScheduledTask/MktData/datahouse/PUTDailyPrice.csv") -y=read.csv("PUTDailyPrice.csv") -y=y[-1:-4,] -ISOdates = as.Date(y[,1], "%m/%d/%Y") # Get dates -PUT2 = xts(as.numeric(as.vector(y[,2])), order.by=ISOdates) - -PUT = rbind(PUT1,PUT2) -colnames(PUT)="Close" -PUT = ROC(Cl(to.monthly(PUT))) -index(PUT) = as.Date(as.yearmon(index(PUT)), frac=1) -# need to drop the last row if inter-month - - -# lastquarter=format(as.Date(as.yearqtr(Sys.Date())-.25, frac=1), "%Y-%m") - - -factors=cbind(SP500.R, GS10.R, USDI.R, TERM, CREDIT, DJUBS.R, dVIX, TED, OIL.R, TB3MS/100) +factors=cbind(SP500.R, GS10.R, USDI.R, TERM, CREDIT, DJUBS.R, dVIX, TED, OIL.R, TB3MS/100) # GOLD.R, REALESTATE.R factors=factors["1997::",] -# factors.Q=cbind(SP500.Q.R, GS10.Q.R, USDI.Q.R, TERM.Q, CREDIT.Q, DJUBS.Q.R, dVIX.Q, TED.Q, OIL.Q.R, TB3MS[endpoints(TB3MS, on="quarters"),]/100) -# factors.Q=factors.Q[paste("1997::",lastquarter,sep=""),] +## Create a chart of the factor set asofdate= tail(index(factors),1) labels=colnames(factors) pdf(file=paste("Cumulative Factor Returns as of ", asofdate, ".pdf", sep=""), paper="letter", width=7.5, height=10) From noreply at r-forge.r-project.org Tue Dec 10 00:44:03 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 10 Dec 2013 00:44:03 +0100 (CET) Subject: [Returnanalytics-commits] r3273 - pkg/PortfolioAnalytics/sandbox Message-ID: <20131209234403.0F0FC1846EB@r-forge.r-project.org> Author: peter_carl Date: 2013-12-10 00:44:02 +0100 (Tue, 10 Dec 2013) New Revision: 3273 Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R Log: - cleaned up DJUBS download Modified: pkg/PortfolioAnalytics/sandbox/script.buildFactors.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:43:32 UTC (rev 3272) +++ pkg/PortfolioAnalytics/sandbox/script.buildFactors.R 2013-12-09 23:44:02 UTC (rev 3273) @@ -83,17 +83,7 @@ ### Commodities ## Use the DJUBS Commodities index - # Remove the old file if it exists - if(file.exists("DJUBS_full_hist.xls")) - system("rm DJUBS_full_hist.xls") - # Download the most recent file - print("Downloading excel spreadsheet from DJUBS web site...") - # Can't get it directly, sorry windows users - system("wget http://www.djindexes.com/mdsidx/downloads/xlspages/ubsci_public/DJUBS_full_hist.xls") - if(!file.exists("DJUBS_full_hist.xls")) - stop(paste("No spreadsheet exists. Download the spreadsheet to be processed from www.djindexes.com into ", filesroot, "/.incoming", sep="")) - print("Reading sheet... This will take a moment...") - x = read.xls("DJUBS_full_hist.xls", sheet="Total Return") + x = read.xls("http://www.djindexes.com/mdsidx/downloads/xlspages/ubsci_public/DJUBS_full_hist.xls", sheet="Total Return") x=x[-1:-2,] # Get rid of the headings x=x[-dim(x)[1],] # Get rid of the last line, which contains the disclaimer ISOdates = as.Date(x[,1], "%m/%d/%Y") # Get dates @@ -107,7 +97,6 @@ ### Volatility # as per Lo, the first difference of the end-of-month value of the CBOE Volatility Index (VIX) - # Older VIX data is available at: # http://www.cboe.com/publish/ScheduledTask/MktData/datahouse/vixarchive.xls # Daily from 1990-2003 @@ -115,27 +104,19 @@ ISOdates = as.Date(x[,1], "%m/%d/%y") # Get dates x.xts = as.xts(as.numeric(as.vector(x[,5])), order.by=ISOdates) x.m.xts = to.monthly(x.xts) - # x.q.xts = to.quarterly(x.xts) getSymbols("VIXCLS", src="FRED") # Calculate monthly returns VIX=to.monthly(VIXCLS) - # VIX.Q=to.quarterly(VIXCLS) VIX=rbind(x.m.xts,VIX) - # VIX.Q=rbind(x.q.xts,VIX.Q) index(VIX)=as.Date(index(VIX), frac=1) - # index(VIX.Q)=as.Date(index(VIX.Q), frac=1) dVIX=diff(Cl(VIX)) - # dVIX.Q=diff(Cl(VIX.Q)) colnames(dVIX)="dVIX" - # colnames(dVIX.Q)="dVIX" ### Term spread # 10 year yield minus 3 month TERM = GS10/100-TB3MS/100 colnames(TERM)="Term Spread" - # TERM.Q=TERM[endpoints(TERM, on="quarters"),] - # colnames(TERM.Q)="Term Spread" ### Gold From noreply at r-forge.r-project.org Sat Dec 14 19:50:44 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 14 Dec 2013 19:50:44 +0100 (CET) Subject: [Returnanalytics-commits] r3274 - pkg/PortfolioAnalytics/R Message-ID: <20131214185044.B1989186AE6@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-14 19:50:44 +0100 (Sat, 14 Dec 2013) New Revision: 3274 Modified: pkg/PortfolioAnalytics/R/optFUN.R Log: Modifying optFUN to use ROI Modified: pkg/PortfolioAnalytics/R/optFUN.R =================================================================== --- pkg/PortfolioAnalytics/R/optFUN.R 2013-12-09 23:44:02 UTC (rev 3273) +++ pkg/PortfolioAnalytics/R/optFUN.R 2013-12-14 18:50:44 UTC (rev 3274) @@ -13,16 +13,16 @@ #' @param conc_groups list of vectors specifying the groups of the assets. #' @author Ross Bennett gmv_opt <- function(R, constraints, moments, lambda, target, lambda_hhi, conc_groups){ - stopifnot("package:quadprog" %in% search() || require("quadprog",quietly = TRUE)) - # stopifnot("package:ROI" %in% search() || require("ROI",quietly = TRUE)) - # stopifnot("package:ROI.plugin.quadprog" %in% search() || require("ROI.plugin.quadprog",quietly = TRUE)) + stopifnot("package:ROI" %in% search() || require("ROI", quietly = TRUE)) + stopifnot("package:ROI.plugin.quadprog" %in% search() || require("ROI.plugin.quadprog", quietly = TRUE)) + # Check for cleaned returns in moments + if(!is.null(moments$cleanR)) R <- moments$cleanR + + # Number of assets N <- ncol(R) - # Applying box constraints, used for ROI - # bnds <- list(lower=list(ind=seq.int(1L, N), val=as.numeric(constraints$min)), - # upper=list(ind=seq.int(1L, N), val=as.numeric(constraints$max))) - # check for a target return constraint + # 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)){ @@ -35,26 +35,26 @@ target <- 0 } Amat <- tmp_means - # dir.vec <- "==" + dir.vec <- "==" rhs.vec <- target meq <- 1 - # set up initial A matrix for leverage constraints + # Set up initial A matrix for leverage constraints Amat <- rbind(Amat, rep(1, N), rep(-1, N)) - # dir.vec <- c(dir.vec, ">=",">=") + dir.vec <- c(dir.vec, ">=",">=") rhs.vec <- c(rhs.vec, constraints$min_sum, -constraints$max_sum) # Add min box constraints Amat <- rbind(Amat, diag(N)) - # dir.vec <- c(dir.vec, rep(">=", N)) + dir.vec <- c(dir.vec, rep(">=", N)) rhs.vec <- c(rhs.vec, constraints$min) # Add max box constraints Amat <- rbind(Amat, -1*diag(N)) - # dir.vec <- c(dir.vec, rep(">=", N)) + dir.vec <- c(dir.vec, rep(">=", N)) rhs.vec <- c(rhs.vec, -constraints$max) - # include group constraints + # Include group constraints if(try(!is.null(constraints$groups), silent=TRUE)){ n.groups <- length(constraints$groups) Amat.group <- matrix(0, nrow=n.groups, ncol=N) @@ -64,7 +64,7 @@ if(is.null(constraints$cLO)) cLO <- rep(-Inf, n.groups) if(is.null(constraints$cUP)) cUP <- rep(Inf, n.groups) Amat <- rbind(Amat, Amat.group, -Amat.group) - # dir.vec <- c(dir.vec, rep(">=", (n.groups + n.groups))) + dir.vec <- c(dir.vec, rep(">=", (n.groups + n.groups))) rhs.vec <- c(rhs.vec, constraints$cLO, -constraints$cUP) } @@ -72,7 +72,7 @@ if(!is.null(constraints$B)){ t.B <- t(constraints$B) Amat <- rbind(Amat, t.B, -t.B) - # dir.vec <- c(dir.vec, rep(">=", 2 * nrow(t.B))) + dir.vec <- c(dir.vec, rep(">=", 2 * nrow(t.B))) rhs.vec <- c(rhs.vec, constraints$lower, -constraints$upper) } @@ -87,12 +87,12 @@ Amat <- Amat[!is.infinite(rhs.vec), ] rhs.vec <- rhs.vec[!is.infinite(rhs.vec)] - # set up the quadratic objective + # Set up the quadratic objective if(!is.null(lambda_hhi)){ if(length(lambda_hhi) == 1 & is.null(conc_groups)){ - # ROI_objective <- Q_objective(Q=2*lambda*(moments$var + lambda_hhi * diag(N)), L=-moments$mean) # ROI - Dmat <- 2*lambda*(moments$var + lambda_hhi * diag(N)) # solve.QP - dvec <- moments$mean # solve.QP + ROI_objective <- Q_objective(Q=2*lambda*(moments$var + lambda_hhi * diag(N)), L=-moments$mean) # ROI + #Dmat <- 2*lambda*(moments$var + lambda_hhi * diag(N)) # solve.QP + #dvec <- moments$mean # solve.QP } else if(!is.null(conc_groups)){ # construct the matrix with concentration aversion values by group hhi_mat <- matrix(0, nrow=N, ncol=N) @@ -106,29 +106,28 @@ } hhi_mat <- hhi_mat + lambda_hhi[i] * tmpI } - # ROI_objective <- Q_objective(Q=2*lambda*(moments$var + hhi_mat), L=-moments$mean) # ROI - Dmat <- 2 * lambda * (moments$var + hhi_mat) # solve.QP - dvec <- moments$mean # solve.QP + ROI_objective <- Q_objective(Q=2*lambda*(moments$var + hhi_mat), L=-moments$mean) # ROI + #Dmat <- 2 * lambda * (moments$var + hhi_mat) # solve.QP + #dvec <- moments$mean # solve.QP } } else { - # ROI_objective <- Q_objective(Q=2*lambda*moments$var, L=-moments$mean) # ROI - Dmat <- 2 * lambda * moments$var # solve.QP - dvec <- moments$mean # solve.QP + ROI_objective <- Q_objective(Q=2*lambda*moments$var, L=-moments$mean) # ROI + #Dmat <- 2 * lambda * moments$var # solve.QP + #dvec <- moments$mean # solve.QP } # 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="quadprog") + opt.prob <- OP(objective=ROI_objective, + constraints=L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec)) + result <- ROI_solve(x=opt.prob, solver="quadprog") - result <- try(solve.QP(Dmat=Dmat, dvec=dvec, Amat=t(Amat), bvec=rhs.vec, meq=meq), silent=TRUE) + # result <- try(solve.QP(Dmat=Dmat, dvec=dvec, Amat=t(Amat), bvec=rhs.vec, meq=meq), silent=TRUE) if(inherits(x=result, "try-error")) stop(paste("No solution found:", result)) weights <- result$solution[1:N] names(weights) <- colnames(R) out <- list() out$weights <- weights - out$out <- result$value + out$out <- result$objval obj_vals <- list() # Calculate the objective values here so that we can use the moments$mean # and moments$var that might be passed in by the user. This will avoid @@ -165,6 +164,9 @@ stopifnot("package:ROI" %in% search() || require("ROI",quietly = TRUE)) stopifnot("package:ROI.plugin.glpk" %in% search() || require("ROI.plugin.glpk",quietly = TRUE)) + # Check for cleaned returns in moments + if(!is.null(moments$cleanR)) R <- moments$cleanR + N <- ncol(R) # Applying box constraints # maxret_opt needs non infinite values for upper and lower bounds @@ -176,8 +178,8 @@ ub[is.infinite(ub)] <- max(abs(c(constraints$min_sum, constraints$max_sum))) lb[is.infinite(lb)] <- 0 } - bnds <- list(lower=list(ind=seq.int(1L, N), val=as.numeric(lb)), - upper=list(ind=seq.int(1L, N), val=as.numeric(ub))) + bnds <- V_bound(li=seq.int(1L, N), lb=as.numeric(lb), + ui=seq.int(1L, N), ub=as.numeric(ub)) # set up initial A matrix for leverage constraints Amat <- rbind(rep(1, N), rep(1, N)) @@ -262,110 +264,111 @@ #' @param target target return value #' @author Ross Bennett maxret_milp_opt <- function(R, constraints, moments, target){ - stopifnot("package:Rglpk" %in% search() || require("Rglpk",quietly = TRUE)) + stopifnot("package:ROI" %in% search() || require("ROI",quietly = TRUE)) + stopifnot("package:ROI.plugin.glpk" %in% search() || require("ROI.plugin.glpk",quietly = TRUE)) + # Check for cleaned returns in moments + if(!is.null(moments$cleanR)) R <- moments$cleanR + + # Number of assets N <- ncol(R) - # position limit constraint + # Maximum number of positions (non-zero weights) max_pos <- constraints$max_pos - if(is.null(max_pos)) max_pos <- N + min_pos <- 1 - # leverage exposure constraint - leverage <- constraints$leverage - if(is.null(leverage)) leverage <- 1 - - # upper and lower bounds for box constraints on weights + # Upper and lower bounds on weights LB <- as.numeric(constraints$min) UB <- as.numeric(constraints$max) - # The leverage exposure constraint splits the weights into long weights and short weights - - # Add weight sum constraint - Amat <- rbind(c(rep(1, N), rep(-1, N), rep(0, N)), - c(rep(1, N), rep(-1, N), rep(0, N))) - dir <- c("<=", ">=") - rhs <- c(constraints$max_sum, constraints$min_sum) - - # Add leverage exposure constraint - Amat <- rbind(Amat, c(rep(1, 2*N), rep(0, N))) - dir <- c(dir, "==") - rhs <- c(rhs, leverage) - - # Add target return + # Check for target return if(!is.na(target)){ - tmp_mean <- moments$mean + # 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 { - tmp_mean <- rep(0, N) - target <- 0 + # No target specified, just maximize + targetcon <- NULL + targetdir <- NULL + targetrhs <- NULL } - Amat <- rbind(Amat, c(tmp_mean, -1 * tmp_mean, rep(0, N))) - dir <- c(dir, "==") - rhs <- c(rhs, target) - # Add constraints for long and short weights - Amat <- rbind(Amat, cbind(diag(2*N), rbind(-1 * diag(N), diag(N)))) - dir <- c(dir, rep("<=", 2*N)) - rhs <- c(rhs, rep(0, N), rep(1, N)) + # weight_sum constraint + Amat <- rbind(c(rep(1, N), rep(0, N)), + c(rep(1, N), rep(0, N))) - # Add factor_exposure constraints + # 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) + + # Include group constraints + if(try(!is.null(constraints$groups), silent=TRUE)){ + n.groups <- length(constraints$groups) + Amat.group <- matrix(0, nrow=n.groups, ncol=N) + k <- 1 + l <- 0 + for(i in 1:n.groups){ + j <- constraints$groups[i] + Amat.group[i, k:(l+j)] <- 1 + k <- l + j + 1 + l <- k - 1 + } + if(is.null(constraints$cLO)) cLO <- rep(-Inf, n.groups) + if(is.null(constraints$cUP)) cUP <- rep(Inf, n.groups) + zeros <- matrix(data=0, nrow=nrow(Amat.group), ncol=ncol(Amat.group)) + Amat <- rbind(Amat, cbind(Amat.group, zeros), cbind(-Amat.group, zeros)) + dir <- c(dir, rep(">=", (n.groups + n.groups))) + rhs <- c(rhs, constraints$cLO, -constraints$cUP) + } + + # Add the factor exposures to Amat, dir, and rhs if(!is.null(constraints$B)){ - t.B <- t(constraints$B) + t.B <- t(B) zeros <- matrix(data=0, nrow=nrow(t.B), ncol=ncol(t.B)) - Amat <- rbind(Amat, cbind(t.B, -t.B, zeros)) - Amat <- rbind(Amat, cbind(t.B, -t.B, zeros)) - dir <- c(dir, ">=", "<=") - rhs <- c(rhs, constraints$lower, constraints$upper) + Amat <- rbind(Amat, cbind(t.B, zeros), cbind(-t.B, zeros)) + dir <- c(dir, rep(">=", 2 * nrow(t.B))) + rhs <- c(rhs, constraints$lower, -constraints$upper) } - # include group constraints - if(!is.null(constraints$groups)){ - n.groups <- length(constraints$groups) - Amat.group <- matrix(0, nrow=n.groups, ncol=N) - for(i in 1:n.groups){ - Amat.group[i, constraints$groups[[i]]] <- 1 - } - zeros <- matrix(data=0, nrow=nrow(Amat.group), ncol=ncol(Amat.group)) - Amat <- rbind(Amat, cbind(Amat.group, -Amat.group, zeros)) - Amat <- rbind(Amat, cbind(Amat.group, -Amat.group, zeros)) - dir <- c(dir, rep(">=", n.groups), rep("<=", n.groups)) - rhs <- c(rhs, constraints$cLO, constraints$cUP) - } + # Only seems to work if I do not specify bounds + # bnds <- V_bound(li=seq.int(1L, 2*m), lb=c(as.numeric(constraints$min), rep(0, m)), + # ui=seq.int(1L, 2*m), ub=c(as.numeric(constraints$max), rep(1, m))) + bnds <- NULL - # Add position limit constraint - zeros <- matrix(data=0, nrow=nrow(Amat), ncol=N) - Amat <- cbind(Amat, zeros) - Amat <- rbind(Amat, c(rep(0, 3*N), rep(1, N))) - dir <- c(dir, "<=") - rhs <- c(rhs, max_pos) + # Set up the types vector with continuous and binary variables + types <- c(rep("C", N), rep("B", N)) - # Bounds on the weights - bnds <- list(lower=list(ind=seq.int(1L, ncol(Amat)), val=rep(0, ncol(Amat))), - upper=list(ind=seq.int(1L, ncol(Amat)), val=c(UB, abs(LB), rep(1, 2*N)))) + # Set up the linear objective to maximize mean return + ROI_objective <- L_objective(L=c(-moments$mean, rep(0, N))) - # Objective function - objL <- c(moments$mean, rep(0, 3*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 <- try(ROI_solve(x=opt.prob, solver="glpk"), silent=TRUE) + if(inherits(roi.result, "try-error")) stop(paste("No solution found:", roi.result)) - # Set the types of variables (Continuous and Binary) - types <- c(rep("C", 2*N), rep("B", 2*N)) - - # Run the optimization - result <- try(Rglpk_solve_LP(obj=objL, mat=Amat, dir=dir, rhs=rhs, types=types, bounds=bnds, max=TRUE), silent=TRUE) - if(inherits(result, "try-error")) stop(paste("No solution found:", result)) - - long_weights <- result$solution[1:N] - short_weights <- result$solution[(N+1):(2*N)] - weights <- long_weights - short_weights + # Weights + weights <- roi.result$solution[1:N] names(weights) <- colnames(R) + # The out object is returned out <- list() out$weights <- weights - out$out <- result$optimum - obj_vals <- list() - # Calculate the objective values here so that we can use the moments$mean - # that might be passed in by the user. This will avoid - # the extra call to constrained_objective + out$out <- roi.result$objval - port.mean <- -result$optimum + obj_vals <- list() + port.mean <- -roi.result$objval names(port.mean) <- "mean" obj_vals[["mean"]] <- port.mean out$obj_vals <- obj_vals @@ -463,7 +466,6 @@ obj_vals[[es_names[es_idx]]] <- port.es } out$obj_vals <- obj_vals - #out$call <- call # add this outside of here, this function doesn't have the call return(out) } @@ -479,9 +481,9 @@ #' @param alpha alpha value for ETL/ES/CVaR #' @author Ross Bennett etl_milp_opt <- function(R, constraints, moments, target, alpha){ + stopifnot("package:ROI" %in% search() || require("ROI",quietly = TRUE)) + stopifnot("package:ROI.plugin.glpk" %in% search() || require("ROI.plugin.glpk",quietly = TRUE)) - stopifnot("package:Rglpk" %in% search() || require("Rglpk",quietly = TRUE)) - # Check for cleaned returns in moments if(!is.null(moments$cleanR)) R <- moments$cleanR @@ -496,6 +498,7 @@ 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. @@ -537,14 +540,15 @@ # 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))) - + # Add rows 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), max_pos) + 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), "==") + dir <- c( rep("<=", n), ">=", "<=", targetdir, rep("<=", 2*m), "<=", "<=") if(try(!is.null(constraints$groups), silent=TRUE)){ n.groups <- length(constraints$groups) @@ -570,49 +574,51 @@ } # Linear objective vector - objL <- c( rep(0, m), 1, rep(1/n, n) / alpha, 0, rep(0, m)) + ROI_objective <- L_objective(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)) ) ) + 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))) + # Set up the optimization problem and solve + 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") - result <- Rglpk_solve_LP(obj=objL, mat=tmpAmat, dir=dir, rhs=rhs, types=types, bounds=bounds) # The Rglpk solvers status returns an an integer with status information # about the solution returned: 0 if the optimal solution was found, a #non-zero value otherwise. - if(result$status != 0) { + if(roi.result$status$code != 0) { message("Undefined Solution") return(NULL) } - weights <- result$solution[1:m] + weights <- roi.result$solution[1:m] names(weights) <- colnames(R) out <- list() out$weights <- weights - out$out <- result$optimum + out$out <- roi.result$objval es_names <- c("ES", "ETL", "CVaR") es_idx <- which(es_names %in% names(moments)) obj_vals <- list() # Calculate the objective values here so that we can use the moments$mean - # and moments$var that might be passed in by the user. This will avoid - # the extra call to constrained_objective + # and moments$var that might be passed in by the user. if(!all(moments$mean == 0)){ port.mean <- as.numeric(sum(weights * moments$mean)) names(port.mean) <- "mean" obj_vals[["mean"]] <- port.mean - port.es <- result$optimum + port.es <- roi.result$objval names(port.es) <- es_names[es_idx] obj_vals[[es_names[es_idx]]] <- port.es } else { - port.es <- result$optimum + port.es <- roi.result$objval names(port.es) <- es_names[es_idx] obj_vals[[es_names[es_idx]]] <- port.es } out$obj_vals <- obj_vals - #out$call <- call # add this outside of here, this function doesn't have the call return(out) } @@ -631,7 +637,8 @@ gmv_opt_toc <- function(R, constraints, moments, lambda, target, init_weights){ # function for minimum variance or max quadratic utility problems stopifnot("package:corpcor" %in% search() || require("corpcor",quietly = TRUE)) - stopifnot("package:quadprog" %in% search() || require("quadprog",quietly = TRUE)) + stopifnot("package:ROI" %in% search() || require("ROI", quietly = TRUE)) + stopifnot("package:ROI.plugin.quadprog" %in% search() || require("ROI.plugin.quadprog", quietly = TRUE)) # Check for cleaned returns in moments if(!is.null(moments$cleanR)) R <- moments$cleanR @@ -727,36 +734,32 @@ rhs <- c(rhs, constraints$lower, -constraints$upper) } - d <- rep(moments$mean, 3) - # Remove the rows of Amat and elements of rhs.vec where rhs is Inf or -Inf Amat <- Amat[!is.infinite(rhs), ] rhs <- rhs[!is.infinite(rhs)] - # print("Amat") - # print(Amat) - # print("rhs") - # print(rhs) - # print("d") - # print(d) - qp.result <- try(solve.QP(Dmat=make.positive.definite(2*lambda*V), - dvec=d, Amat=t(Amat), bvec=rhs, meq=meq), silent=TRUE) - if(inherits(qp.result, "try-error")) stop(paste("No solution found:", qp.result)) + dir <- dir[!is.infinite(rhs)] - wts <- qp.result$solution - # print(round(wts,4)) - wts.final <- wts[(1:N)] - # wts.buy <- wts[(1+N):(2*N)] - # wts.sell <- wts[(2*N+1):(3*N)] + 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 <- try(ROI_solve(x=opt.prob, solver="quadprog"), silent=TRUE) + + if(inherits(roi.result, "try-error")) stop(paste("No solution found:", roi.result)) + + wts <- roi.result$solution + wts.final <- wts[1:N] + weights <- wts.final names(weights) <- colnames(R) out <- list() out$weights <- weights - out$out <- qp.result$value + out$out <- roi.result$value obj_vals <- list() # Calculate the objective values here so that we can use the moments$mean - # and moments$var that might be passed in by the user. This will avoid - # the extra call to constrained_objective + # and moments$var that might be passed in by the user. if(!all(moments$mean == 0)){ port.mean <- as.numeric(sum(weights * moments$mean)) names(port.mean) <- "mean" @@ -771,25 +774,15 @@ } out$obj_vals <- obj_vals return(out) - - # TODO - # Get this working with ROI - - # Not getting solution using ROI - # set up the quadratic objective - # ROI_objective <- Q_objective(Q=make.positive.definite(2*lambda*V), L=rep(-moments$mean, 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") } # proportional transaction cost constraint gmv_opt_ptc <- function(R, constraints, moments, lambda, target, init_weights){ # function for minimum variance or max quadratic utility problems # modifying ProportionalCostOpt function from MPO package - stopifnot("package:corpcor" %in% search() || require("corpcor",quietly = TRUE)) - stopifnot("package:quadprog" %in% search() || require("quadprog",quietly = TRUE)) + stopifnot("package:corpcor" %in% search() || require("corpcor", quietly = TRUE)) + stopifnot("package:ROI" %in% search() || require("ROI", quietly = TRUE)) + stopifnot("package:ROI.plugin.quadprog" %in% search() || require("ROI.plugin.quadprog", quietly = TRUE)) # Check for cleaned returns in moments if(!is.null(moments$cleanR)) R <- moments$cleanR @@ -809,7 +802,7 @@ Amat <- cbind(diag(N), matrix(0, nrow=N, ncol=N*2)) rhs <- init_weights dir <- rep("==", N) - meq <- 4 + meq <- N # check for a target return constraint if(!is.na(target)) { @@ -822,7 +815,7 @@ Amat <- rbind(Amat, rep((1+tmp_means), 3)) dir <- c(dir, "==") rhs <- c(rhs, (1+target)) - meq <- 5 + meq <- N + 1 } # Amat for positive weights for w.buy and w.sell @@ -876,15 +869,21 @@ # Remove the rows of Amat and elements of rhs.vec where rhs is Inf or -Inf Amat <- Amat[!is.infinite(rhs), ] - rhs <- rhs.vec[!is.infinite(rhs)] + rhs <- rhs[!is.infinite(rhs)] + dir <- dir[!is.infinite(rhs)] - qp.result <- try(solve.QP(Dmat=make.positive.definite(2*lambda*V), - dvec=d, Amat=t(Amat), bvec=rhs, meq=meq), silent=TRUE) - if(inherits(qp.result, "try-error")) stop(paste("No solution found:", qp.result)) + ROI_objective <- Q_objective(Q=make.positive.definite(2*lambda*V), + L=rep(-moments$mean, 3)) - wts <- qp.result$solution - w.buy <- qp.result$solution[(N+1):(2*N)] - w.sell <- qp.result$solution[(2*N+1):(3*N)] + opt.prob <- OP(objective=ROI_objective, + constraints=L_constraint(L=Amat, dir=dir, rhs=rhs)) + roi.result <- try(ROI_solve(x=opt.prob, solver="quadprog"), silent=TRUE) + + if(inherits(roi.result, "try-error")) stop(paste("No solution found:", roi.result)) + + wts <- roi.result$solution + w.buy <- roi.result$solution[(N+1):(2*N)] + w.sell <- roi.result$solution[(2*N+1):(3*N)] w.total <- init_weights + w.buy + w.sell wts.final <- wts[(1:N)] + wts[(1+N):(2*N)] + wts[(2*N+1):(3*N)] @@ -892,11 +891,10 @@ names(weights) <- colnames(R) out <- list() out$weights <- weights - out$out <- qp.result$value + out$out <- roi.result$objval obj_vals <- list() # Calculate the objective values here so that we can use the moments$mean - # and moments$var that might be passed in by the user. This will avoid - # the extra call to constrained_objective + # and moments$var that might be passed in by the user. if(!all(moments$mean == 0)){ port.mean <- as.numeric(sum(weights * moments$mean)) names(port.mean) <- "mean" @@ -911,17 +909,6 @@ } out$obj_vals <- obj_vals return(out) - - # TODO - # Get this working with ROI - - # Not getting solution using ROI - # set up the quadratic objective - # ROI_objective <- Q_objective(Q=make.positive.definite(2*lambda*V), L=rep(-moments$mean, 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") } From noreply at r-forge.r-project.org Sun Dec 15 04:59:07 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 15 Dec 2013 04:59:07 +0100 (CET) Subject: [Returnanalytics-commits] r3275 - pkg/PortfolioAnalytics/R Message-ID: <20131215035907.B49A3186C0D@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-15 04:59:05 +0100 (Sun, 15 Dec 2013) New Revision: 3275 Modified: pkg/PortfolioAnalytics/R/random_portfolios.R Log: modifying random portfolio methods to remove unused and unnecessary ... Modified: pkg/PortfolioAnalytics/R/random_portfolios.R =================================================================== --- pkg/PortfolioAnalytics/R/random_portfolios.R 2013-12-14 18:50:44 UTC (rev 3274) +++ pkg/PortfolioAnalytics/R/random_portfolios.R 2013-12-15 03:59:05 UTC (rev 3275) @@ -324,8 +324,8 @@ #' version 2 generate an arbitary number of constrained random portfolios #' -#' repeatedly calls \code{\link{randomize_portfolio}} to generate an -#' arbitrary number of constrained random portfolios. +#' Generate random portfolios using the 'sample', 'simplex', or 'grid' method. +#' See details. #' #' @details #' Random portfolios can be generate using one of three methods. @@ -362,7 +362,7 @@ #' feasible portfolios may be 1/3 or less depending on the other constraints. #' #' -#' @param portfolio an object of type "portfolio" specifying the constraints for the optimization, see \code{\link{constraint}} +#' @param portfolio an object of class 'portfolio' specifying the constraints for the optimization, see \code{\link{portfolio.spec}} #' @param permutations integer: number of unique constrained random portfolios to generate #' @param \dots any other passthru parameters #' @param rp_method method to generate random portfolios. Currently "sample", "simplex", or "grid". See Details. @@ -373,7 +373,7 @@ #' \code{\link{rp_sample}}, #' \code{\link{rp_simplex}}, #' \code{\link{rp_grid}} -#' @author Peter Carl, Brian G. Peterson, Ross Bennett (based on an idea by Pat Burns) +#' @author Peter Carl, Brian G. Peterson, Ross Bennett #' @aliases random_portfolios #' @rdname random_portfolios #' @export @@ -381,11 +381,11 @@ if(hasArg(fev)) fev=match.call(expand.dots=TRUE)$fev else fev=0:5 if(hasArg(normalize)) normalize=match.call(expand.dots=TRUE)$normalize else normalize=TRUE switch(rp_method, - sample = {rp <- rp_sample(portfolio, permutations, ...) + sample = {rp <- rp_sample(portfolio, permutations) }, - simplex = {rp <- rp_simplex(portfolio, permutations, fev, ...) + simplex = {rp <- rp_simplex(portfolio, permutations, fev) }, - grid = {rp <- rp_grid(portfolio, permutations, normalize, ...) + grid = {rp <- rp_grid(portfolio, permutations, normalize) } ) if(eliminate){ @@ -419,10 +419,10 @@ #' and position limit constraints. #' @param portfolio an object of type "portfolio" specifying the constraints for the optimization, see \code{\link{portfolio.spec}} #' @param permutations integer: number of unique constrained random portfolios to generate -#' @param \dots any other passthru parameters +#' @param max_permutations integer: maximum number of iterations to try for a valid portfolio, default 200 #' @return a matrix of random portfolio weights #' @export -rp_sample <- function(portfolio, permutations, ...){ +rp_sample <- function(portfolio, permutations, max_permutations=200){ # this function generates a series of portfolios that are a "random walk" from the current portfolio seed <- portfolio$assets result <- matrix(nrow=permutations, ncol=length(seed)) @@ -432,7 +432,7 @@ # rownames(result)[2]<-"equal.weight" for(i in 3:permutations) { #result[i,] <- as.matrix(randomize_portfolio_v2(portfolio=portfolio, ...)) - result[i,] <- randomize_portfolio_v2(portfolio=portfolio, ...) + result[i,] <- randomize_portfolio_v2(portfolio=portfolio, max_permutations=max_permutations) } result <- unique(result) # i <- nrow(result) @@ -473,10 +473,9 @@ #' @param portfolio an object of class 'portfolio' specifying the constraints for the optimization, see \code{\link{portfolio.spec}} #' @param permutations integer: number of unique constrained random portfolios to generate #' @param fev scalar or vector for FEV biasing -#' @param \dots any other passthru parameters #' @return a matrix of random portfolio weights #' @export -rp_simplex <- function(portfolio, permutations, fev=0:5, ...){ +rp_simplex <- function(portfolio, permutations, fev=0:5){ # get the assets from the portfolio assets <- portfolio$assets nassets <- length(assets) @@ -526,10 +525,9 @@ #' @param portfolio an object of class 'portfolio' specifying the constraints for the optimization, see \code{\link{portfolio.spec}} #' @param permutations integer: number of unique constrained random portfolios to generate #' @param normalize TRUE/FALSE to normalize the weghts to satisfy min_sum or max_sum -#' @param \dots any passthru parameters. Currently ignored #' @return matrix of random portfolio weights #' @export -rp_grid <- function(portfolio, permutations=2000, normalize=TRUE, ...){ +rp_grid <- function(portfolio, permutations=2000, normalize=TRUE){ # get the constraints from the portfolio constraints <- get_constraints(portfolio) From noreply at r-forge.r-project.org Sun Dec 15 05:35:06 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 15 Dec 2013 05:35:06 +0100 (CET) Subject: [Returnanalytics-commits] r3276 - in pkg/PortfolioAnalytics: . inst inst/tests Message-ID: <20131215043506.988FA185FB1@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-15 05:35:02 +0100 (Sun, 15 Dec 2013) New Revision: 3276 Added: pkg/PortfolioAnalytics/inst/ pkg/PortfolioAnalytics/inst/tests/ pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R Log: adding folder for tests and an initial test for backwards compatibility demo Added: pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R 2013-12-15 04:35:02 UTC (rev 3276) @@ -0,0 +1,82 @@ + +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/backwards_compat.R") + +context("Backwards compatibility is maintained") + +# class +test_that("Class of gen.constr is v1_constraint", + { expect_that(inherits(gen.constr, "v1_constraint", is_true()) }) + +# assets +test_that("Initial assets form an equal weight portfolio", + { expect_that(all.equal(as.numeric(gen.constr$assets), rep(1/4, 4)), is_true()) }) + +# min +test_that("Box constraints min vector is all 0s", + { expect_that(all.equal(as.numeric(gen.constr$min), rep(0, 4)), is_true()) }) + +# max +test_that("Box constraints max vector is all 1s", + { expect_that(all.equal(as.numeric(gen.constr$max), rep(1, 4)), is_true()) }) + +# min_mult +test_that("min_mult is null", + { expect_that(is.null(gen.constr$min_mult), is_true()) }) + +# max_mult +test_that("max_mult is null", + { expect_that(is.null(gen.constr$max_mult), is_true()) }) + +# min_sum +test_that("min_sum is 0.99", + { expect_that(all.equal(gen.constr$min_sum, 0.99), is_true()) }) + +# max_sum +test_that("min_sum is 1.01", + { expect_that(all.equal(gen.constr$max_sum, 1.01), is_true()) }) + +# mean objective +test_that("The objective name is 'mean'", + { expect_that(all.equal(gen.constr$objectives[[1]]$name, "mean"), is_true()) }) + +context("Optimization output") + +# Not sure how to test for exact values of optimization results for DEoptim +# and random portfolios +# - use a specific data set of rp weights + +# random portfolios optimization +test_that("random portfolios updated portfolio object", + { expect_that(inherits(optrpv1$portfolio, "portfolio.spec"), is_true()) }) + +test_that("random portfolios returns optimal weights", + { expect_that(is.numeric(extractWeights(optrpv1)), is_true()) }) + +test_that("random portfolios returns an objective measure", + { expect_that(is.numeric(extractObjectiveMeasures(optrpv1)$mean), is_true()) }) + +# DEoptim optimization +test_that("DE optim updated portfolio object", + { expect_that(inherits(optrdev1$portfolio, "portfolio.spec"), is_true()) }) + +test_that("DE optim returns optimal weights", + { expect_that(is.numeric(extractWeights(optdev1)), is_true()) }) + +test_that("DE optim returns an objective measure", + { expect_that(is.numeric(extractObjectiveMeasures(optdev1)$mean), is_true()) }) + +# ROI optimization +test_that("ROI updated portfolio object", + { expect_that(inherits(optroiv1$portfolio, "portfolio.spec"), is_true()) }) + +test_that("ROI returns optimal weights equal to c(0, 0, 0.46, 0.55)", + { expect_equal(as.numeric(extractWeights(optroiv1)), c(0, 0, 0.46, 0.55)) }) + +test_that("ROI returns an objective measure mean=0.008193842", + { expect_equal(is.numeric(extractObjectiveMeasures(optroiv1)$mean), 0.008193842) }) + From noreply at r-forge.r-project.org Sun Dec 15 23:58:27 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 15 Dec 2013 23:58:27 +0100 (CET) Subject: [Returnanalytics-commits] r3277 - pkg/PortfolioAnalytics/demo Message-ID: <20131215225827.80BDF186694@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-15 23:58:27 +0100 (Sun, 15 Dec 2013) New Revision: 3277 Modified: pkg/PortfolioAnalytics/demo/backwards_compat.R pkg/PortfolioAnalytics/demo/demo_efficient_frontier.R pkg/PortfolioAnalytics/demo/demo_group_constraints.R pkg/PortfolioAnalytics/demo/demo_leverage_exposure_constraint.R pkg/PortfolioAnalytics/demo/demo_max_STARR.R pkg/PortfolioAnalytics/demo/demo_max_Sharpe.R pkg/PortfolioAnalytics/demo/demo_max_quadratic_utility.R pkg/PortfolioAnalytics/demo/demo_max_return.R pkg/PortfolioAnalytics/demo/demo_min_StdDev.R pkg/PortfolioAnalytics/demo/demo_min_expected_shortfall.R pkg/PortfolioAnalytics/demo/demo_return_target.R pkg/PortfolioAnalytics/demo/demo_risk_budgets.R pkg/PortfolioAnalytics/demo/demo_weight_concentration.R Log: Minor modifications to some demos for consistency and easier testing Modified: pkg/PortfolioAnalytics/demo/backwards_compat.R =================================================================== --- pkg/PortfolioAnalytics/demo/backwards_compat.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/backwards_compat.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -8,7 +8,8 @@ funds <- colnames(ret) # Set up constraint object using v1 specification -gen.constr <- constraint(assets=funds, min=0, max=0.55, min_sum=0.99, max_sum=1, weight_seq=generatesequence(min=0, max=0.55, by=0.002)) +gen.constr <- constraint(assets=funds, min=0, max=0.55, min_sum=0.99, max_sum=1.01, + weight_seq=generatesequence(min=0, max=0.55, by=0.002)) class(gen.constr) # Add an objective to the gen.constr object @@ -19,17 +20,16 @@ # and will update to the v2 specification using a portfolio object with # constraints and objectives from the v1_constraint object. -# Random +# Random Portfolios optrpv1 <- optimize.portfolio(R=ret, constraints=gen.constr, optimize_method="random", search_size=2000) -print(optrpv1$portfolio) -print(optrpv1) +optrpv1 # DEoptim optdev1 <- optimize.portfolio(R=ret, constraints=gen.constr, optimize_method="DEoptim", search_size=2000) -print(optdev1) +optdev1 # ROI optroiv1 <- optimize.portfolio(R=ret, constraints=gen.constr, optimize_method="ROI") -print(optroiv1) +optroiv1 Modified: pkg/PortfolioAnalytics/demo/demo_efficient_frontier.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_efficient_frontier.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_efficient_frontier.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -40,7 +40,7 @@ # mean-var efficient frontier meanvar.ef <- create.EfficientFrontier(R=R, portfolio=meanvar.portf, type="mean-StdDev") -print(meanvar.ef) +meanvar.ef summary(meanvar.ef, digits=2) meanvar.ef$frontier @@ -107,15 +107,17 @@ # the optimize.portfolio object, it is best to extractEfficientFrontier as shown # below ef <- extractEfficientFrontier(object=opt_meanvar, match.col="StdDev", n.portfolios=15) -print(ef) +ef summary(ef, digits=5) chart.Weights.EF(ef, match.col="StdDev", colorset=bluemono) chart.Weights.EF(ef, match.col="StdDev", colorset=bluemono, by.groups=TRUE) # mean-etl efficient frontier meanetl.ef <- create.EfficientFrontier(R=R, portfolio=meanetl.portf, type="mean-ES") -print(meanetl.ef) +meanetl.ef summary(meanetl.ef) +meanetl.ef$frontier + chart.EfficientFrontier(meanetl.ef, match.col="ES", main="mean-ETL Efficient Frontier", type="l", col="blue", RAR.text="STARR") chart.Weights.EF(meanetl.ef, colorset=bluemono, match.col="ES") chart.Weights.EF(meanetl.ef, by.groups=TRUE, colorset=bluemono, match.col="ES") Modified: pkg/PortfolioAnalytics/demo/demo_group_constraints.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_group_constraints.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_group_constraints.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -9,23 +9,23 @@ funds <- colnames(R) # Set up portfolio with objectives and constraints -pspec <- portfolio.spec(assets=funds) -pspec <- add.constraint(portfolio=pspec, type="full_investment") -pspec <- add.constraint(portfolio=pspec, type="long_only") +init.portf <- portfolio.spec(assets=funds) +init.portf <- add.constraint(portfolio=init.portf, type="full_investment") +init.portf <- add.constraint(portfolio=init.portf, type="long_only") # Add group constraints such that assets 1, 3, and 5 are in a group called # GroupA and assets 2 and 4 are in a group called Group B. The sum of the # weights in GroupA must be between 0.05 and 0.7. The sum of the weights in # GroupB must be between 0.15 and 0.5. -pspec <- add.constraint(portfolio=pspec, type="group", - groups=list(groupA=c(1, 3, 5), - groupB=c(2, 4)), - group_min=c(0.05, 0.15), - group_max=c(0.7, 0.5)) -print(pspec) +init.portf <- add.constraint(portfolio=init.portf, type="group", + groups=list(groupA=c(1, 3, 5), + groupB=c(2, 4)), + group_min=c(0.05, 0.15), + group_max=c(0.7, 0.5)) +init.portf # Add an objective to minimize portfolio standard deviation -pspec <- add.objective(portfolio=pspec, type="risk", name="StdDev") +init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev") # The examples here use the obective to minimize standard deviation, but any # supported objective can also be used. @@ -34,25 +34,25 @@ # problem and solved very quickly using optimize_method="ROI". Although "StdDev" # was specified as an objective, the quadratic programming problem uses the # variance-covariance matrix in the objective function. -minStdDev.ROI <- optimize.portfolio(R=R, portfolio=pspec, optimize_method="ROI") -print(minStdDev.ROI) +minStdDev.ROI <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI") +minStdDev.ROI extractGroups(minStdDev.ROI) # The leverage constraints should be relaxed slightly for random portfolios # and DEoptim -pspec$constraints[[1]]$min_sum=0.99 -pspec$constraints[[1]]$max_sum=1.01 +init.portf$constraints[[1]]$min_sum=0.99 +init.portf$constraints[[1]]$max_sum=1.01 # Solve with random portfolios # By construction, the random portfolios will be generated to satisfy the # group constraint. -minStdDev.RP <- optimize.portfolio(R=R, portfolio=pspec, - optimize_method="random", search_size=2500) -print(minStdDev.RP) +minStdDev.RP <- optimize.portfolio(R=R, portfolio=init.portf, + optimize_method="random", search_size=2000) +minStdDev.RP extractGroups(minStdDev.RP) # Solve with DEoptim -minStdDev.DE <- optimize.portfolio(R=R, portfolio=pspec, - optimize_method="DEoptim", search_size=2500) -print(minStdDev.DE) +minStdDev.DE <- optimize.portfolio(R=R, portfolio=init.portf, + optimize_method="DEoptim", search_size=2000) +minStdDev.DE extractGroups(minStdDev.DE) Modified: pkg/PortfolioAnalytics/demo/demo_leverage_exposure_constraint.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_leverage_exposure_constraint.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_leverage_exposure_constraint.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -4,7 +4,7 @@ library(PortfolioAnalytics) data(edhec) -R <- edhec[, 1:5] +R <- edhec[, 1:10] funds <- colnames(R) # Set up an initial portfolio object with basic constraints @@ -30,8 +30,8 @@ # Run optimization dollar.neutral.opt <- optimize.portfolio(R=R, portfolio=dollar.neutral.portf, optimize_method="DEoptim", - search_size=2500) -print(dollar.neutral.opt) + search_size=2000) +dollar.neutral.opt # Leveraged portfolio with max 1.6:1 leverage constraint leveraged.portf <- init.portf @@ -46,7 +46,6 @@ # Run optimization leveraged.opt <- optimize.portfolio(R=R, portfolio=leveraged.portf, optimize_method="DEoptim", - search_size=2500) -print(leveraged.opt) + search_size=2000) +leveraged.opt - Modified: pkg/PortfolioAnalytics/demo/demo_max_STARR.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_max_STARR.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_max_STARR.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -15,20 +15,20 @@ init.portf <- add.objective(portfolio=init.portf, type="return", name="mean") init.portf <- add.objective(portfolio=init.portf, type="risk", name="ES", arguments=list(p=0.925)) -print(init.portf) +init.portf # Maximizing STARR Ratio can be formulated as a linear programming # problem and solved very quickly using optimize_method="ROI". -# The default action if "mean" and "StdDev" are specified as objectives with -# optimize_method="ROI" is to maximize quadratic utility. If we want to use +# The default action if "mean" and "ES" are specified as objectives with +# optimize_method="ROI" is to maximize STARR. If we want to use # both mean and ES in the objective function, but only minimize ES, we need to # pass in maxSTARR=FALSE to optimize.portfolio. maxSTARR.lo.ROI <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI", trace=TRUE) -print(maxSTARR.lo.ROI) +maxSTARR.lo.ROI # Although the maximum STARR Ratio objective can be solved quickly and accurately # with optimize_method="ROI", it is also possible to solve this optimization @@ -45,17 +45,17 @@ # Use random portfolios maxSTARR.lo.RP <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="random", - search_size=5000, + search_size=2000, trace=TRUE) -print(maxSTARR.lo.RP) +maxSTARR.lo.RP chart.RiskReward(maxSTARR.lo.RP, risk.col="ES", return.col="mean") # Use DEoptim maxSTARR.lo.DE <- optimize.portfolio(R=R, portfolio=init.portf, - optimize_method="DEoptim", - search_size=5000, - trace=TRUE) -print(maxSTARR.lo.DE) + optimize_method="DEoptim", + search_size=2000, + trace=TRUE) +maxSTARR.lo.DE chart.RiskReward(maxSTARR.lo.DE, risk.col="ES", return.col="mean", xlim=c(0.01, 0.08), ylim=c(0.004,0.008)) Modified: pkg/PortfolioAnalytics/demo/demo_max_Sharpe.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_max_Sharpe.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_max_Sharpe.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -13,9 +13,9 @@ init.portf <- add.constraint(portfolio=init.portf, type="long_only") init.portf <- add.objective(portfolio=init.portf, type="return", name="mean") init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev") -print(init.portf) +init.portf -# Maximizing Sharpe Ratio can be formulated as a quardratic programming +# Maximizing Sharpe Ratio can be formulated as a quadratic programming # problem and solved very quickly using optimize_method="ROI". Although "StdDev" # was specified as an objective, the quadratic programming problem uses the # variance-covariance matrix in the objective function. @@ -27,7 +27,7 @@ maxSR.lo.ROI <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI", maxSR=TRUE, trace=TRUE) -print(maxSR.lo.ROI) +maxSR.lo.ROI # Although the maximum Sharpe Ratio objective can be solved quickly and accurately # with optimize_method="ROI", it is also possible to solve this optimization @@ -45,7 +45,7 @@ optimize_method="random", search_size=2000, trace=TRUE) -print(maxSR.lo.RP) +maxSR.lo.RP chart.RiskReward(maxSR.lo.RP, risk.col="StdDev", return.col="mean") # Use DEoptim @@ -53,6 +53,6 @@ optimize_method="DEoptim", search_size=2000, trace=TRUE) -print(maxSR.lo.DE) +maxSR.lo.DE chart.RiskReward(maxSR.lo.DE, risk.col="StdDev", return.col="mean") Modified: pkg/PortfolioAnalytics/demo/demo_max_quadratic_utility.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_max_quadratic_utility.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_max_quadratic_utility.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -16,7 +16,7 @@ # is penalized init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev", risk_aversion=4) -print(init.portf) +init.portf # Maximizing quadratic utility can be formulated as a quardratic programming # problem and solved very quickly using optimize_method="ROI". Although "StdDev" @@ -24,7 +24,7 @@ # variance-covariance matrix in the objective function. maxQU.lo.ROI <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI", trace=TRUE) -print(maxQU.lo.ROI) +maxQU.lo.ROI plot(maxQU.lo.ROI, risk.col="StdDev", main=expression("Long Only Max Quadratic Utility" ~ lambda ~"=0.25")) @@ -34,7 +34,7 @@ init.portf$objectives[[2]]$risk_aversion <- 1e-6 maxQU.maxret.ROI <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI", trace=TRUE) -print(maxQU.maxret.ROI) +maxQU.maxret.ROI plot(maxQU.maxret.ROI, risk.col="StdDev", main=expression("Long Only Max Quadratic Utility" ~ lambda ~"= 1e-6")) @@ -43,7 +43,7 @@ init.portf$objectives[[2]]$risk_aversion <- 1e6 maxQU.minvol.ROI <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI", trace=TRUE) -print(maxQU.minvol.ROI) +maxQU.minvol.ROI plot(maxQU.minvol.ROI, risk.col="StdDev", main=expression("Long Only Max Quadratic Utility" ~ lambda ~"= 1e6")) Modified: pkg/PortfolioAnalytics/demo/demo_max_return.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_max_return.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_max_return.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -12,7 +12,7 @@ init.portf <- add.constraint(portfolio=init.portf, type="full_investment") init.portf <- add.constraint(portfolio=init.portf, type="long_only") init.portf <- add.objective(portfolio=init.portf, type="return", name="mean") -print(init.portf) +init.portf # Maximizing return can be formulated as a linear programming problem and # solved very quickly using optimize_method="ROI". We are using long_only @@ -20,7 +20,7 @@ # highest mean return. maxret.lo.ROI <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI", trace=TRUE) -print(maxret.lo.ROI) +maxret.lo.ROI chart.Weights(maxret.lo.ROI, main="Long Only Maximize Return") @@ -31,7 +31,7 @@ maxret.box.ROI <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI", trace=TRUE) -print(maxret.box.ROI) +maxret.box.ROI chart.Weights(maxret.box.ROI, main="Box Maximize Return") @@ -61,9 +61,9 @@ maxret.box1.RP <- optimize.portfolio(R=R, portfolio=port1, optimize_method="random", - search_size=5000, + search_size=2000, trace=TRUE) -print(maxret.box1.RP) +maxret.box1.RP ploy(maxret.box1.RP, risk.col="StdDev") # create a new portfolio called 'port2' by using init.portf and modify the @@ -73,15 +73,15 @@ maxret.box2.RP <- optimize.portfolio(R=R, portfolio=port2, optimize_method="random", - search_size=5000, + search_size=2000, trace=TRUE) -print(maxret.box2.RP) +maxret.box2.RP plot(maxret.box2.RP, risk.col="StdDev") # Now solve the problem with DEoptim maxret.box.DE <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="DEoptim", - search_size=5000, + search_size=2000, trace=TRUE) -print(maxret.box.DE) +maxret.box.DE plot(maxret.box.DE, risk.col="StdDev", return.col="mean") Modified: pkg/PortfolioAnalytics/demo/demo_min_StdDev.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_min_StdDev.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_min_StdDev.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -63,7 +63,7 @@ minStdDev.box1.RP <- optimize.portfolio(R=R, portfolio=port1, optimize_method="random", - search_size=5000, + search_size=2000, trace=TRUE) print(minStdDev.box1.RP) ploy(minStdDev.box1.RP, risk.col="StdDev") @@ -75,7 +75,7 @@ minStdDev.box2.RP <- optimize.portfolio(R=R, portfolio=port2, optimize_method="random", - search_size=5000, + search_size=2000, trace=TRUE) print(minStdDev.box2.RP) plot(minStdDev.box2.RP, risk.col="StdDev") @@ -83,7 +83,7 @@ # Now solve the problem with DEoptim minStdDev.box.DE <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="DEoptim", - search_size=5000, + search_size=2000, trace=TRUE) print(minStdDev.box.DE) plot(minStdDev.box.DE, risk.col="StdDev", return.col="mean") Modified: pkg/PortfolioAnalytics/demo/demo_min_expected_shortfall.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_min_expected_shortfall.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_min_expected_shortfall.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -13,7 +13,7 @@ init.portf <- add.constraint(portfolio=init.portf, type="full_investment") init.portf <- add.constraint(portfolio=init.portf, type="long_only") # Add objective to minimize expected shortfall with a confidence level of -# 0.95. +# 0.9. init.portf <- add.objective(portfolio=init.portf, type="risk", name="ES", arguments=list(p=0.9)) print(init.portf) @@ -71,7 +71,7 @@ minES.box1.RP <- optimize.portfolio(R=R, portfolio=port1, optimize_method="random", - search_size=5000, + search_size=2000, trace=TRUE) print(minES.box1.RP) plot(minES.box1.RP, risk.col="ES", return.col="mean") @@ -83,7 +83,7 @@ minES.box2.RP <- optimize.portfolio(R=R, portfolio=port2, optimize_method="random", - search_size=5000, + search_size=2000, trace=TRUE) print(minES.box2.RP) plot(minES.box2.RP, risk.col="ES", return.col="mean") @@ -91,7 +91,7 @@ # Now solve the problem with DEoptim minES.box.DE <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="DEoptim", - search_size=5000, + search_size=2000, trace=TRUE) print(minES.box.DE) plot(minES.box.DE, risk.col="ES", return.col="mean") Modified: pkg/PortfolioAnalytics/demo/demo_return_target.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_return_target.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_return_target.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -6,45 +6,49 @@ data(edhec) ret <- edhec[, 1:4] -# set up portfolio specification object target in the return object -pspec1 <- portfolio.spec(assets=colnames(ret)) -pspec1 <- add.constraint(portfolio=pspec1, type="leverage", min_sum=0.99, max_sum=1.01) -pspec1 <- add.constraint(portfolio=pspec1, type="box") -pspec1 <- add.objective(portfolio=pspec1, type="return", name="mean", target=0.007) +# Create an initial portfolio object +init.portf <- portfolio.spec(assets=colnames(ret)) +init.portf <- add.constraint(portfolio=init.portf, type="full_investment") +init.portf <- add.constraint(portfolio=init.portf, type="long_only") -# run optimization using ROI with pspec1 -opt1 <- optimize.portfolio(R=ret, portfolio=pspec1, optimize_method="ROI") -opt1 -summary(opt1) -wts1 <- extractWeights(opt1) +# Add mean return objective with target return +ret.obj.portf <- add.objective(portfolio=init.portf, type="return", + name="mean", target=0.007) -# set up portfolio specification object target with the return constraint -pspec2 <- portfolio.spec(assets=colnames(ret)) -pspec2 <- add.constraint(portfolio=pspec2, type="leverage", min_sum=0.99, max_sum=1.01) -pspec2 <- add.constraint(portfolio=pspec2, type="box") -pspec2 <- add.constraint(portfolio=pspec2, type="return", return_target=0.007) -pspec2 <- add.objective(portfolio=pspec2, type="return", name="mean") +# Add return target constraint +ret.constr.portf <- add.constraint(portfolio=init.portf, type="return", return_target=0.007) +ret.constr.portf <- add.objective(portfolio=ret.constr.portf, type="return", name="mean") -# run optimization using ROI with pspec2 -opt2 <- optimize.portfolio(R=ret, portfolio=pspec2, optimize_method="ROI") -opt2 -summary(opt2) -wts2 <- extractWeights(opt2) -# run optimization with DEoptim using pspec1 +# Run optimization using ROI with target return as an objective +ret.obj.opt <- optimize.portfolio(R=ret, portfolio=ret.obj.portf, optimize_method="ROI") +ret.obj.opt + +# Run optimization using ROI with target return as a constraint +ret.constr.opt <- optimize.portfolio(R=ret, portfolio=ret.constr.portf, optimize_method="ROI") +ret.constr.opt + +# Relaxe constraints for the sum of weights for DEoptim and random portfolios +ret.obj.portf$constraints[[1]]$min_sum <- 0.99 +ret.obj.portf$constraints[[1]]$max_sum <- 1.01 + +ret.constr.portf$constraints[[1]]$min_sum <- 0.99 +ret.constr.portf$constraints[[1]]$max_sum <- 1.01 + +# run optimization with DEoptim using ret.obj.portf set.seed(123) -opt_de1 <- optimize.portfolio(R=ret, portfolio=pspec1, optimize_method="DEoptim", search_size=4000, traceDE=5) -opt_de1 +opt.obj.de <- optimize.portfolio(R=ret, portfolio=ret.obj.portf, optimize_method="DEoptim", search_size=2000, traceDE=5) +opt.obj.de -# run optimization with DEoptim using pspec2 +# run optimization with DEoptim using ret.constr.portf set.seed(123) -opt_de2 <- optimize.portfolio(R=ret, portfolio=pspec2, optimize_method="DEoptim", search_size=4000, traceDE=5) -opt_de2 +opt.constr.de <- optimize.portfolio(R=ret, portfolio=ret.constr.portf, optimize_method="DEoptim", search_size=2000, traceDE=5) +opt.constr.de -# run optimizations with random portfolios using pspec1 -opt_rp1 <- optimize.portfolio(R=ret, portfolio=pspec1, optimize_method="random", search_size=4000) -opt_rp1 +# run optimizations with random portfolios using ret.obj.portf +opt.obj.rp <- optimize.portfolio(R=ret, portfolio=ret.obj.portf, optimize_method="random", search_size=2000) +opt.obj.rp -# run optimizations with random portfolios using pspec2 -opt_rp2 <- optimize.portfolio(R=ret, portfolio=pspec2, optimize_method="random", search_size=4000) -opt_rp2 +# run optimizations with random portfolios using ret.constr.portf +opt.constr.rp <- optimize.portfolio(R=ret, portfolio=ret.constr.portf, optimize_method="random", search_size=2000) +opt.constr.rp Modified: pkg/PortfolioAnalytics/demo/demo_risk_budgets.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_risk_budgets.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_risk_budgets.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -22,8 +22,8 @@ # to have a "sub" objective such as maximizing return, minimizing ES, # minimizing StdDev, etc. -# Add objective to maximize mean with limit on component ES risk contribution -# The max_prisk controls the maximum percentage contribution to risk +# Add objective to maximize mean with limit on component ES risk contribution. +# The max_prisk controls the maximum percentage contribution to risk. rbES.portf <- add.objective(portfolio=init.portf, type="return", name="mean") rbES.portf <- add.objective(portfolio=rbES.portf, type="risk_budget", name="ES", max_prisk=0.4, arguments=list(p=0.92)) @@ -31,24 +31,26 @@ # Use DEoptim for optimization rbES.DE <- optimize.portfolio(R=R, portfolio=rbES.portf, optimize_method="DEoptim", - search_size=5000, trace=TRUE) -print(rbES.DE) + search_size=2000, trace=TRUE) +rbES.DE plot(rbES.DE, xlim=c(0, 0.08), ylim=c(0, 0.01)) chart.RiskBudget(rbES.DE, risk.type="pct_contrib") # Add objective to maximize mean return with equal ES risk contribution eqES.portf <- add.objective(portfolio=init.portf, type="return", name="mean") eqES.portf <- add.objective(portfolio=eqES.portf, type="risk_budget", - name="ES", min_concentration=TRUE, arguments=list(p=0.9)) + name="ES", min_concentration=TRUE, + arguments=list(p=0.9, clean="boudt"), + multiplier=10) # Use random portfolios for optimization # Use cleaned returns -R.clean <- Return.clean(R=R, method="boudt") -eqES.RP <- optimize.portfolio(R=R.clean, portfolio=eqES.portf, +# R.clean <- Return.clean(R=R, method="boudt") +eqES.RP <- optimize.portfolio(R=R, portfolio=eqES.portf, optimize_method="random", - search_size=2500, trace=TRUE) + search_size=2000, trace=TRUE) -print(eqES.RP) +eqES.RP plot(eqES.RP) chart.RiskBudget(eqES.RP, risk.type="pct_contrib") @@ -60,11 +62,8 @@ # Use DEoptim for optimization rbStdDev.DE <- optimize.portfolio(R=R, portfolio=rbStdDev.portf, optimize_method="DEoptim", - search_size=5000, trace=TRUE) + search_size=2000, trace=TRUE) -print(eqES.RP) -plot(eqES.RP) -chart.RiskBudget(eqES.RP, risk.type="pct_contrib") - - - +rbStdDev.DE +plot(rbStdDev.DE, risk.col="StdDev", xlim=c(0, 0.035), ylim=c(0, 0.01)) +chart.RiskBudget(rbStdDev.DE, risk.type="pct_contrib") Modified: pkg/PortfolioAnalytics/demo/demo_weight_concentration.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_weight_concentration.R 2013-12-15 04:35:02 UTC (rev 3276) +++ pkg/PortfolioAnalytics/demo/demo_weight_concentration.R 2013-12-15 22:58:27 UTC (rev 3277) @@ -12,21 +12,21 @@ # Create initial portfolio object with category_labels -init <- portfolio.spec(assets=funds, category_labels=cap_labels) +init.portf <- portfolio.spec(assets=funds, category_labels=cap_labels) # Add some weight constraints -init <- add.constraint(portfolio=init, type="full_investment") -init <- add.constraint(portfolio=init, type="long_only") +init.portf <- add.constraint(portfolio=init.portf, type="full_investment") +init.portf <- add.constraint(portfolio=init.portf, type="long_only") # Add objective to minimize variance -init <- add.objective(portfolio=init, type="risk", name="var") +init.portf <- add.objective(portfolio=init.portf, type="risk", name="var") # Run the optimization with var as the only objective -opt1 <- optimize.portfolio(R=R, portfolio=init, optimize_method="ROI", trace=TRUE) +opt1 <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="ROI", trace=TRUE) opt1 # Add the weight_concentration objective # Set the conc_aversion values to 0 so that we should get the same value as min var -conc <- add.objective(portfolio=init, type="weight_concentration", name="HHI", - conc_aversion=0, conc_groups=init$category_labels) +conc.portf <- add.objective(portfolio=init.portf, type="weight_concentration", name="HHI", + conc_aversion=0, conc_groups=init.portf$category_labels) opt2 <- optimize.portfolio(R=R, portfolio=conc, optimize_method="ROI", trace=TRUE) opt2 @@ -34,8 +34,8 @@ chart.Weights(opt2) # Now change the conc_aversion values -conc$objectives[[2]]$conc_aversion <- c(0.03, 0.03, 0.06, 0.02) -opt3 <- optimize.portfolio(R=R, portfolio=conc, optimize_method="ROI", trace=TRUE) +conc.portf$objectives[[2]]$conc_aversion <- c(0.03, 0.03, 0.06, 0.02) +opt3 <- optimize.portfolio(R=R, portfolio=conc.portf, optimize_method="ROI", trace=TRUE) opt3 chart.Weights(opt3) @@ -45,7 +45,7 @@ chart.GroupWeights(opt3, grouping="category", plot.type="barplot", col=bluemono) # If all the conc_aversion values are very high, this should result in an equal weight portfolio -conc$objectives[[2]]$conc_aversion <- rep(1e6, 4) -opt4 <- optimize.portfolio(R=R, portfolio=conc, optimize_method="ROI", trace=TRUE) +conc.portf$objectives[[2]]$conc_aversion <- rep(1e6, 4) +opt4 <- optimize.portfolio(R=R, portfolio=conc.portf, optimize_method="ROI", trace=TRUE) opt4 chart.Weights(opt4) From noreply at r-forge.r-project.org Mon Dec 16 00:00:18 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 00:00:18 +0100 (CET) Subject: [Returnanalytics-commits] r3278 - pkg/PortfolioAnalytics/inst/tests Message-ID: <20131215230018.EC9551869D2@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 00:00:17 +0100 (Mon, 16 Dec 2013) New Revision: 3278 Added: pkg/PortfolioAnalytics/inst/tests/test_demo_efficient_frontier.R pkg/PortfolioAnalytics/inst/tests/test_demo_group_constraints.R pkg/PortfolioAnalytics/inst/tests/test_demo_leverage.R pkg/PortfolioAnalytics/inst/tests/test_demo_max_STARR.R pkg/PortfolioAnalytics/inst/tests/test_demo_max_qu.R pkg/PortfolioAnalytics/inst/tests/test_demo_max_return.R pkg/PortfolioAnalytics/inst/tests/test_demo_min_StdDev.R pkg/PortfolioAnalytics/inst/tests/test_demo_min_expected_shortfall.R pkg/PortfolioAnalytics/inst/tests/test_demo_return_target.R pkg/PortfolioAnalytics/inst/tests/test_demo_risk_budgets.R pkg/PortfolioAnalytics/inst/tests/test_demo_weight_concentration.R pkg/PortfolioAnalytics/inst/tests/test_max_Sharpe.R Modified: pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R Log: Adding tests for demos Modified: pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R 2013-12-15 22:58:27 UTC (rev 3277) +++ pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -10,7 +10,7 @@ # class test_that("Class of gen.constr is v1_constraint", - { expect_that(inherits(gen.constr, "v1_constraint", is_true()) }) + { expect_that(inherits(gen.constr, "v1_constraint"), is_true()) }) # assets test_that("Initial assets form an equal weight portfolio", Added: pkg/PortfolioAnalytics/inst/tests/test_demo_efficient_frontier.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_efficient_frontier.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_efficient_frontier.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,35 @@ + +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/demo_efficient_frontier.R") + +context("mean-var efficient frontier") + +test_that("meanvar.ef$frontier has 25 rows", + { expect_equal(nrow(meanvar.ef$frontier), 25) }) + +test_that("colnames(meanvar.ef$frontier) are consistent", + { expect_equal(colnames(meanvar.ef$frontier), c("mean", "StdDev", "out", "w.CA", "w.CTAG", "w.DS", "w.EM", "w.EQM")) }) + +test_that("first row of meanvar.ef$frontier is consistent", + { expect_equal(as.numeric(meanvar.ef$frontier[1,]), c(0.006765658, 0.01334460, 178.0782, 0.15, 0.15, 0.15, 0.15, 0.4)) }) + +test_that("last row of meanvar.ef$frontier is consistent", + { expect_equal(as.numeric(meanvar.ef$frontier[25,]), c(0.007326513, 0.02070151, 428.5526, 0.15, 0.15, 0.15, 0.4, 0.15)) }) + +context("mean-etl efficient frontier") + +test_that("meanetl.ef$frontier has 25 rows", + { expect_equal(nrow(meanetl.ef$frontier), 25) }) + +test_that("colnames(meanetl.ef$frontier) are consistent", + { expect_equal(colnames(meanetl.ef$frontier), c("mean", "ES", "out", "w.CA", "w.CTAG", "w.DS", "w.EM", "w.EQM")) }) + +test_that("first row of meanetl.ef$frontier is consistent", + { expect_equal(as.numeric(meanetl.ef$frontier[1,]), c(0.006887368, 0.02637039, 0.02637039, 0.15, 0.4, 0.15, 0.15, 0.15)) }) + +test_that("last row of meanetl.ef$frontier is consistent", + { expect_equal(as.numeric(meanetl.ef$frontier[25,]), c(0.007326513, 0.04642908, 0.04642908, 0.15, 0.15, 0.15, 0.4, 0.15)) }) Added: pkg/PortfolioAnalytics/inst/tests/test_demo_group_constraints.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_group_constraints.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_group_constraints.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,95 @@ + +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/demo_group_constraints.R") + +##### Test the constraints ##### +context("demo_group_constraints") + +group_constr <- init.portf$constraints[[3]] + +test_that("init.portf contains groups as a constraint", + { expect_that(inherits(group_constr, "group_constraint"), is_true()) }) + +test_that("group constraint for groupA is c(1, 3, 5)", + { expect_equal(group_constr$groups$groupA, c(1, 3, 5)) }) + +test_that("group constraint for groupB is c(2, 4)", + { expect_equal(group_constr$groups$groupB, c(2, 4)) }) + +test_that("group constraint cLO is c(0.05, 0.15)", + { expect_equal(group_constr$cLO, c(0.05, 0.15)) }) + +test_that("group constraint cUP is c(0.7, 0.5)", + { expect_equal(group_constr$cUP, c(0.7, 0.5)) }) + +cLO <- group_constr$cLO +cUP <- group_constr$cUP + +##### ROI Optimization ##### +context("demo_group_constraints") + +test_that("minStdDev.ROI weights equal c(4.593895e-03, 2.540430e-01, -1.387779e-17, 4.595703e-02, 6.954061e-01)", + { expect_equal(extractWeights(minStdDev.ROI), c(4.593895e-03, 2.540430e-01, -1.387779e-17, 4.595703e-02, 6.954061e-01)) }) + +test_that("minStdDev.ROI objective measure StdDev = 0.01042408", + { expect_equal(extractObjectiveMeasures(minStdDev.ROI)$StdDev, 0.01042408) }) + +weights.ROI <- extractWeights(minStdDev.ROI) + +test_that("minStdDev.ROI group weights are calculated correctly", + { expect_equal(as.numeric(extractGroups(minStdDev.ROI)$group_weights), + c(sum(weights.ROI[c(1, 3, 5)]), sum(weights.ROI[c(2, 4)]))) }) + +test_that("minStdDev.ROI group constraint cLO is not violated", + { expect_that(all(extractGroups(minStdDev.ROI)$group_weights >= cLO), is_true()) }) + +test_that("minStdDev.ROI group constraint cUP is not violated", + { expect_that(all(extractGroups(minStdDev.ROI)$group_weights <= cUP), is_true()) }) + + +##### RP Optimization ##### +context("minStdDev.RP") + +test_that("minStdDev.RP weights is a numeric vector", + { expect_that(is.numeric(extractWeights(minStdDev.RP)), is_true()) }) + +test_that("minStdDev.RP objective measure StdDev is numeric", + { expect_that(extractObjectiveMeasures(minStdDev.RP)$StdDev, is_true()) }) + +weights.RP <- extractWeights(minStdDev.RP) + +test_that("minStdDev.RP group weights are calculated correctly", + { expect_equal(as.numeric(extractGroups(minStdDev.RP)$group_weights), + c(sum(weights.RB[c(1, 3, 5)]), sum(weights.RB[c(2, 4)]))) }) + +test_that("minStdDev.RP group constraint cLO is not violated", + { expect_that(all(extractGroups(minStdDev.RP)$group_weights >= cLO), is_true()) }) + +test_that("minStdDev.RP group constraint cUP is not violated", + { expect_that(all(extractGroups(minStdDev.RP)$group_weights <= cUP), is_true()) }) + + +##### DE Optimization ##### +context("minStdDev.DE") + +test_that("minStdDev.DE weights is a numeric vector", + { expect_equal(extractWeights(minStdDev.DE), is_true()) }) + +test_that("minStdDev.DE objective measure StdDev is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.ROI)$StdDev), is_true()) }) + +weights.DE <- extractWeights(minStdDev.DE) + +test_that("minStdDev.DE group weights are calculated correctly", + { expect_equal(as.numeric(extractGroups(minStdDev.DE)$group_weights), + c(sum(weights.DE[c(1, 3, 5)]), sum(weights.DE[c(2, 4)]))) }) + +test_that("minStdDev.DE group constraint cLO is not violated", + { expect_that(all(extractGroups(minStdDev.DE)$group_weights >= cLO), is_true()) }) + +test_that("minStdDev.DE group constraint cUP is not violated", + { expect_that(all(extractGroups(minStdDev.DE)$group_weights <= cUP), is_true()) }) Added: pkg/PortfolioAnalytics/inst/tests/test_demo_leverage.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_leverage.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_leverage.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,54 @@ + +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/demo_leverage_exposure_constraint.R") + +context("dollar neutral portfolio") + +test_that("dollar.neutral.portf min_sum constraint is -0.01", + { expect_equal(dollar.neutral.portf$constraints[[1]]$min_sum, -0.01) }) + +test_that("dollar.neutral.portf max_sum constraint is 0.01", + { expect_equal(dollar.neutral.portf$constraints[[1]]$max_sum, 0.01) }) + +test_that("dollar.neutral.portf leverage exposure constraint is 2", + { expect_equal(dollar.neutral.portf$constraints[[3]]$leverage, 2) }) + +test_that("dollar.neutral.portf weights is a numeric vector", + { expect_that(is.numeric(extractWeights(dollar.neutral.opt)), is_true()) }) + +test_that("dollar.neutral.portf leverage exposure constraint is not violated", + { expect_that(sum(abs(extractWeights(dollar.neutral.opt))) <= 2, is_true()) }) + +test_that("dollar.neutral.portf objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(dollar.neutral.opt)$mean), is_true()) }) + +test_that("dollar.neutral.portf objective measure ES is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(dollar.neutral.opt)$ES), is_true()) }) + + +context("leveraged portfolio") + +test_that("leveraged.portf min_sum constraint is 0.99", + { expect_equal(leveraged.portf$constraints[[1]]$min_sum, 0.99) }) + +test_that("leveraged.portf max_sum constraint is 1.01", + { expect_equal(leveraged.portf$constraints[[1]]$max_sum, 1.01) }) + +test_that("leveraged.portf leverage exposure constraint is 1.6", + { expect_equal(leveraged.portf$constraints[[3]]$leverage, 1.6) }) + +test_that("leveraged.portf weights is a numeric vector", + { expect_that(is.numeric(extractWeights(leveraged.portf)), is_true()) }) + +test_that("leveraged.portf leverage exposure constraint is not violated", + { expect_that(sum(abs(extractWeights(leveraged.portf))) <= 1.6, is_true()) }) + +test_that("leveraged.portf objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(leveraged.portf)$mean), is_true()) }) + +test_that("leveraged.portf objective measure ES is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(leveraged.portf)$ES), is_true()) }) Added: pkg/PortfolioAnalytics/inst/tests/test_demo_max_STARR.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_max_STARR.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_max_STARR.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,45 @@ + +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/demo_max_STARR.R") + +context("demo_max_STARR") + +test_that("init.portf contains mean as an objective", + { expect_that(init.portf$objectives[[1]]$name == "mean", is_true()) }) + +test_that("init.portf contains ES as an objective", + { expect_that(init.portf$objectives[[2]]$name == "ES", is_true()) }) + +test_that("init.portf contains ES as an objective with p=0.925", + { expect_that(init.portf$objectives[[2]]$arguments$p == 0.925, is_true()) }) + +##### maxSR.lo.ROI ##### +context("maxSTARR.lo.ROI") + +test_that("maxSTARR.lo.ROI objective measure mean = 0.006657183", + { expect_that(all.equal(extractObjectiveMeasures(maxSTARR.lo.ROI)$mean, 0.006657183), is_true()) }) + +test_that("maxSTARR.lo.ROI objective measure ES = 0.01394436", + { expect_that(all.equal(extractObjectiveMeasures(maxSTARR.lo.ROI)$ES, 0.01394436), is_true()) }) + +##### maxSTARR.lo.RP ##### +context("maxSTARR.lo.RP") + +test_that("maxSTARR.lo.RP objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.RP)$mean), is_true()) }) + +test_that("maxSTARR.lo.RP objective measure ES is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.RP)$StdDev), is_true()) }) + +##### maxSTARR.lo.DE ##### +context("maxSTARR.lo.DE") + +test_that("maxSTARR.lo.DE objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.DE)$mean), is_true()) }) + +test_that("maxSR.lo.DE objective measure StdDev is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.DE)$StdDev), is_true()) }) Added: pkg/PortfolioAnalytics/inst/tests/test_demo_max_qu.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_max_qu.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_max_qu.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,71 @@ +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/demo_max_quadratic_utility.R") + +context("demo_max_quadratic_utility") + +##### init.portf objectives ##### +context("objectives for quadratic utility") + +test_that("init.portf contains mean as an objective", + { expect_that(init.portf$objectives[[1]]$name == "mean", is_true()) }) + +test_that("init.portf contains StdDev as an objective", + { expect_that(init.portf$objectives[[2]]$name == "StdDev", is_true()) }) + +test_that("init.portf contains risk_aversion parameter equal to 4", + { expect_that(init.portf$objectives[[2]]$risk_aversion == 4, is_true()) }) + +##### ROI, full_investment, long only, max qu ###### +context("maxQU.lo.ROI") + +test_that("maxQU.lo.ROI objective measure mean = 0.007813251", + { expect_that(all.equal(extractObjectiveMeasures(maxQU.lo.ROI)$mean, 0.007813251), is_true()) }) + +test_that("maxQU.lo.ROI objective measure StdDev = 0.01556929", + { expect_that(all.equal(extractObjectiveMeasures(maxQU.lo.ROI)$StdDev, 0.01556929), is_true()) }) + +test_that("maxQU.lo.ROI min box constraints are not violated", + { expect_that(all(extractWeights(maxQU.lo.ROI) >= maxQU.lo.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("maxret.lo.ROI max box constraints are not violated", + { expect_that(all(extractWeights(maxQU.lo.ROI) <= maxQU.lo.ROI$portfolio$constraints[[2]]$max), is_true()) }) + +##### ROI, full_investment, long only, max qu to approximate max return ###### +context("maxQU.maxret.ROI") + +test_that("risk aversion parameter = 1e-6", + { expect_that(all.equal(init.portf$objectives[[2]]$risk_aversion, 1e-6), is_true()) }) + +test_that("maxQU.maxret.ROI objective measure mean = 0.008246053", + { expect_that(all.equal(extractObjectiveMeasures(maxQU.maxret.ROI)$mean, 0.008246053), is_true()) }) + +test_that("maxQU.maxret.ROI objective measure StdDev = 0.03857144", + { expect_that(all.equal(extractObjectiveMeasures(maxQU.maxret.ROI)$StdDev, 0.03857144), is_true()) }) + +test_that("maxQU.maxret.ROI min box constraints are not violated", + { expect_that(all(extractWeights(maxQU.maxret.ROI) >= maxQU.maxret.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("maxQU.maxret.ROI max box constraints are not violated", + { expect_that(all(extractWeights(maxQU.maxret.ROI) <= maxQU.maxret.ROI$portfolio$constraints[[2]]$max), is_true()) }) + +##### ROI, full_investment, long only, max qu to approximate min StdDev ###### +context("maxQU.minvol.ROI") + +test_that("risk aversion parameter = 1e6", + { expect_that(all.equal(init.portf$objectives[[2]]$risk_aversion, 1e6), is_true()) }) + +test_that("maxQU.minvol.ROI objective measure mean = 0.00603498", + { expect_that(all.equal(extractObjectiveMeasures(maxQU.minvol.ROI)$mean, 0.00603498), is_true()) }) + +test_that("maxQU.minvol.ROI objective measure StdDev = 0.008251084", + { expect_that(all.equal(extractObjectiveMeasures(maxQU.minvol.ROI)$StdDev, 0.008251084), is_true()) }) + +test_that("maxQU.minvol.ROI min box constraints are not violated", + { expect_that(all(extractWeights(maxQU.minvol.ROI) >= maxQU.minvol.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("maxQU.minvol.ROI max box constraints are not violated", + { expect_that(all(extractWeights(maxQU.minvol.ROI) <= maxQU.minvol.ROI$portfolio$constraints[[2]]$max), is_true()) }) Added: pkg/PortfolioAnalytics/inst/tests/test_demo_max_return.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_max_return.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_max_return.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,102 @@ +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/demo_max_return.R") + +context("demo_max_return") + +###### ROI, full_investment, long only, max return ###### +context("maxret.lo.ROI") + +test_that("maxret.lo.ROI contains mean as an objective", + { expect_that(maxret.lo.ROI$portfolio$objectives[[1]]$name == "mean", is_true()) }) + +test_that("maxret.lo.ROI objective measure mean = 0.008246053", + { expect_that(all.equal(extractObjectiveMeasures(maxret.lo.ROI)$mean, 0.008246053), is_true()) }) + +test_that("maxret.lo.ROI min box constraints are not violated", + { expect_that(all(extractWeights(maxret.lo.ROI) >= maxret.lo.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("maxret.lo.ROI max box constraints are not violated", + { expect_that(all(extractWeights(maxret.lo.ROI) <= maxret.lo.ROI$portfolio$constraints[[2]]$max), is_true()) }) + + +###### ROI, full_investment, box, max return ###### +context("maxret.box.ROI") + +test_that("maxret.box.ROI contains mean as an objective", + { expect_that(maxret.box.ROI$portfolio$objectives[[1]]$name == "mean", is_true()) }) + +test_that("maxret.box.ROI objective measure mean = 0.007508355", + { expect_that(all.equal(extractObjectiveMeasures(maxret.box.ROI)$mean, 0.007508355), is_true()) }) + +test_that("maxret.box.ROI min box constraints are not violated", + { expect_that(all(extractWeights(maxret.box.ROI) >= maxret.box.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("maxret.lo.ROI max box constraints are not violated", + { expect_that(all(extractWeights(maxret.box.ROI) <= maxret.box.ROI$portfolio$constraints[[2]]$max), is_true()) }) + +###### RP, full_investment, box with shorting, max return ###### +context("maxret.box1.RP") + +test_that("maxret.box1.RP contains StdDev as an objective", + { expect_that(maxret.box1.RP$portfolio$objectives[[2]]$name == "StdDev", is_true()) }) + +test_that("maxret.box1.RP contains mean as an objective", + { expect_that(maxret.box1.RP$portfolio$objectives[[1]]$name == "mean", is_true()) }) + +test_that("maxret.box1.RP objective measure StdDev is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxret.box1.RP)$StdDev), is_true()) }) + +test_that("maxret.box1.RP objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxret.box1.RP)$mean), is_true()) }) + +test_that("maxret.box1.RP min box constraints are not violated", + { expect_that(all(extractWeights(maxret.box1.RP) >= maxret.box1.RP$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.box1.RP max box constraints are not violated", + { expect_that(all(extractWeights(maxret.box1.RP) <= maxret.box1.RP$portfolio$constraints[[2]]$max), is_true()) }) + +###### RP, full_investment, box, max return ###### +context("maxret.box2.RP") + +test_that("maxret.box2.RP contains StdDev as an objective", + { expect_that(maxret.box2.RP$portfolio$objectives[[2]]$name == "StdDev", is_true()) }) + +test_that("maxret.box2.RP contains mean as an objective", + { expect_that(maxret.box2.RP$portfolio$objectives[[1]]$name == "mean", is_true()) }) + +test_that("maxret.box2.RP objective measure StdDev is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxret.box2.RP)$StdDev), is_true()) }) + +test_that("maxret.box2.RP objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxret.box2.RP)$mean), is_true()) }) + +test_that("maxret.box2.RP min box constraints are not violated", + { expect_that(all(extractWeights(maxret.box2.RP) >= maxret.box2.RP$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("maxret.box2.RP max box constraints are not violated", + { expect_that(all(extractWeights(maxret.box2.RP) <= maxret.box2.RP$portfolio$constraints[[2]]$max), is_true()) }) + +###### DE, full_investment, box, max return ###### +context("maxret.box.DE") + +test_that("maxret.box.DE contains StdDev as an objective", + { expect_that(maxret.box.DE$portfolio$objectives[[2]]$name == "StdDev", is_true()) }) + +test_that("maxret.box.DE contains mean as an objective", + { expect_that(maxret.box.DE$portfolio$objectives[[1]]$name == "mean", is_true()) }) + +test_that("maxret.box.DE objective measure StdDev is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxret.box.DE)$StdDev), is_true()) }) + +test_that("maxret.box.DE objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(maxret.box.DE)$mean), is_true()) }) + +test_that("maxret.box.DE min box constraints are not violated", + { expect_that(all(extractWeights(maxret.box.DE) >= maxret.box.DE$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("maxret.box.DE max box constraints are not violated", + { expect_that(all(extractWeights(maxret.box.DE) <= maxret.box.DE$portfolio$constraints[[2]]$max), is_true()) }) Added: pkg/PortfolioAnalytics/inst/tests/test_demo_min_StdDev.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_min_StdDev.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_min_StdDev.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,102 @@ +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/demo_min_StdDev.R") + +context("demo_min_StdDev") + +###### ROI, full_investment, long only, min StdDev ###### +context("minStdDev.lo.ROI") + +test_that("minStdDev.lo.ROI contains StdDev as an objective", + { expect_that(minStdDev.lo.ROI$portfolio$objectives[[1]]$name == "StdDev", is_true()) }) + +test_that("minStdDev.lo.ROI objective measure StdDev = 0.008251084", + { expect_that(all.equal(extractObjectiveMeasures(minStdDev.lo.ROI)$StdDev, 0.008251084), is_true()) }) + +test_that("minStdDev.lo.ROI min box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.lo.ROI) >= minStdDev.lo.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minStdDev.lo.ROI max box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.lo.ROI) <= minStdDev.lo.ROI$portfolio$constraints[[2]]$max), is_true()) }) + +###### ROI, full_investment, box, min StdDev ###### +context("minStdDev.box.ROI") + +test_that("minStdDev.box.ROI contains StdDev as an objective", + { expect_that(minStdDev.box.ROI$portfolio$objectives[[1]]$name == "StdDev", is_true()) }) + +test_that("minStdDev.box.ROI objective measure StdDev = 0.01096122", + { expect_that(all.equal(extractObjectiveMeasures(minStdDev.box.ROI)$StdDev, 0.01096122), is_true()) }) + +test_that("minStdDev.box.ROI min box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.box.ROI) >= minStdDev.box.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minStdDev.box.ROI max box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.box.ROI) <= minStdDev.box.ROI$portfolio$constraints[[2]]$max), is_true()) }) + +###### RP, full_investment, box, min ES ###### +context("minStdDev.box1.RP") + +test_that("minStdDev.box1.RP contains StdDev as an objective", + { expect_that(minStdDev.box1.RP$portfolio$objectives[[1]]$name == "StdDev", is_true()) }) + +test_that("minStdDev.box1.RP contains mean as an objective", + { expect_that(minStdDev.box1.RP$portfolio$objectives[[2]]$name == "mean", is_true()) }) + +test_that("minStdDev.box1.RP objective measure StDev is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.box1.RP)$StdDev), is_true()) }) + +test_that("minStdDev.box1.RP objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.box1.RP)$mean), is_true()) }) + +test_that("minStdDev.box1.RP min box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.box1.RP) >= minStdDev.box1.RP$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.box1.RP max box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.box1.RP) <= minStdDev.box1.RP$portfolio$constraints[[2]]$max), is_true()) }) + +###### RP, full_investment, box, min StdDev ###### +context("minStdDev.box2.RP") + +test_that("minStdDev.box2.RP contains StdDev as an objective", + { expect_that(minStdDev.box2.RP$portfolio$objectives[[1]]$name == "StdDev", is_true()) }) + +test_that("minStdDev.box2.RP contains mean as an objective", + { expect_that(minStdDev.box2.RP$portfolio$objectives[[2]]$name == "mean", is_true()) }) + +test_that("minStdDev.box2.RP objective measure StDev is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.box2.RP)$StdDev), is_true()) }) + +test_that("minStdDev.box2.RP objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.box2.RP)$mean), is_true()) }) + +test_that("minStdDev.box2.RP min box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.box2.RP) >= minStdDev.box2.RP$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.box1.RP max box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.box2.RP) <= minStdDev.box2.RP$portfolio$constraints[[2]]$max), is_true()) }) + +###### DE, full_investment, box, min StdDev ###### +context("minStdDev.box.DE") + +test_that("minStdDev.box.DE contains StdDev as an objective", + { expect_that(minStdDev.box.DE$portfolio$objectives[[1]]$name == "StdDev", is_true()) }) + +test_that("minStdDev.box.DE contains mean as an objective", + { expect_that(minStdDev.box.DE$portfolio$objectives[[2]]$name == "mean", is_true()) }) + +test_that("minStdDev.box.DE objective measure StDev is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.box.DE)$StdDev), is_true()) }) + +test_that("minStdDev.box.DE objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.box.DE)$mean), is_true()) }) + +test_that("minStdDev.box.DE min box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.box.DE) >= minStdDev.box.DE$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.box1.RP max box constraints are not violated", + { expect_that(all(extractWeights(minStdDev.box.DE) <= minStdDev.box.DE$portfolio$constraints[[2]]$max), is_true()) }) + Added: pkg/PortfolioAnalytics/inst/tests/test_demo_min_expected_shortfall.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_min_expected_shortfall.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_min_expected_shortfall.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,119 @@ + +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + +##### Source Demo Script ##### +source("demo/demo_min_expected_shortfall.R") + +context("demo_min_expected_shortfall") + +###### ROI, full_investment, long only, min ES ###### +context("minES.lo.ROI") + +test_that("minES.lo.ROI contains ES as an objective", + { expect_that(minES.lo.ROI$portfolio$objectives[[1]]$name == "ES", is_true()) }) + +test_that("minES.lo.ROI ES objective p=0.9", + { expect_that(minES.lo.ROI$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + +test_that("minES.lo.ROI objective measure ES = 0.01013571", + { expect_that(all.equal(extractObjectiveMeasures(minES.lo.ROI)$ES, 0.01013571), is_true()) }) + +test_that("minES.lo.ROI min box constraints are not violated", + { expect_that(all(extractWeights(minES.lo.ROI) >= minES.lo.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.lo.ROI max box constraints are not violated", + { expect_that(all(extractWeights(minES.lo.ROI) <= minES.lo.ROI$portfolio$constraints[[2]]$max), is_true()) }) + +###### ROI, full_investment, long only, min ES ###### +context("minES.box.ROI") + +test_that("minES.box.ROI contains ES as an objective", + { expect_that(minES.box.ROI$portfolio$objectives[[1]]$name == "ES", is_true()) }) + +test_that("minES.box.ROI ES objective p=0.9", + { expect_that(minES.box.ROI$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + +test_that("minES.box.ROI objective measure ES = 0.01477709", + { expect_that(all.equal(extractObjectiveMeasures(minES.box.ROI)$ES, 0.01477709), is_true()) }) + +test_that("minES.box.ROI min box constraints are not violated", + { expect_that(all(extractWeights(minES.box.ROI) >= minES.box.ROI$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.box.ROI max box constraints are not violated", + { expect_that(all(extractWeights(minES.box.ROI) <= minES.box.ROI$portfolio$constraints[[2]]$max), is_true()) }) + +###### RP, full_investment, box, min ES ###### +context("minES.box1.RP") + +test_that("minES.box1.RP contains ES as an objective", + { expect_that(minES.box1.RP$portfolio$objectives[[1]]$name == "ES", is_true()) }) + +test_that("minES.box1.RP ES objective p=0.9", + { expect_that(minES.box1.RP$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + +test_that("minES.box1.RP contains mean as an objective", + { expect_that(minES.box1.RP$portfolio$objectives[[2]]$name == "mean", is_true()) }) + +test_that("minES.box1.RP objective measure ES is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minES.box1.RP)$ES), is_true()) }) + +test_that("minES.box1.RP objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minES.box1.RP)$mean), is_true()) }) + +test_that("minES.box1.RP min box constraints are not violated", + { expect_that(all(extractWeights(minES.box1.RP) >= minES.box1.RP$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.box1.RP max box constraints are not violated", + { expect_that(all(extractWeights(minES.box1.RP) <= minES.box1.RP$portfolio$constraints[[2]]$max), is_true()) }) + +###### RP, full_investment, box, min ES ###### +context("minES.box2.RP") + +test_that("minES.box2.RP contains ES as an objective", + { expect_that(minES.box2.RP$portfolio$objectives[[1]]$name == "ES", is_true()) }) + +test_that("minES.box2.RP ES objective p=0.9", + { expect_that(minES.box2.RP$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + +test_that("minES.box2.RP contains mean as an objective", + { expect_that(minES.box2.RP$portfolio$objectives[[2]]$name == "mean", is_true()) }) + +test_that("minES.box2.RP objective measure ES is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minES.box2.RP)$ES), is_true()) }) + +test_that("minES.box2.RP objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minES.box2.RP)$mean), is_true()) }) + +test_that("minES.box2.RP min box constraints are not violated", + { expect_that(all(extractWeights(minES.box2.RP) >= minES.box2.RP$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.box2.RP max box constraints are not violated", + { expect_that(all(extractWeights(minES.box2.RP) <= minES.box2.RP$portfolio$constraints[[2]]$max), is_true()) }) + +###### DE, full_investment, box, min ES ###### +context("minES.box1.DE") + +test_that("minES.box.DE contains ES as an objective", + { expect_that(minES.box.DE$portfolio$objectives[[1]]$name == "ES", is_true()) }) + +test_that("minES.box.DE ES objective p=0.9", + { expect_that(minES.box.DE$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + +test_that("minES.box2.DE contains mean as an objective", + { expect_that(minES.box.DE$portfolio$objectives[[2]]$name == "mean", is_true()) }) + +test_that("minES.box.DE objective measure ES is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minES.box.DE)$ES), is_true()) }) + +test_that("minES.box.DE objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(minES.box.DE)$mean), is_true()) }) + +test_that("minES.box.DE min box constraints are not violated", + { expect_that(all(extractWeights(minES.box.DE) >= minES.box.DE$portfolio$constraints[[2]]$min), is_true()) }) + +test_that("minES.box.DE max box constraints are not violated", + { expect_that(all(extractWeights(minES.box.DE) <= minES.box.DE$portfolio$constraints[[2]]$max), is_true()) }) + + Added: pkg/PortfolioAnalytics/inst/tests/test_demo_return_target.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_return_target.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_return_target.R 2013-12-15 23:00:17 UTC (rev 3278) @@ -0,0 +1,43 @@ + +##### Load packages ##### +require(testthat) +require(PortfolioAnalytics) + [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3278 From noreply at r-forge.r-project.org Mon Dec 16 00:03:29 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 00:03:29 +0100 (CET) Subject: [Returnanalytics-commits] r3279 - pkg/PortfolioAnalytics/R Message-ID: <20131215230329.52B68186A1E@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 00:03:28 +0100 (Mon, 16 Dec 2013) New Revision: 3279 Modified: pkg/PortfolioAnalytics/R/applyFUN.R pkg/PortfolioAnalytics/R/extractstats.R Log: syntax format in extractStats.optimize.portfolio.ROI and changing applyFUN to explicitly use a function argument instead of dots Modified: pkg/PortfolioAnalytics/R/applyFUN.R =================================================================== --- pkg/PortfolioAnalytics/R/applyFUN.R 2013-12-15 23:00:17 UTC (rev 3278) +++ pkg/PortfolioAnalytics/R/applyFUN.R 2013-12-15 23:03:28 UTC (rev 3279) @@ -9,8 +9,8 @@ #' @param ... any passthrough arguments to FUN #' @author Ross Bennett #' @export -applyFUN <- function(R, weights, FUN="mean", ...){ - nargs <- list(...) +applyFUN <- function(R, weights, FUN="mean", arguments){ + nargs <- arguments moments <- function(R){ momentargs <- list() @@ -95,8 +95,8 @@ #' @param ... any passthrough arguments to FUN #' @author Ross Bennett #' @export -scatterFUN <- function(R, FUN, ...){ - nargs <- list(...) +scatterFUN <- function(R, FUN, arguments){ + nargs <- arguments # match the FUN arg to a risk or return function switch(FUN, Modified: pkg/PortfolioAnalytics/R/extractstats.R =================================================================== --- pkg/PortfolioAnalytics/R/extractstats.R 2013-12-15 23:00:17 UTC (rev 3278) +++ pkg/PortfolioAnalytics/R/extractstats.R 2013-12-15 23:03:28 UTC (rev 3279) @@ -215,13 +215,14 @@ #' @export extractStats.optimize.portfolio.ROI <- function(object, prefix=NULL, ...) { if(!inherits(object, "optimize.portfolio.ROI")) stop("object must be of class optimize.portfolio.ROI") - trow<-c(out=object$out, object$weights) - + trow <- c(object$out, object$weights) objmeas <- extractObjectiveMeasures(object) objnames <- names(objmeas) obj <- unlist(objmeas) result <- c(obj, trow) - rnames<-c(objnames, 'out',paste('w',names(object$weights),sep='.')) + rnames<-c(objnames, 'out', paste('w', names(object$weights), sep='.')) + #print(result) + #print(rnames) names(result)<-rnames return(result) } From noreply at r-forge.r-project.org Mon Dec 16 00:05:34 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 00:05:34 +0100 (CET) Subject: [Returnanalytics-commits] r3280 - pkg/PortfolioAnalytics/R Message-ID: <20131215230534.304D4186A3F@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 00:05:33 +0100 (Mon, 16 Dec 2013) New Revision: 3280 Modified: pkg/PortfolioAnalytics/R/moment.functions.R pkg/PortfolioAnalytics/R/optFUN.R Log: Modifying bounds for etl_opt and adding mean as an objective name to set.portfolio.moments Modified: pkg/PortfolioAnalytics/R/moment.functions.R =================================================================== --- pkg/PortfolioAnalytics/R/moment.functions.R 2013-12-15 23:03:28 UTC (rev 3279) +++ pkg/PortfolioAnalytics/R/moment.functions.R 2013-12-15 23:05:33 UTC (rev 3280) @@ -197,6 +197,9 @@ } for (objective in portfolio$objectives){ switch(objective$name, + mean = { + if(is.null(momentargs$mu)) momentargs$mu = matrix( as.vector(apply(R,2,'mean', na.rm=TRUE)),ncol=1) + }, sd =, StdDev = { if(is.null(momentargs$mu)) momentargs$mu = matrix( as.vector(apply(R,2,'mean', na.rm=TRUE)),ncol=1); Modified: pkg/PortfolioAnalytics/R/optFUN.R =================================================================== --- pkg/PortfolioAnalytics/R/optFUN.R 2013-12-15 23:03:28 UTC (rev 3279) +++ pkg/PortfolioAnalytics/R/optFUN.R 2013-12-15 23:05:33 UTC (rev 3280) @@ -396,8 +396,10 @@ N <- ncol(R) T <- nrow(R) # Applying box constraints - bnds <- list(lower=list(ind=seq.int(1L, N), val=as.numeric(constraints$min)), - upper=list(ind=seq.int(1L, N), val=as.numeric(constraints$max))) + LB <- c(as.numeric(constraints$min), rep(0, T), -1) + UB <- c(as.numeric(constraints$max), rep(Inf, T), 1) + bnds <- V_bound(li=seq.int(1L, N+T+1), lb=LB, + ui=seq.int(1L, N+T+1), ub=UB) # Add this check if mean is not an objective and return is a constraints if(!is.na(target)){ From noreply at r-forge.r-project.org Mon Dec 16 00:14:09 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 00:14:09 +0100 (CET) Subject: [Returnanalytics-commits] r3281 - pkg/PortfolioAnalytics/inst/tests Message-ID: <20131215231409.E8E3A185CA0@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 00:14:09 +0100 (Mon, 16 Dec 2013) New Revision: 3281 Added: pkg/PortfolioAnalytics/inst/tests/test_all_constraints.R pkg/PortfolioAnalytics/inst/tests/test_objectives.R Log: Adding tests for constraints and objectives Added: pkg/PortfolioAnalytics/inst/tests/test_all_constraints.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_all_constraints.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_all_constraints.R 2013-12-15 23:14:09 UTC (rev 3281) @@ -0,0 +1,97 @@ + +require(testthat) +require(PortfolioAnalytics) + +context("constraints") + +N <- 4 +init.portf <- portfolio.spec(assets=N) +# Weight_sum constraint +init.portf <- add.constraint(portfolio=init.portf, + type="weight_sum", + min_sum=0.99, + max_sum=1.01) +# Box constraint +init.portf <- add.constraint(portfolio=init.portf, + type="box", + min=0, + max=1) +# Group constraint +init.portf <- add.constraint(portfolio=init.portf, + type="group", + groups=list(c(1, 3), c(2, 4)), + group_min=c(0.15, 0.25), + group_max=c(0.65, 0.55)) +# Turnover constraint +init.portf <- add.constraint(portfolio=init.portf, + type="turnover", + turnover_target=0.6) +# Diversification constraint +init.portf <- add.constraint(portfolio=init.portf, + type="diversification", + div_target=0.55) +# Position limit constraint +init.portf <- add.constraint(portfolio=init.portf, + type="position_limit", + max_pos=3, + max_pos_long=2, + max_pos_short=1) +# Return constraint +init.portf <- add.constraint(portfolio=init.portf, + type="return", + return_target=0.007) +# Factor exposure constraint +init.portf <- add.constraint(portfolio=init.portf, + type="factor_exposure", + B=rep(1, N), + lower=0.9, + upper=1.1) + +tmp_constraints <- PortfolioAnalytics:::get_constraints(init.portf) + +test_that("weight_sum constraint is consistent", { + expect_that(tmp_constraints$min_sum, equals(0.99)) + expect_that(tmp_constraints$max_sum, equals(1.01)) +}) + +test_that("box constraint is consistent", { + expect_that(as.numeric(tmp_constraints$min), equals(rep(0, N))) + expect_that(as.numeric(tmp_constraints$max), equals(rep(1, N))) +}) + +test_that("group constraint is consistent", { + expect_that(is.list(tmp_constraints$groups), is_true()) + expect_that(tmp_constraints$groups[[1]], equals(c(1, 3))) + expect_that(tmp_constraints$groups[[2]], equals(c(2, 4))) + expect_that(tmp_constraints$group_labels, equals(c("group1", "group2"))) + expect_that(tmp_constraints$cLO, equals(c(0.15, 0.25))) + expect_that(tmp_constraints$cUP, equals(c(0.65, 0.55))) +}) + +test_that("turnover constraint is consistent", { + expect_that(tmp_constraints$turnover_target, equals(0.6)) +}) + +test_that("diversification constraint is consistent", { + expect_that(tmp_constraints$div_target, equals(0.55)) +}) + +test_that("position limit constraint is consistent", { + expect_that(tmp_constraints$max_pos, equals(3)) + expect_that(tmp_constraints$max_pos_long, equals(2)) + expect_that(tmp_constraints$max_pos_short, equals(1)) +}) + +test_that("return constraint is consistent", { + expect_that(tmp_constraints$return_target, equals(0.007)) +}) + +B <- matrix(1, ncol=1, nrow=N) +rownames(B) <- paste("Asset", 1:N, sep=".") +colnames(B) <- "factor1" + +test_that("factor exposure constraint is consistent", { + expect_that(tmp_constraints$B, equals(B)) + expect_that(tmp_constraints$lower, equals(0.9)) + expect_that(tmp_constraints$upper, equals(1.1)) +}) Added: pkg/PortfolioAnalytics/inst/tests/test_objectives.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_objectives.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_objectives.R 2013-12-15 23:14:09 UTC (rev 3281) @@ -0,0 +1,40 @@ + +require(testthat) +require(PortfolioAnalytics) + +context("objectives") + +N <- 4 +init.portf <- portfolio.spec(assets=N) +init.portf <- add.objective(portfolio=init.portf, type="return", name="mean", target=0.005) +init.portf <- add.objective(portfolio=init.portf, type="risk", name="ES", arguments=list(p=0.95)) +init.portf <- add.objective(portfolio=init.portf, type="risk_budget", name="ES") + +test_that("return objective is consistent", { + expect_that(init.portf$objectives[[1]]$name, equals("mean")) + expect_that(init.portf$objectives[[1]]$target, equals(0.005)) + expect_that(init.portf$objectives[[1]]$enabled, is_true()) + expect_that(init.portf$objectives[[1]]$multiplier, equals(-1)) + expect_that(class(init.portf$objectives[[1]]), equals(c("return_objective", "objective"))) +}) + +test_that("risk objective is consistent", { + expect_that(init.portf$objectives[[2]]$name, equals("ES")) + expect_that(is.null(init.portf$objectives[[2]]$target), is_true()) + expect_that(init.portf$objectives[[2]]$arguments$portfolio_method, equals("single")) + expect_that(init.portf$objectives[[2]]$arguments$p, equals(0.95)) + expect_that(init.portf$objectives[[2]]$enabled, is_true()) + expect_that(init.portf$objectives[[2]]$multiplier, equals(1)) + expect_that(class(init.portf$objectives[[2]]), equals(c("portfolio_risk_objective", "objective"))) +}) + +test_that("risk objective is consistent", { + expect_that(init.portf$objectives[[3]]$name, equals("ES")) + expect_that(is.null(init.portf$objectives[[3]]$target), is_true()) + expect_that(init.portf$objectives[[3]]$arguments$portfolio_method, equals("component")) + expect_that(init.portf$objectives[[3]]$enabled, is_true()) + expect_that(init.portf$objectives[[3]]$multiplier, equals(1)) + expect_that(init.portf$objectives[[3]]$min_concentration, is_true()) + expect_that(init.portf$objectives[[3]]$min_difference, is_false()) + expect_that(class(init.portf$objectives[[3]]), equals(c("risk_budget_objective", "objective"))) +}) From noreply at r-forge.r-project.org Mon Dec 16 06:26:33 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 06:26:33 +0100 (CET) Subject: [Returnanalytics-commits] r3282 - in pkg/PortfolioAnalytics: demo inst/tests Message-ID: <20131216052633.C1C5F1865E1@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 06:26:32 +0100 (Mon, 16 Dec 2013) New Revision: 3282 Modified: pkg/PortfolioAnalytics/demo/demo_max_return.R pkg/PortfolioAnalytics/demo/demo_min_StdDev.R pkg/PortfolioAnalytics/demo/demo_weight_concentration.R pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R pkg/PortfolioAnalytics/inst/tests/test_demo_efficient_frontier.R pkg/PortfolioAnalytics/inst/tests/test_demo_group_constraints.R pkg/PortfolioAnalytics/inst/tests/test_demo_leverage.R pkg/PortfolioAnalytics/inst/tests/test_demo_max_STARR.R pkg/PortfolioAnalytics/inst/tests/test_demo_max_qu.R pkg/PortfolioAnalytics/inst/tests/test_demo_max_return.R pkg/PortfolioAnalytics/inst/tests/test_demo_min_StdDev.R pkg/PortfolioAnalytics/inst/tests/test_demo_min_expected_shortfall.R pkg/PortfolioAnalytics/inst/tests/test_demo_return_target.R pkg/PortfolioAnalytics/inst/tests/test_demo_risk_budgets.R pkg/PortfolioAnalytics/inst/tests/test_demo_weight_concentration.R pkg/PortfolioAnalytics/inst/tests/test_max_Sharpe.R Log: Cleaning up some of the demos and improving tests Modified: pkg/PortfolioAnalytics/demo/demo_max_return.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_max_return.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/demo/demo_max_return.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -64,7 +64,7 @@ search_size=2000, trace=TRUE) maxret.box1.RP -ploy(maxret.box1.RP, risk.col="StdDev") +plot(maxret.box1.RP, risk.col="StdDev") # create a new portfolio called 'port2' by using init.portf and modify the # box constraints Modified: pkg/PortfolioAnalytics/demo/demo_min_StdDev.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_min_StdDev.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/demo/demo_min_StdDev.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -66,7 +66,7 @@ search_size=2000, trace=TRUE) print(minStdDev.box1.RP) -ploy(minStdDev.box1.RP, risk.col="StdDev") +plot(minStdDev.box1.RP, risk.col="StdDev") # create a new portfolio called 'port2' by using init.portf and modify the # box constraints Modified: pkg/PortfolioAnalytics/demo/demo_weight_concentration.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_weight_concentration.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/demo/demo_weight_concentration.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -28,7 +28,7 @@ conc.portf <- add.objective(portfolio=init.portf, type="weight_concentration", name="HHI", conc_aversion=0, conc_groups=init.portf$category_labels) -opt2 <- optimize.portfolio(R=R, portfolio=conc, optimize_method="ROI", trace=TRUE) +opt2 <- optimize.portfolio(R=R, portfolio=conc.portf, optimize_method="ROI", trace=TRUE) opt2 all.equal(opt1$weights, opt2$weights) chart.Weights(opt2) Modified: pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_backwards_compat.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,7 +4,7 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/backwards_compat.R") +source(system.file("demo/backwards_compat.R", package="PortfolioAnalytics")) context("Backwards compatibility is maintained") @@ -21,8 +21,8 @@ { expect_that(all.equal(as.numeric(gen.constr$min), rep(0, 4)), is_true()) }) # max -test_that("Box constraints max vector is all 1s", - { expect_that(all.equal(as.numeric(gen.constr$max), rep(1, 4)), is_true()) }) +test_that("Box constraints max vector is all 0.55", + { expect_that(all.equal(as.numeric(gen.constr$max), rep(0.55, 4)), is_true()) }) # min_mult test_that("min_mult is null", @@ -62,7 +62,7 @@ # DEoptim optimization test_that("DE optim updated portfolio object", - { expect_that(inherits(optrdev1$portfolio, "portfolio.spec"), is_true()) }) + { expect_that(inherits(optdev1$portfolio, "portfolio.spec"), is_true()) }) test_that("DE optim returns optimal weights", { expect_that(is.numeric(extractWeights(optdev1)), is_true()) }) @@ -78,5 +78,5 @@ { expect_equal(as.numeric(extractWeights(optroiv1)), c(0, 0, 0.46, 0.55)) }) test_that("ROI returns an objective measure mean=0.008193842", - { expect_equal(is.numeric(extractObjectiveMeasures(optroiv1)$mean), 0.008193842) }) + { expect_equal(as.numeric(extractObjectiveMeasures(optroiv1)$mean), 0.008193842) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_efficient_frontier.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_efficient_frontier.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_efficient_frontier.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,7 +4,7 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_efficient_frontier.R") +source(system.file("demo/demo_efficient_frontier.R", package="PortfolioAnalytics")) context("mean-var efficient frontier") @@ -15,10 +15,12 @@ { expect_equal(colnames(meanvar.ef$frontier), c("mean", "StdDev", "out", "w.CA", "w.CTAG", "w.DS", "w.EM", "w.EQM")) }) test_that("first row of meanvar.ef$frontier is consistent", - { expect_equal(as.numeric(meanvar.ef$frontier[1,]), c(0.006765658, 0.01334460, 178.0782, 0.15, 0.15, 0.15, 0.15, 0.4)) }) + { expect_equal(as.numeric(meanvar.ef$frontier[1,]), c(0.006765658, 0.01334460, 178.0782, 0.15, 0.15, 0.15, 0.15, 0.4), + tolerance=1e-6) }) test_that("last row of meanvar.ef$frontier is consistent", - { expect_equal(as.numeric(meanvar.ef$frontier[25,]), c(0.007326513, 0.02070151, 428.5526, 0.15, 0.15, 0.15, 0.4, 0.15)) }) + { expect_equal(as.numeric(meanvar.ef$frontier[25,]), c(0.007326513, 0.02070151, 428.5526, 0.15, 0.15, 0.15, 0.4, 0.15), + tolerance=1e-6) }) context("mean-etl efficient frontier") @@ -29,7 +31,9 @@ { expect_equal(colnames(meanetl.ef$frontier), c("mean", "ES", "out", "w.CA", "w.CTAG", "w.DS", "w.EM", "w.EQM")) }) test_that("first row of meanetl.ef$frontier is consistent", - { expect_equal(as.numeric(meanetl.ef$frontier[1,]), c(0.006887368, 0.02637039, 0.02637039, 0.15, 0.4, 0.15, 0.15, 0.15)) }) + { expect_equal(as.numeric(meanetl.ef$frontier[1,]), c(0.006887368, 0.02637039, 0.02637039, 0.15, 0.4, 0.15, 0.15, 0.15), + tolerance=1e-6) }) test_that("last row of meanetl.ef$frontier is consistent", - { expect_equal(as.numeric(meanetl.ef$frontier[25,]), c(0.007326513, 0.04642908, 0.04642908, 0.15, 0.15, 0.15, 0.4, 0.15)) }) + { expect_equal(as.numeric(meanetl.ef$frontier[25,]), c(0.007326513, 0.04642908, 0.04642908, 0.15, 0.15, 0.15, 0.4, 0.15), + tolerance=1e-6) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_group_constraints.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_group_constraints.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_group_constraints.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,7 +4,7 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_group_constraints.R") +source(system.file("demo/demo_group_constraints.R", package="PortfolioAnalytics")) ##### Test the constraints ##### context("demo_group_constraints") @@ -30,13 +30,15 @@ cUP <- group_constr$cUP ##### ROI Optimization ##### -context("demo_group_constraints") +context("demo_group_constraints optimization") test_that("minStdDev.ROI weights equal c(4.593895e-03, 2.540430e-01, -1.387779e-17, 4.595703e-02, 6.954061e-01)", - { expect_equal(extractWeights(minStdDev.ROI), c(4.593895e-03, 2.540430e-01, -1.387779e-17, 4.595703e-02, 6.954061e-01)) }) + { expect_equal(as.numeric(extractWeights(minStdDev.ROI)), c(4.593895e-03, 2.540430e-01, -1.387779e-17, 4.595703e-02, 6.954061e-01), + tolerance=1e-6) }) test_that("minStdDev.ROI objective measure StdDev = 0.01042408", - { expect_equal(extractObjectiveMeasures(minStdDev.ROI)$StdDev, 0.01042408) }) + { expect_equal(as.numeric(extractObjectiveMeasures(minStdDev.ROI)$StdDev), 0.01042408, + tolerance=1e-6) }) weights.ROI <- extractWeights(minStdDev.ROI) @@ -58,13 +60,13 @@ { expect_that(is.numeric(extractWeights(minStdDev.RP)), is_true()) }) test_that("minStdDev.RP objective measure StdDev is numeric", - { expect_that(extractObjectiveMeasures(minStdDev.RP)$StdDev, is_true()) }) + { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.RP)$StdDev), is_true()) }) weights.RP <- extractWeights(minStdDev.RP) test_that("minStdDev.RP group weights are calculated correctly", { expect_equal(as.numeric(extractGroups(minStdDev.RP)$group_weights), - c(sum(weights.RB[c(1, 3, 5)]), sum(weights.RB[c(2, 4)]))) }) + c(sum(weights.RP[c(1, 3, 5)]), sum(weights.RP[c(2, 4)]))) }) test_that("minStdDev.RP group constraint cLO is not violated", { expect_that(all(extractGroups(minStdDev.RP)$group_weights >= cLO), is_true()) }) @@ -77,7 +79,7 @@ context("minStdDev.DE") test_that("minStdDev.DE weights is a numeric vector", - { expect_equal(extractWeights(minStdDev.DE), is_true()) }) + { expect_that(is.numeric(extractWeights(minStdDev.DE)), is_true()) }) test_that("minStdDev.DE objective measure StdDev is numeric", { expect_that(is.numeric(extractObjectiveMeasures(minStdDev.ROI)$StdDev), is_true()) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_leverage.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_leverage.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_leverage.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,8 +4,9 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_leverage_exposure_constraint.R") +source(system.file("demo/demo_leverage_exposure_constraint.R", package="PortfolioAnalytics")) + context("dollar neutral portfolio") test_that("dollar.neutral.portf min_sum constraint is -0.01", @@ -41,14 +42,14 @@ test_that("leveraged.portf leverage exposure constraint is 1.6", { expect_equal(leveraged.portf$constraints[[3]]$leverage, 1.6) }) -test_that("leveraged.portf weights is a numeric vector", - { expect_that(is.numeric(extractWeights(leveraged.portf)), is_true()) }) +test_that("leveraged.opt weights is a numeric vector", + { expect_that(is.numeric(extractWeights(leveraged.opt)), is_true()) }) -test_that("leveraged.portf leverage exposure constraint is not violated", - { expect_that(sum(abs(extractWeights(leveraged.portf))) <= 1.6, is_true()) }) +test_that("leveraged.opt leverage exposure constraint is not violated", + { expect_that(sum(abs(extractWeights(leveraged.opt))) <= 1.6, is_true()) }) -test_that("leveraged.portf objective measure mean is numeric", - { expect_that(is.numeric(extractObjectiveMeasures(leveraged.portf)$mean), is_true()) }) +test_that("leveraged.opt objective measure mean is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(leveraged.opt)$mean), is_true()) }) -test_that("leveraged.portf objective measure ES is numeric", - { expect_that(is.numeric(extractObjectiveMeasures(leveraged.portf)$ES), is_true()) }) +test_that("leveraged.opt objective measure ES is numeric", + { expect_that(is.numeric(extractObjectiveMeasures(leveraged.opt)$ES), is_true()) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_max_STARR.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_max_STARR.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_max_STARR.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,8 +4,9 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_max_STARR.R") +source(system.file("demo/demo_max_STARR.R", package="PortfolioAnalytics")) + context("demo_max_STARR") test_that("init.portf contains mean as an objective", @@ -15,16 +16,16 @@ { expect_that(init.portf$objectives[[2]]$name == "ES", is_true()) }) test_that("init.portf contains ES as an objective with p=0.925", - { expect_that(init.portf$objectives[[2]]$arguments$p == 0.925, is_true()) }) + { expect_equal(init.portf$objectives[[2]]$arguments$p, 0.925) }) ##### maxSR.lo.ROI ##### context("maxSTARR.lo.ROI") test_that("maxSTARR.lo.ROI objective measure mean = 0.006657183", - { expect_that(all.equal(extractObjectiveMeasures(maxSTARR.lo.ROI)$mean, 0.006657183), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxSTARR.lo.ROI)$mean), 0.006657183, tolerance=1e-6) }) test_that("maxSTARR.lo.ROI objective measure ES = 0.01394436", - { expect_that(all.equal(extractObjectiveMeasures(maxSTARR.lo.ROI)$ES, 0.01394436), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxSTARR.lo.ROI)$ES), 0.01394436, tolerance=1e-6) }) ##### maxSTARR.lo.RP ##### context("maxSTARR.lo.RP") @@ -33,7 +34,7 @@ { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.RP)$mean), is_true()) }) test_that("maxSTARR.lo.RP objective measure ES is numeric", - { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.RP)$StdDev), is_true()) }) + { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.RP)$ES), is_true()) }) ##### maxSTARR.lo.DE ##### context("maxSTARR.lo.DE") @@ -42,4 +43,4 @@ { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.DE)$mean), is_true()) }) test_that("maxSR.lo.DE objective measure StdDev is numeric", - { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.DE)$StdDev), is_true()) }) + { expect_that(is.numeric(extractObjectiveMeasures(maxSTARR.lo.DE)$ES), is_true()) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_max_qu.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_max_qu.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_max_qu.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -3,9 +3,8 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_max_quadratic_utility.R") +source(system.file("demo/demo_max_quadratic_utility.R", package="PortfolioAnalytics")) -context("demo_max_quadratic_utility") ##### init.portf objectives ##### context("objectives for quadratic utility") @@ -16,17 +15,17 @@ test_that("init.portf contains StdDev as an objective", { expect_that(init.portf$objectives[[2]]$name == "StdDev", is_true()) }) -test_that("init.portf contains risk_aversion parameter equal to 4", - { expect_that(init.portf$objectives[[2]]$risk_aversion == 4, is_true()) }) - ##### ROI, full_investment, long only, max qu ###### context("maxQU.lo.ROI") +test_that("risk aversion parameter = 4", + { expect_equal(maxQU.lo.ROI$portfolio$objectives[[2]]$risk_aversion, 4) }) + test_that("maxQU.lo.ROI objective measure mean = 0.007813251", - { expect_that(all.equal(extractObjectiveMeasures(maxQU.lo.ROI)$mean, 0.007813251), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxQU.lo.ROI)$mean), 0.007813251, tolerance=1e-6) }) test_that("maxQU.lo.ROI objective measure StdDev = 0.01556929", - { expect_that(all.equal(extractObjectiveMeasures(maxQU.lo.ROI)$StdDev, 0.01556929), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxQU.lo.ROI)$StdDev), 0.01556929, tolerance=1e-6) }) test_that("maxQU.lo.ROI min box constraints are not violated", { expect_that(all(extractWeights(maxQU.lo.ROI) >= maxQU.lo.ROI$portfolio$constraints[[2]]$min), is_true()) }) @@ -38,13 +37,13 @@ context("maxQU.maxret.ROI") test_that("risk aversion parameter = 1e-6", - { expect_that(all.equal(init.portf$objectives[[2]]$risk_aversion, 1e-6), is_true()) }) + { expect_equal(maxQU.maxret.ROI$portfolio$objectives[[2]]$risk_aversion, 1e-6) }) test_that("maxQU.maxret.ROI objective measure mean = 0.008246053", - { expect_that(all.equal(extractObjectiveMeasures(maxQU.maxret.ROI)$mean, 0.008246053), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxQU.maxret.ROI)$mean), 0.008246053, tolerance=1e-6) }) test_that("maxQU.maxret.ROI objective measure StdDev = 0.03857144", - { expect_that(all.equal(extractObjectiveMeasures(maxQU.maxret.ROI)$StdDev, 0.03857144), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxQU.maxret.ROI)$StdDev), 0.03857144, tolerance=1e-6) }) test_that("maxQU.maxret.ROI min box constraints are not violated", { expect_that(all(extractWeights(maxQU.maxret.ROI) >= maxQU.maxret.ROI$portfolio$constraints[[2]]$min), is_true()) }) @@ -56,13 +55,13 @@ context("maxQU.minvol.ROI") test_that("risk aversion parameter = 1e6", - { expect_that(all.equal(init.portf$objectives[[2]]$risk_aversion, 1e6), is_true()) }) + { expect_equal(maxQU.minvol.ROI$portfolio$objectives[[2]]$risk_aversion, 1e6) }) test_that("maxQU.minvol.ROI objective measure mean = 0.00603498", - { expect_that(all.equal(extractObjectiveMeasures(maxQU.minvol.ROI)$mean, 0.00603498), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxQU.minvol.ROI)$mean), 0.00603498, tolerance=1e-6) }) test_that("maxQU.minvol.ROI objective measure StdDev = 0.008251084", - { expect_that(all.equal(extractObjectiveMeasures(maxQU.minvol.ROI)$StdDev, 0.008251084), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxQU.minvol.ROI)$StdDev), 0.008251084, tolerance=1e-6) }) test_that("maxQU.minvol.ROI min box constraints are not violated", { expect_that(all(extractWeights(maxQU.minvol.ROI) >= maxQU.minvol.ROI$portfolio$constraints[[2]]$min), is_true()) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_max_return.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_max_return.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_max_return.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -3,8 +3,9 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_max_return.R") +source(system.file("demo/demo_max_return.R", package="PortfolioAnalytics")) + context("demo_max_return") ###### ROI, full_investment, long only, max return ###### @@ -14,7 +15,7 @@ { expect_that(maxret.lo.ROI$portfolio$objectives[[1]]$name == "mean", is_true()) }) test_that("maxret.lo.ROI objective measure mean = 0.008246053", - { expect_that(all.equal(extractObjectiveMeasures(maxret.lo.ROI)$mean, 0.008246053), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxret.lo.ROI)$mean), 0.008246053, tolerance=1e-6) }) test_that("maxret.lo.ROI min box constraints are not violated", { expect_that(all(extractWeights(maxret.lo.ROI) >= maxret.lo.ROI$portfolio$constraints[[2]]$min), is_true()) }) @@ -30,7 +31,7 @@ { expect_that(maxret.box.ROI$portfolio$objectives[[1]]$name == "mean", is_true()) }) test_that("maxret.box.ROI objective measure mean = 0.007508355", - { expect_that(all.equal(extractObjectiveMeasures(maxret.box.ROI)$mean, 0.007508355), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxret.box.ROI)$mean), 0.007508355, tolerance=1e-6) }) test_that("maxret.box.ROI min box constraints are not violated", { expect_that(all(extractWeights(maxret.box.ROI) >= maxret.box.ROI$portfolio$constraints[[2]]$min), is_true()) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_min_StdDev.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_min_StdDev.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_min_StdDev.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -3,8 +3,9 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_min_StdDev.R") +source(system.file("demo/demo_min_StdDev.R", package="PortfolioAnalytics")) + context("demo_min_StdDev") ###### ROI, full_investment, long only, min StdDev ###### @@ -14,7 +15,7 @@ { expect_that(minStdDev.lo.ROI$portfolio$objectives[[1]]$name == "StdDev", is_true()) }) test_that("minStdDev.lo.ROI objective measure StdDev = 0.008251084", - { expect_that(all.equal(extractObjectiveMeasures(minStdDev.lo.ROI)$StdDev, 0.008251084), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(minStdDev.lo.ROI)$StdDev), 0.008251084, tolerance=1e-6) }) test_that("minStdDev.lo.ROI min box constraints are not violated", { expect_that(all(extractWeights(minStdDev.lo.ROI) >= minStdDev.lo.ROI$portfolio$constraints[[2]]$min), is_true()) }) @@ -29,7 +30,7 @@ { expect_that(minStdDev.box.ROI$portfolio$objectives[[1]]$name == "StdDev", is_true()) }) test_that("minStdDev.box.ROI objective measure StdDev = 0.01096122", - { expect_that(all.equal(extractObjectiveMeasures(minStdDev.box.ROI)$StdDev, 0.01096122), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(minStdDev.box.ROI)$StdDev), 0.01096122, tolerance=1e-6) }) test_that("minStdDev.box.ROI min box constraints are not violated", { expect_that(all(extractWeights(minStdDev.box.ROI) >= minStdDev.box.ROI$portfolio$constraints[[2]]$min), is_true()) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_min_expected_shortfall.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_min_expected_shortfall.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_min_expected_shortfall.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,7 +4,7 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_min_expected_shortfall.R") +source(system.file("demo/demo_min_expected_shortfall.R", package="PortfolioAnalytics")) context("demo_min_expected_shortfall") @@ -15,10 +15,10 @@ { expect_that(minES.lo.ROI$portfolio$objectives[[1]]$name == "ES", is_true()) }) test_that("minES.lo.ROI ES objective p=0.9", - { expect_that(minES.lo.ROI$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + { expect_equal(minES.lo.ROI$portfolio$objectives[[1]]$arguments$p, 0.9) }) test_that("minES.lo.ROI objective measure ES = 0.01013571", - { expect_that(all.equal(extractObjectiveMeasures(minES.lo.ROI)$ES, 0.01013571), is_true()) }) + { expect_equal(extractObjectiveMeasures(minES.lo.ROI)$ES, 0.01013571, tolerance=1e-6) }) test_that("minES.lo.ROI min box constraints are not violated", { expect_that(all(extractWeights(minES.lo.ROI) >= minES.lo.ROI$portfolio$constraints[[2]]$min), is_true()) }) @@ -33,10 +33,10 @@ { expect_that(minES.box.ROI$portfolio$objectives[[1]]$name == "ES", is_true()) }) test_that("minES.box.ROI ES objective p=0.9", - { expect_that(minES.box.ROI$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + { expect_equal(minES.box.ROI$portfolio$objectives[[1]]$arguments$p, 0.9) }) test_that("minES.box.ROI objective measure ES = 0.01477709", - { expect_that(all.equal(extractObjectiveMeasures(minES.box.ROI)$ES, 0.01477709), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(minES.box.ROI)$ES), 0.01477709, tolerance=1e-6) }) test_that("minES.box.ROI min box constraints are not violated", { expect_that(all(extractWeights(minES.box.ROI) >= minES.box.ROI$portfolio$constraints[[2]]$min), is_true()) }) @@ -51,7 +51,7 @@ { expect_that(minES.box1.RP$portfolio$objectives[[1]]$name == "ES", is_true()) }) test_that("minES.box1.RP ES objective p=0.9", - { expect_that(minES.box1.RP$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + { expect_equal(minES.box1.RP$portfolio$objectives[[1]]$arguments$p, 0.9) }) test_that("minES.box1.RP contains mean as an objective", { expect_that(minES.box1.RP$portfolio$objectives[[2]]$name == "mean", is_true()) }) @@ -75,7 +75,7 @@ { expect_that(minES.box2.RP$portfolio$objectives[[1]]$name == "ES", is_true()) }) test_that("minES.box2.RP ES objective p=0.9", - { expect_that(minES.box2.RP$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + { expect_equal(minES.box2.RP$portfolio$objectives[[1]]$arguments$p, 0.9) }) test_that("minES.box2.RP contains mean as an objective", { expect_that(minES.box2.RP$portfolio$objectives[[2]]$name == "mean", is_true()) }) @@ -99,7 +99,7 @@ { expect_that(minES.box.DE$portfolio$objectives[[1]]$name == "ES", is_true()) }) test_that("minES.box.DE ES objective p=0.9", - { expect_that(minES.box.DE$portfolio$objectives[[1]]$arguments$p == 0.9, is_true()) }) + { expect_equal(minES.box.DE$portfolio$objectives[[1]]$arguments$p, 0.9) }) test_that("minES.box2.DE contains mean as an objective", { expect_that(minES.box.DE$portfolio$objectives[[2]]$name == "mean", is_true()) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_return_target.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_return_target.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_return_target.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,24 +4,25 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_return_target.R") +source(system.file("demo/demo_return_target.R", package="PortfolioAnalytics")) + context("target return as an objective") test_that("ret.obj.portf contains mean as an objective", { expect_that(ret.obj.portf$objectives[[1]]$name == "mean", is_true()) }) test_that("ret.obj.portf contains mean as an objective with target = 0.007", - { expect_that(ret.obj.portf$objectives[[1]]$target == 0.007, is_true()) }) + { expect_equal(ret.obj.portf$objectives[[1]]$target, 0.007) }) test_that("ret.obj.opt objective measure mean = 0.007", - { expect_equal(extractObjectiveMeasures(ret.obj.opt)$mean, 0.007) }) + { expect_equal(as.numeric(extractObjectiveMeasures(ret.obj.opt)$mean), 0.007, tolerance=0.0001) }) test_that("opt.obj.de objective measure mean = 0.007", - { expect_equal(extractObjectiveMeasures(opt.obj.de)$mean, 0.007, tolerance=0.00001) }) + { expect_equal(as.numeric(extractObjectiveMeasures(opt.obj.de)$mean), 0.007, tolerance=0.0001) }) test_that("opt.obj.rp objective measure mean = 0.007", - { expect_equal(extractObjectiveMeasures(opt.obj.rp)$mean, 0.007, tolerance=0.00001) }) + { expect_equal(as.numeric(extractObjectiveMeasures(opt.obj.rp)$mean), 0.007, tolerance=0.0001) }) context("target return as a constraint") @@ -29,15 +30,15 @@ { expect_that(ret.constr.portf$constraints[[3]]$type == "return", is_true()) }) test_that("ret.obj.portf contains mean as a constraint with target = 0.007", - { expect_that(ret.constr.portf$constraints[[3]]$return_target == 0.007, is_true()) }) + { expect_equal(ret.constr.portf$constraints[[3]]$return_target, 0.007) }) test_that("ret.constr.opt objective measure mean = 0.007", - { expect_equal(extractObjectiveMeasures(ret.constr.opt)$mean, 0.007) }) + { expect_equal(as.numeric(extractObjectiveMeasures(ret.constr.opt)$mean), 0.007, tolerance=0.0001) }) test_that("opt.constr.de objective measure mean = 0.007", - { expect_equal(extractObjectiveMeasures(opt.constr.de)$mean, 0.007, tolerance=0.00001) }) + { expect_equal(as.numeric(extractObjectiveMeasures(opt.constr.de)$mean), 0.007, tolerance=0.0001) }) test_that("opt.constr.rp objective measure mean = 0.007", - { expect_equal(extractObjectiveMeasures(opt.constr.rp)$mean, 0.007, tolerance=0.00001) }) + { expect_equal(as.numeric(extractObjectiveMeasures(opt.constr.rp)$mean), 0.007, tolerance=0.0001) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_risk_budgets.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_risk_budgets.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_risk_budgets.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,8 +4,9 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_risk_budgets.R") +source(system.file("demo/demo_risk_budgets.R", package="PortfolioAnalytics")) + context("Risk Budget Optimizations") context("risk budget objective ES max_prisk") Modified: pkg/PortfolioAnalytics/inst/tests/test_demo_weight_concentration.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_demo_weight_concentration.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_demo_weight_concentration.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,7 +4,7 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_weight_concentration.R") +source(system.file("demo/demo_weight_concentration.R", package="PortfolioAnalytics")) context("weight concentration objective") @@ -15,7 +15,7 @@ { expect_that(conc.portf$objectives[[2]]$name == "HHI", is_true()) }) test_that("conc.portf contains weight_concentration as an objective with conc_aversion=0", - { expect_equal(conc.portf$objectives[[2]]$conc_aversion, rep(0, 4)) }) + { expect_equal(opt2$portfolio$objectives[[2]]$conc_aversion, rep(0, 4)) }) test_that("minimum variance and conc.portf weights are equal with conc_aversion=0", { expect_equal(opt1$weights, opt2$weights) }) Modified: pkg/PortfolioAnalytics/inst/tests/test_max_Sharpe.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_max_Sharpe.R 2013-12-15 23:14:09 UTC (rev 3281) +++ pkg/PortfolioAnalytics/inst/tests/test_max_Sharpe.R 2013-12-16 05:26:32 UTC (rev 3282) @@ -4,8 +4,9 @@ require(PortfolioAnalytics) ##### Source Demo Script ##### -source("demo/demo_max_Sharpe.R") +source(system.file("demo/demo_max_Sharpe.R", package="PortfolioAnalytics")) + context("demo_max_Sharpe") test_that("init.portf contains mean as an objective", @@ -18,10 +19,10 @@ context("maxSR.lo.ROI") test_that("maxSR.lo.ROI objective measure mean = 0.006062083", - { expect_that(all.equal(extractObjectiveMeasures(maxSR.lo.ROI)$mean, 0.006062083), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxSR.lo.ROI)$mean), 0.006062083, tolerance=1e-6) }) test_that("maxSR.lo.ROI objective measure StdDev = 0.008843188", - { expect_that(all.equal(extractObjectiveMeasures(maxSR.lo.ROI)$StdDev, 0.008843188), is_true()) }) + { expect_equal(as.numeric(extractObjectiveMeasures(maxSR.lo.ROI)$StdDev), 0.008843188, tolerance=1e-6) }) ##### maxSR.lo.RP ##### context("maxSR.lo.RP") From noreply at r-forge.r-project.org Mon Dec 16 06:28:37 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 06:28:37 +0100 (CET) Subject: [Returnanalytics-commits] r3283 - pkg/PortfolioAnalytics/R Message-ID: <20131216052837.96251186299@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 06:28:36 +0100 (Mon, 16 Dec 2013) New Revision: 3283 Modified: pkg/PortfolioAnalytics/R/applyFUN.R pkg/PortfolioAnalytics/R/extract.efficient.frontier.R Log: Cleaning up applyFUN and efficient frontiers Modified: pkg/PortfolioAnalytics/R/applyFUN.R =================================================================== --- pkg/PortfolioAnalytics/R/applyFUN.R 2013-12-16 05:26:32 UTC (rev 3282) +++ pkg/PortfolioAnalytics/R/applyFUN.R 2013-12-16 05:28:36 UTC (rev 3283) @@ -6,7 +6,7 @@ #' @param R xts object of asset returns #' @param weights a matrix of weights generated from random_portfolios or \code{optimize.portfolio} #' @param FUN name of a function -#' @param ... any passthrough arguments to FUN +#' @param arguments named list of arguments to FUN #' @author Ross Bennett #' @export applyFUN <- function(R, weights, FUN="mean", arguments){ @@ -92,11 +92,15 @@ #' #' @param R xts object of asset returns #' @param FUN name of function -#' @param ... any passthrough arguments to FUN +#' @param arguments named list of arguments to FUN #' @author Ross Bennett #' @export -scatterFUN <- function(R, FUN, arguments){ - nargs <- arguments +scatterFUN <- function(R, FUN, arguments=NULL){ + if(is.null(arguments)){ + nargs <- list() + } else{ + nargs <- arguments + } # match the FUN arg to a risk or return function switch(FUN, Modified: pkg/PortfolioAnalytics/R/extract.efficient.frontier.R =================================================================== --- pkg/PortfolioAnalytics/R/extract.efficient.frontier.R 2013-12-16 05:26:32 UTC (rev 3282) +++ pkg/PortfolioAnalytics/R/extract.efficient.frontier.R 2013-12-16 05:28:36 UTC (rev 3283) @@ -184,6 +184,7 @@ } colnames(out) <- c("mean", names(stats)) } + out <- na.omit(out) return(structure(out, class="frontier")) } @@ -257,8 +258,7 @@ # length.out is the number of portfolios to create ret_seq <- seq(from=minret, to=maxret, length.out=n.portfolios) - out <- matrix(0, nrow=length(ret_seq), ncol=length(extractStats(tmp))) - +# out <- matrix(0, nrow=length(ret_seq), ncol=length(extractStats(tmp))) # for(i in 1:length(ret_seq)){ # portfolio$objectives[[mean_idx]]$target <- ret_seq[i] # out[i, ] <- extractStats(optimize.portfolio(R=R, portfolio=portfolio, optimize_method="ROI")) @@ -269,6 +269,7 @@ extractStats(optimize.portfolio(R=R, portfolio=portfolio, optimize_method="ROI", ef=TRUE, ...=...)) } colnames(out) <- names(stats) + out <- na.omit(out) return(structure(out, class="frontier")) } From noreply at r-forge.r-project.org Mon Dec 16 06:32:31 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 06:32:31 +0100 (CET) Subject: [Returnanalytics-commits] r3284 - pkg/PortfolioAnalytics/R Message-ID: <20131216053231.DE009186739@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 06:32:31 +0100 (Mon, 16 Dec 2013) New Revision: 3284 Modified: pkg/PortfolioAnalytics/R/constrained_objective.R pkg/PortfolioAnalytics/R/optimize.portfolio.R Log: Slight modifications to how moments and arguments are passed for calculating tmp_measure. Test and benchmark with this before using an environment. Modified: pkg/PortfolioAnalytics/R/constrained_objective.R =================================================================== --- pkg/PortfolioAnalytics/R/constrained_objective.R 2013-12-16 05:28:36 UTC (rev 3283) +++ pkg/PortfolioAnalytics/R/constrained_objective.R 2013-12-16 05:32:31 UTC (rev 3284) @@ -345,7 +345,7 @@ #' @aliases constrained_objective constrained_objective_v1 #' @rdname constrained_objective #' @export -constrained_objective_v2 <- function(w, R, portfolio, ..., trace=FALSE, normalize=TRUE, storage=FALSE, moments=NULL) +constrained_objective_v2 <- function(w, R, portfolio, ..., trace=FALSE, normalize=TRUE, storage=FALSE, env=NULL) { if (ncol(R) > length(w)) { R <- R[ ,1:length(w)] @@ -474,7 +474,7 @@ # penalize weights that violate return target constraint if(!is.null(constraints$return_target)){ return_target <- constraints$return_target - mean_return <- port.mean(weights=w, mu=moments$mu) + mean_return <- port.mean(weights=w, mu=env$mu) mult <- 1 out = out + penalty * mult * abs(mean_return - return_target) } # End return constraint penalty @@ -524,8 +524,12 @@ # trust that all the moments are correctly set in optimize.portfolio through # momentFUN? - if(!is.null(moments)){ - nargs <- moments + # Add R and w to the environment with the moments + # env$R <- R + # env$weights <- w + + if(!is.null(env)){ + nargs <- env } else { # print("calculating moments") # calculating the moments @@ -546,6 +550,9 @@ # should be avoided because nargs could be large because it contains the moments. tmp_args <- list() + # JMU: Add all the variables in 'env' to tmp_args as names/symbols + # tmp_args[ls(env)] <- lapply(ls(env), as.name) + if(is.null(portfolio$objectives)) { warning("no objectives specified in portfolio") } else{ @@ -576,7 +583,7 @@ VaR = { fun = match.fun(VaR) if(!inherits(objective,"risk_budget_objective") & is.null(objective$arguments$portfolio_method) & is.null(nargs$portfolio_method)) tmp_args$portfolio_method='single' - if(is.null(objective$arguments$invert)) objective$arguments$invert = FALSE + if(is.null(objective$arguments$invert)) tmp_args$invert = FALSE }, es =, mES =, @@ -587,7 +594,7 @@ ES = { fun = match.fun(ES) if(!inherits(objective,"risk_budget_objective") & is.null(objective$arguments$portfolio_method) & is.null(nargs$portfolio_method)) tmp_args$portfolio_method='single' - if(is.null(objective$arguments$invert)) objective$arguments$invert = FALSE + if(is.null(objective$arguments$invert)) tmp_args$invert = FALSE }, turnover = { fun = match.fun(turnover) # turnover function included in objectiveFUN.R @@ -609,11 +616,12 @@ # Add R and weights if necessary if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=R, dots=TRUE) if("weights" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, weights=w, dots=TRUE) + # .formals <- modify.args(formals=.formals, arglist=tmp_args, dots=TRUE) .formals$... <- NULL } - # print(.formals) - tmp_measure <- try((do.call(fun,.formals)), silent=TRUE) + # tmp_measure <- try(do.call(fun, .formals, envir=env), silent=TRUE) + tmp_measure <- try(do.call(fun, .formals), silent=TRUE) if(isTRUE(trace) | isTRUE(storage)) { # Subsitute 'StdDev' if the objective name is 'var' Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R =================================================================== --- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-16 05:28:36 UTC (rev 3283) +++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-16 05:32:31 UTC (rev 3284) @@ -511,9 +511,16 @@ # call momentFUN mout <- try(do.call(momentFUN, .formals), silent=TRUE) - if(inherits(mout,"try-error")) { - message(paste("portfolio moment function failed with message",mout)) + + if(inherits(mout, "try-error")) { + message(paste("portfolio moment function failed with message", mout)) } else { + #.args_env <- as.environment(mout) + #.args_env <- new.env() + # Assign each element of mout to the .args_env environment + #for(name in names(mout)){ + # .args_env[[name]] <- mout[[name]] + #} dotargs <- mout } @@ -614,14 +621,15 @@ # if(hasArg(eps)) eps=match.call(expand.dots=TRUE)$eps else eps = 0.01 if(hasArg(rp_method)) rp_method=match.call(expand.dots=TRUE)$rp_method else rp_method="sample" if(hasArg(eliminate)) eliminate=match.call(expand.dots=TRUE)$eliminate else eliminate=TRUE - rp <- random_portfolios(portfolio=portfolio, permutations=NP, rp_method=rp_method, eliminate=eliminate, ...) + if(hasArg(fev)) fev=match.call(expand.dots=TRUE)$fev else fev=0:5 + rp <- random_portfolios(portfolio=portfolio, permutations=NP, rp_method=rp_method, eliminate=eliminate, fev=fev) DEcformals$initialpop <- rp } controlDE <- do.call(DEoptim.control, DEcformals) # We are passing fn_map to the optional fnMap function to do the # transformation so we need to force normalize=FALSE in call to constrained_objective - minw = try(DEoptim( constrained_objective, lower=lower[1:N], upper=upper[1:N], control=controlDE, R=R, portfolio=portfolio, moments = dotargs, normalize=FALSE, fnMap=function(x) fn_map(x, portfolio=portfolio)$weights)) # add ,silent=TRUE here? + minw = try(DEoptim( constrained_objective, lower=lower[1:N], upper=upper[1:N], control=controlDE, R=R, portfolio=portfolio, env=dotargs, normalize=FALSE, fnMap=function(x) fn_map(x, portfolio=portfolio)$weights), silent=TRUE) if(inherits(minw, "try-error")) { minw=NULL } if(is.null(minw)){ @@ -636,7 +644,7 @@ # is it necessary to normalize the weights here? # weights <- normalize_weights(weights) names(weights) <- colnames(R) - obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE, moments=dotargs)$objective_measures + obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE, env=dotargs)$objective_measures out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=minw$optim$bestval, call=call) if (isTRUE(trace)){ out$DEoutput <- minw @@ -658,16 +666,17 @@ if(missing(rp) | is.null(rp)){ if(hasArg(rp_method)) rp_method=match.call(expand.dots=TRUE)$rp_method else rp_method="sample" if(hasArg(eliminate)) eliminate=match.call(expand.dots=TRUE)$eliminate else eliminate=TRUE - rp <- random_portfolios(portfolio=portfolio, permutations=search_size, rp_method=rp_method, eliminate=eliminate, ...) + if(hasArg(fev)) fev=match.call(expand.dots=TRUE)$fev else fev=0:5 + rp <- random_portfolios(portfolio=portfolio, permutations=search_size, rp_method=rp_method, eliminate=eliminate, fev=fev) } #' store matrix in out if trace=TRUE if (isTRUE(trace)) out$random_portfolios <- rp # rp is already being generated with a call to fn_map so set normalize=FALSE in the call to constrained_objective #' write foreach loop to call constrained_objective() with each portfolio if ("package:foreach" %in% search() & !hasArg(parallel)){ - rp_objective_results <- foreach(ii=1:nrow(rp), .errorhandling='pass') %dopar% constrained_objective(w=rp[ii,], R=R, portfolio=portfolio, trace=trace, moments=dotargs, normalize=FALSE) + rp_objective_results <- foreach(ii=1:nrow(rp), .errorhandling='pass') %dopar% constrained_objective(w=rp[ii,], R=R, portfolio=portfolio, trace=trace, env=dotargs, normalize=FALSE) } else { - rp_objective_results <- apply(rp, 1, constrained_objective, R=R, portfolio=portfolio, trace=trace, normalize=FALSE, moments=dotargs) + rp_objective_results <- apply(rp, 1, constrained_objective, R=R, portfolio=portfolio, trace=trace, normalize=FALSE, env=dotargs) } #' if trace=TRUE , store results of foreach in out$random_results if(isTRUE(trace)) out$random_portfolio_objective_results <- rp_objective_results @@ -691,7 +700,7 @@ } #' re-call constrained_objective on the best portfolio, as above in DEoptim, with trace=TRUE to get results for out list out$weights <- min_objective_weights - obj_vals <- try(constrained_objective(w=min_objective_weights, R=R, portfolio=portfolio, trace=TRUE, normalize=FALSE, moments=dotargs)$objective_measures) + obj_vals <- try(constrained_objective(w=min_objective_weights, R=R, portfolio=portfolio, trace=TRUE, normalize=FALSE, env=dotargs)$objective_measures) out$objective_measures <- obj_vals out$opt_values <- obj_vals out$call <- call @@ -898,7 +907,7 @@ upper <- constraints$max lower <- constraints$min - minw <- try(psoptim( par = rep(NA, N), fn = constrained_objective, R=R, portfolio=portfolio, moments=dotargs, + minw <- try(psoptim( par = rep(NA, N), fn = constrained_objective, R=R, portfolio=portfolio, env=dotargs, lower = lower[1:N] , upper = upper[1:N] , control = controlPSO)) # add ,silent=TRUE here? if(inherits(minw,"try-error")) { minw=NULL } @@ -910,7 +919,7 @@ weights <- as.vector( minw$par) weights <- normalize_weights(weights) names(weights) <- colnames(R) - obj_vals <- constrained_objective(w=weights, R=R, portfolio=portfolio, trace=TRUE, moments=dotargs)$objective_measures + obj_vals <- constrained_objective(w=weights, R=R, portfolio=portfolio, trace=TRUE, env=dotargs)$objective_measures out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, @@ -944,7 +953,7 @@ lower <- constraints$min minw = try(GenSA( par = rep(1/N, N), lower = lower[1:N] , upper = upper[1:N], control = controlGenSA, - fn = constrained_objective , R=R, portfolio=portfolio, moments=dotargs)) # add ,silent=TRUE here? + fn = constrained_objective , R=R, portfolio=portfolio, env=dotargs)) # add ,silent=TRUE here? if(inherits(minw,"try-error")) { minw=NULL } if(is.null(minw)){ @@ -955,7 +964,7 @@ weights <- as.vector(minw$par) weights <- normalize_weights(weights) names(weights) <- colnames(R) - obj_vals <- constrained_objective(w=weights, R=R, portfolio=portfolio, trace=TRUE, moments=dotargs)$objective_measures + obj_vals <- constrained_objective(w=weights, R=R, portfolio=portfolio, trace=TRUE, env=dotargs)$objective_measures out = list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, From noreply at r-forge.r-project.org Mon Dec 16 07:39:40 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 07:39:40 +0100 (CET) Subject: [Returnanalytics-commits] r3285 - pkg/PortfolioAnalytics/inst/tests Message-ID: <20131216063940.6B1B6180153@r-forge.r-project.org> 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) +}) + From noreply at r-forge.r-project.org Mon Dec 16 16:50:19 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 16:50:19 +0100 (CET) Subject: [Returnanalytics-commits] r3286 - in pkg/PortfolioAnalytics: . R man Message-ID: <20131216155019.439B218676F@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 16:50:18 +0100 (Mon, 16 Dec 2013) New Revision: 3286 Added: pkg/PortfolioAnalytics/man/leverage_exposure_constraint.Rd Modified: pkg/PortfolioAnalytics/DESCRIPTION pkg/PortfolioAnalytics/NAMESPACE pkg/PortfolioAnalytics/R/constrained_objective.R pkg/PortfolioAnalytics/R/optimize.portfolio.R pkg/PortfolioAnalytics/man/applyFUN.Rd pkg/PortfolioAnalytics/man/constrained_objective.Rd pkg/PortfolioAnalytics/man/meanetl.efficient.frontier.Rd pkg/PortfolioAnalytics/man/meanvar.efficient.frontier.Rd pkg/PortfolioAnalytics/man/optimize.portfolio.Rd pkg/PortfolioAnalytics/man/random_portfolios.Rd pkg/PortfolioAnalytics/man/rp_grid.Rd pkg/PortfolioAnalytics/man/rp_sample.Rd pkg/PortfolioAnalytics/man/rp_simplex.Rd pkg/PortfolioAnalytics/man/scatterFUN.Rd Log: Updating documentation Modified: pkg/PortfolioAnalytics/DESCRIPTION =================================================================== --- pkg/PortfolioAnalytics/DESCRIPTION 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/DESCRIPTION 2013-12-16 15:50:18 UTC (rev 3286) @@ -62,4 +62,3 @@ 'equal.weight.R' 'inverse.volatility.weight.R' 'utils.R' - Modified: pkg/PortfolioAnalytics/NAMESPACE =================================================================== --- pkg/PortfolioAnalytics/NAMESPACE 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/NAMESPACE 2013-12-16 15:50:18 UTC (rev 3286) @@ -34,6 +34,7 @@ export(is.constraint) export(is.objective) export(is.portfolio) +export(leverage_exposure_constraint) export(meanetl.efficient.frontier) export(meanvar.efficient.frontier) export(minmax_objective) Modified: pkg/PortfolioAnalytics/R/constrained_objective.R =================================================================== --- pkg/PortfolioAnalytics/R/constrained_objective.R 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/R/constrained_objective.R 2013-12-16 15:50:18 UTC (rev 3286) @@ -340,6 +340,7 @@ #' @param normalize TRUE/FALSE whether to normalize results to min/max sum (TRUE), or let the optimizer penalize portfolios that do not conform (FALSE) #' @param storage TRUE/FALSE default TRUE for DEoptim with trace, otherwise FALSE. not typically user-called. #' @param constraints a v1_constraint object for backwards compatibility with \code{constrained_objective_v1}. +#' @param env environment of moments calculated in \code{optimize.portfolio} #' @seealso \code{\link{constraint}}, \code{\link{objective}}, \code{\link[DEoptim]{DEoptim.control}} #' @author Kris Boudt, Peter Carl, Brian G. Peterson, Ross Bennett #' @aliases constrained_objective constrained_objective_v1 Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R =================================================================== --- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-16 15:50:18 UTC (rev 3286) @@ -989,7 +989,7 @@ return(out) } -#' constrained optimization of portfolios +#' Constrained optimization of portfolios #' #' This function aims to provide a wrapper for constrained optimization of #' portfolios that specify constraints and objectives. @@ -1022,7 +1022,11 @@ #' \item{Minimize portfolio variance subject to leverage, box, group, and/or factor exposure constraints and a desired portfolio return.} #' \item{Maximize quadratic utility subject to leverage, box, group, target mean return, turnover, and/or factor exposure constraints and risk aversion parameter. #' (The risk aversion parameter is passed into \code{optimize.portfolio} as an added argument to the \code{portfolio} object).} -#' \item{Mean CVaR optimization subject to leverage, box, group, position limit, target mean return, and/or factor exposure constraints and target portfolio return.} +#' \item{Maximize portfolio mean return per unit standard deviation (i.e. the Sharpe Ratio) can be done by specifying \code{maxSR=TRUE} in \code{optimize.portfolio}. +#' If both mean and StdDev are specified as objective names, the default action is to maximize quadratic utility, therefore \code{maxSR=TRUE} must be specified to maximize Sharpe Ratio.} +#' \item{Minimize portfolio ES/ETL/CVaR optimization subject to leverage, box, group, position limit, target mean return, and/or factor exposure constraints and target portfolio return.} +#' \item{Maximize portfolio mean return per unit ES/ETL/CVaR (i.e. the STARR Ratio) can be done by specifying \code{maxSTARR=TRUE} in \code{optimize.portfolio}. +#' If both mean and ES/ETL/CVaR are specified as objective names, the default action is to maximize mean return per unit ES/ETL/CVaR.} #' } #' These problems also support a weight_concentration objective where concentration #' of weights as measured by HHI is added as a penalty term to the quadratic objective. Modified: pkg/PortfolioAnalytics/man/applyFUN.Rd =================================================================== --- pkg/PortfolioAnalytics/man/applyFUN.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/applyFUN.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -2,7 +2,7 @@ \alias{applyFUN} \title{Apply a risk or return function to a set of weights} \usage{ - applyFUN(R, weights, FUN = "mean", ...) + applyFUN(R, weights, FUN = "mean", arguments) } \arguments{ \item{R}{xts object of asset returns} @@ -12,7 +12,7 @@ \item{FUN}{name of a function} - \item{...}{any passthrough arguments to FUN} + \item{arguments}{named list of arguments to FUN} } \description{ This function is used to calculate risk or return metrics Modified: pkg/PortfolioAnalytics/man/constrained_objective.Rd =================================================================== --- pkg/PortfolioAnalytics/man/constrained_objective.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/constrained_objective.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -8,10 +8,12 @@ trace = FALSE, normalize = TRUE, storage = FALSE) constrained_objective_v2(w, R, portfolio, ..., - trace = FALSE, normalize = TRUE, storage = FALSE) + trace = FALSE, normalize = TRUE, storage = FALSE, + env = NULL) constrained_objective(w, R, portfolio, ..., - trace = FALSE, normalize = TRUE, storage = FALSE) + trace = FALSE, normalize = TRUE, storage = FALSE, + env = NULL) } \arguments{ \item{R}{an xts, vector, matrix, data frame, timeSeries @@ -39,6 +41,9 @@ \item{constraints}{a v1_constraint object for backwards compatibility with \code{constrained_objective_v1}.} + + \item{env}{environment of moments calculated in + \code{optimize.portfolio}} } \description{ Function to calculate a numeric return value for a Added: pkg/PortfolioAnalytics/man/leverage_exposure_constraint.Rd =================================================================== --- pkg/PortfolioAnalytics/man/leverage_exposure_constraint.Rd (rev 0) +++ pkg/PortfolioAnalytics/man/leverage_exposure_constraint.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -0,0 +1,50 @@ +\name{leverage_exposure_constraint} +\alias{leverage_exposure_constraint} +\title{constructor for leverage_exposure_constraint} +\usage{ + leverage_exposure_constraint(type = "leverage_exposure", + leverage = NULL, enabled = TRUE, message = FALSE, ...) +} +\arguments{ + \item{type}{character type of the constraint} + + \item{leverage}{maximum leverage value} + + \item{enabled}{TRUE/FALSE} + + \item{message}{TRUE/FALSE. The default is message=FALSE. + Display messages if TRUE.} + + \item{\dots}{any other passthru parameters to specify + diversification constraint an object of class + 'diversification_constraint'} +} +\description{ + The leverage_exposure constraint specifies a maximum + leverage. This should be used for constructing, for + example, 130/30 portfolios or dollar neutral portfolios + with 2:1 leverage. For the ROI solvers, this is + implemented as a MILP problem and is not supported for + problems formulated as a quadratic programming problem. + This ma changed in the future if a MIQP solver is added. +} +\details{ + This function is called by add.constraint when + type="leverage_exposure" is specified, see + \code{\link{add.constraint}}. +} +\examples{ +data(edhec) +ret <- edhec[, 1:4] + +pspec <- portfolio.spec(assets=colnames(ret)) + +pspec <- add.constraint(portfolio=pspec, type="leverage_exposure", leverage=1.6) +} +\author{ + Ross Bennett +} +\seealso{ + \code{\link{add.constraint}} +} + Modified: pkg/PortfolioAnalytics/man/meanetl.efficient.frontier.Rd =================================================================== --- pkg/PortfolioAnalytics/man/meanetl.efficient.frontier.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/meanetl.efficient.frontier.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -3,7 +3,7 @@ \title{Generate the efficient frontier for a mean-etl portfolio} \usage{ meanetl.efficient.frontier(portfolio, R, - n.portfolios = 25) + n.portfolios = 25, ...) } \arguments{ \item{portfolio}{a portfolio object with constraints and @@ -13,6 +13,9 @@ \item{n.portfolios}{number of portfolios to generate the efficient frontier} + + \item{\dots}{passthru parameters to + \code{\link{optimize.portfolio}}} } \value{ a matrix of objective measure values and weights along Modified: pkg/PortfolioAnalytics/man/meanvar.efficient.frontier.Rd =================================================================== --- pkg/PortfolioAnalytics/man/meanvar.efficient.frontier.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/meanvar.efficient.frontier.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -3,7 +3,7 @@ \title{Generate the efficient frontier for a mean-variance portfolio} \usage{ meanvar.efficient.frontier(portfolio, R, - n.portfolios = 25, risk_aversion = NULL) + n.portfolios = 25, risk_aversion = NULL, ...) } \arguments{ \item{portfolio}{a portfolio object with constraints and @@ -19,6 +19,9 @@ ignored if \code{risk_aversion} is specified and the number of points along the efficient frontier is equal to the length of \code{risk_aversion}.} + + \item{\dots}{passthru parameters to + \code{\link{optimize.portfolio}}} } \value{ a matrix of objective measure values and weights along Modified: pkg/PortfolioAnalytics/man/optimize.portfolio.Rd =================================================================== --- pkg/PortfolioAnalytics/man/optimize.portfolio.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/optimize.portfolio.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -2,7 +2,7 @@ \alias{optimize.portfolio} \alias{optimize.portfolio_v1} \alias{optimize.portfolio_v2} -\title{constrained optimization of portfolios} +\title{Constrained optimization of portfolios} \usage{ optimize.portfolio_v1(R, constraints, optimize_method = c("DEoptim", "random", "ROI", "ROI_old", "pso", "GenSA"), @@ -166,14 +166,26 @@ turnover, and/or factor exposure constraints and risk aversion parameter. (The risk aversion parameter is passed into \code{optimize.portfolio} as an added - argument to the \code{portfolio} object).} \item{Mean - CVaR optimization subject to leverage, box, group, - position limit, target mean return, and/or factor - exposure constraints and target portfolio return.} } - These problems also support a weight_concentration - objective where concentration of weights as measured by - HHI is added as a penalty term to the quadratic - objective. + argument to the \code{portfolio} object).} \item{Maximize + portfolio mean return per unit standard deviation (i.e. + the Sharpe Ratio) can be done by specifying + \code{maxSR=TRUE} in \code{optimize.portfolio}. If both + mean and StdDev are specified as objective names, the + default action is to maximize quadratic utility, + therefore \code{maxSR=TRUE} must be specified to maximize + Sharpe Ratio.} \item{Minimize portfolio ES/ETL/CVaR + optimization subject to leverage, box, group, position + limit, target mean return, and/or factor exposure + constraints and target portfolio return.} \item{Maximize + portfolio mean return per unit ES/ETL/CVaR (i.e. the + STARR Ratio) can be done by specifying + \code{maxSTARR=TRUE} in \code{optimize.portfolio}. If + both mean and ES/ETL/CVaR are specified as objective + names, the default action is to maximize mean return per + unit ES/ETL/CVaR.} } These problems also support a + weight_concentration objective where concentration of + weights as measured by HHI is added as a penalty term to + the quadratic objective. Because these convex optimization problem are standardized, there is no need for a penalty term. The Modified: pkg/PortfolioAnalytics/man/random_portfolios.Rd =================================================================== --- pkg/PortfolioAnalytics/man/random_portfolios.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/random_portfolios.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -7,9 +7,9 @@ rp_method = "sample", eliminate = TRUE, ...) } \arguments{ - \item{portfolio}{an object of type "portfolio" specifying - the constraints for the optimization, see - \code{\link{constraint}}} + \item{portfolio}{an object of class 'portfolio' + specifying the constraints for the optimization, see + \code{\link{portfolio.spec}}} \item{permutations}{integer: number of unique constrained random portfolios to generate} @@ -26,9 +26,8 @@ matrix of random portfolio weights } \description{ - repeatedly calls \code{\link{randomize_portfolio}} to - generate an arbitrary number of constrained random - portfolios. + Generate random portfolios using the 'sample', 'simplex', + or 'grid' method. See details. } \details{ Random portfolios can be generate using one of three @@ -73,8 +72,7 @@ be 1/3 or less depending on the other constraints. } \author{ - Peter Carl, Brian G. Peterson, Ross Bennett (based on an - idea by Pat Burns) + Peter Carl, Brian G. Peterson, Ross Bennett } \seealso{ \code{\link{portfolio.spec}}, \code{\link{objective}}, Modified: pkg/PortfolioAnalytics/man/rp_grid.Rd =================================================================== --- pkg/PortfolioAnalytics/man/rp_grid.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/rp_grid.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -2,8 +2,7 @@ \alias{rp_grid} \title{Generate random portfolios based on grid search method} \usage{ - rp_grid(portfolio, permutations = 2000, normalize = TRUE, - ...) + rp_grid(portfolio, permutations = 2000, normalize = TRUE) } \arguments{ \item{portfolio}{an object of class 'portfolio' @@ -15,8 +14,6 @@ \item{normalize}{TRUE/FALSE to normalize the weghts to satisfy min_sum or max_sum} - - \item{\dots}{any passthru parameters. Currently ignored} } \value{ matrix of random portfolio weights Modified: pkg/PortfolioAnalytics/man/rp_sample.Rd =================================================================== --- pkg/PortfolioAnalytics/man/rp_sample.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/rp_sample.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -2,7 +2,8 @@ \alias{rp_sample} \title{Generate random portfolios using the sample method} \usage{ - rp_sample(portfolio, permutations, ...) + rp_sample(portfolio, permutations, + max_permutations = 200) } \arguments{ \item{portfolio}{an object of type "portfolio" specifying @@ -12,7 +13,8 @@ \item{permutations}{integer: number of unique constrained random portfolios to generate} - \item{\dots}{any other passthru parameters} + \item{max_permutations}{integer: maximum number of + iterations to try for a valid portfolio, default 200} } \value{ a matrix of random portfolio weights Modified: pkg/PortfolioAnalytics/man/rp_simplex.Rd =================================================================== --- pkg/PortfolioAnalytics/man/rp_simplex.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/rp_simplex.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -2,7 +2,7 @@ \alias{rp_simplex} \title{Generate random portfolios using the simplex method} \usage{ - rp_simplex(portfolio, permutations, fev = 0:5, ...) + rp_simplex(portfolio, permutations, fev = 0:5) } \arguments{ \item{portfolio}{an object of class 'portfolio' @@ -13,8 +13,6 @@ random portfolios to generate} \item{fev}{scalar or vector for FEV biasing} - - \item{\dots}{any other passthru parameters} } \value{ a matrix of random portfolio weights Modified: pkg/PortfolioAnalytics/man/scatterFUN.Rd =================================================================== --- pkg/PortfolioAnalytics/man/scatterFUN.Rd 2013-12-16 06:39:40 UTC (rev 3285) +++ pkg/PortfolioAnalytics/man/scatterFUN.Rd 2013-12-16 15:50:18 UTC (rev 3286) @@ -2,14 +2,14 @@ \alias{scatterFUN} \title{Apply a risk or return function to asset returns} \usage{ - scatterFUN(R, FUN, ...) + scatterFUN(R, FUN, arguments = NULL) } \arguments{ \item{R}{xts object of asset returns} \item{FUN}{name of function} - \item{...}{any passthrough arguments to FUN} + \item{arguments}{named list of arguments to FUN} } \description{ This function is used to calculate risk or return metrics From noreply at r-forge.r-project.org Mon Dec 16 16:52:09 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Dec 2013 16:52:09 +0100 (CET) Subject: [Returnanalytics-commits] r3287 - pkg/PortfolioAnalytics/R Message-ID: <20131216155209.7D879186848@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-16 16:52:09 +0100 (Mon, 16 Dec 2013) New Revision: 3287 Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R Log: Modifying optimize.portfolio_v1 to use '::' instead of ':::' for R CMD check Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R =================================================================== --- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-16 15:50:18 UTC (rev 3286) +++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-16 15:52:09 UTC (rev 3287) @@ -227,7 +227,7 @@ # ROI constraint object, but with an additional solver arg. # then we can do something like this print("ROI_old is going to be depricated.") - roi.result <- ROI:::ROI_solve(x=constraints$constrainted_objective, constraints$solver) + roi.result <- ROI::ROI_solve(x=constraints$constrainted_objective, constraints$solver) weights <- roi.result$solution names(weights) <- colnames(R) out$weights <- weights @@ -265,8 +265,8 @@ } } plugin <- ifelse(any(names(moments)=="var"), "quadprog", "glpk") - if(plugin == "quadprog") ROI_objective <- ROI:::Q_objective(Q=2*lambda*moments$var, L=-moments$mean) - if(plugin == "glpk") ROI_objective <- ROI:::L_objective(L=-moments$mean) + if(plugin == "quadprog") ROI_objective <- ROI::Q_objective(Q=2*lambda*moments$var, L=-moments$mean) + if(plugin == "glpk") ROI_objective <- ROI::L_objective(L=-moments$mean) Amat <- rbind(rep(1, N), rep(1, N)) dir.vec <- c(">=","<=") rhs.vec <- c(constraints$min_sum, constraints$max_sum) @@ -298,7 +298,7 @@ } if(any(names(moments)=="CVaR")) { Rmin <- ifelse(is.na(target), 0, target) - ROI_objective <- ROI:::L_objective(c(rep(0,N), rep(1/(alpha*T),T), 1)) + ROI_objective <- ROI::L_objective(c(rep(0,N), rep(1/(alpha*T),T), 1)) Amat <- cbind(rbind(1, 1, moments$mean, coredata(R)), rbind(0, 0, 0, cbind(diag(T), 1))) dir.vec <- c(">=","<=",">=",rep(">=",T)) rhs.vec <- c(constraints$min_sum, constraints$max_sum, Rmin ,rep(0, T)) @@ -309,10 +309,10 @@ rhs.vec <- c(rhs.vec, constraints$cLO, -constraints$cUP) } } - opt.prob <- ROI:::OP(objective=ROI_objective, - constraints=ROI:::L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec), + opt.prob <- ROI::OP(objective=ROI_objective, + constraints=ROI::L_constraint(L=Amat, dir=dir.vec, rhs=rhs.vec), bounds=bnds) - roi.result <- ROI:::ROI_solve(x=opt.prob, solver=plugin) + roi.result <- ROI::ROI_solve(x=opt.prob, solver=plugin) weights <- roi.result$solution[1:N] names(weights) <- colnames(R) out$weights <- weights From noreply at r-forge.r-project.org Tue Dec 17 22:03:02 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 17 Dec 2013 22:03:02 +0100 (CET) Subject: [Returnanalytics-commits] r3288 - pkg/PortfolioAnalytics Message-ID: <20131217210302.5795318670E@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-17 22:03:01 +0100 (Tue, 17 Dec 2013) New Revision: 3288 Modified: pkg/PortfolioAnalytics/DESCRIPTION Log: Modifying description file to match ROI version on CRAN Modified: pkg/PortfolioAnalytics/DESCRIPTION =================================================================== --- pkg/PortfolioAnalytics/DESCRIPTION 2013-12-16 15:52:09 UTC (rev 3287) +++ pkg/PortfolioAnalytics/DESCRIPTION 2013-12-17 21:03:01 UTC (rev 3288) @@ -21,8 +21,8 @@ fGarch, Rglpk, quadprog, - ROI, - ROI.plugin.glpk, + ROI (>= 0.1.0), + ROI.plugin.glpk (>= 0.0.2), ROI.plugin.quadprog (>= 0.0.2), pso, GenSA, From noreply at r-forge.r-project.org Tue Dec 17 22:06:09 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 17 Dec 2013 22:06:09 +0100 (CET) Subject: [Returnanalytics-commits] r3289 - in pkg/PortfolioAnalytics: R sandbox/benchmarking Message-ID: <20131217210609.A6EBD1867EC@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-17 22:06:07 +0100 (Tue, 17 Dec 2013) New Revision: 3289 Added: pkg/PortfolioAnalytics/sandbox/benchmarking/benchmark_output.txt Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R pkg/PortfolioAnalytics/sandbox/benchmarking/benchmark_opt.R Log: Simplifying how initialpop is set for DEoptim with random portfolios. Adding benchmarking script and output file with results. Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R =================================================================== --- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-17 21:03:01 UTC (rev 3288) +++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-17 21:06:07 UTC (rev 3289) @@ -609,22 +609,37 @@ consider relaxing. e.g. 'full_investment' constraint should be min_sum=0.99 and max_sum=1.01") } - if(hasArg(rpseed)){ - seed <- match.call(expand.dots=TRUE)$rpseed + #if(hasArg(rpseed)){ + # seed <- match.call(expand.dots=TRUE)$rpseed + # DEcformals$initialpop <- seed + # rpseed <- FALSE + #} else { + # rpseed <- TRUE + #} + #if(hasArg(rpseed) & isTRUE(rpseed)) { + # # initial seed population is generated with random_portfolios function + # # if(hasArg(eps)) eps=match.call(expand.dots=TRUE)$eps else eps = 0.01 + # if(hasArg(rp_method)) rp_method=match.call(expand.dots=TRUE)$rp_method else rp_method="sample" + # if(hasArg(eliminate)) eliminate=match.call(expand.dots=TRUE)$eliminate else eliminate=TRUE + # if(hasArg(fev)) fev=match.call(expand.dots=TRUE)$fev else fev=0:5 + # rp <- random_portfolios(portfolio=portfolio, permutations=NP, rp_method=rp_method, eliminate=eliminate, fev=fev) + # DEcformals$initialpop <- rp + #} + + # Use rp as the initial population or generate from random portfolios + if(!is.null(rp)){ + rp_len <- min(nrow(rp), NP) + seed <- rp[1:rp_len,] DEcformals$initialpop <- seed - rpseed <- FALSE - } else { - rpseed <- TRUE - } - if(hasArg(rpseed) & isTRUE(rpseed)) { - # initial seed population is generated with random_portfolios function - # if(hasArg(eps)) eps=match.call(expand.dots=TRUE)$eps else eps = 0.01 + } else{ + # Initial seed population is generated with random_portfolios function if rp is not passed in if(hasArg(rp_method)) rp_method=match.call(expand.dots=TRUE)$rp_method else rp_method="sample" if(hasArg(eliminate)) eliminate=match.call(expand.dots=TRUE)$eliminate else eliminate=TRUE if(hasArg(fev)) fev=match.call(expand.dots=TRUE)$fev else fev=0:5 rp <- random_portfolios(portfolio=portfolio, permutations=NP, rp_method=rp_method, eliminate=eliminate, fev=fev) DEcformals$initialpop <- rp } + controlDE <- do.call(DEoptim.control, DEcformals) # We are passing fn_map to the optional fnMap function to do the Modified: pkg/PortfolioAnalytics/sandbox/benchmarking/benchmark_opt.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/benchmarking/benchmark_opt.R 2013-12-17 21:03:01 UTC (rev 3288) +++ pkg/PortfolioAnalytics/sandbox/benchmarking/benchmark_opt.R 2013-12-17 21:06:07 UTC (rev 3289) @@ -1,7 +1,8 @@ +# The purpose of this script is to set a baseline for performance of optimize.portfolio library(PortfolioAnalytics) -library(rbenchmark) +library(microbenchmark) data(edhec) returns <- edhec[,1:10] @@ -11,47 +12,54 @@ init.portf <- portfolio.spec(assets=funds) init.portf <- add.constraint(portfolio=init.portf, type="weight_sum", min_sum=0.99, max_sum=1.01) -init.portf <- add.constraint(portfolio=init.portf, type="box", min=0, max=0.45) -# init.portf <- add.objective(portfolio=init.portf, type="return", name="mean") +init.portf <- add.constraint(portfolio=init.portf, type="box", min=0, max=1) init.portf <- add.objective(portfolio=init.portf, type="risk", name="ES") -n_portfolios <- 1000 +# Generate N random portfolios. Random portfolios should be generated outside +# of optimize.portfolio so that the time to generate random portfolios is not +# included in the timing +n_portfolios <- 5000 rp <- random_portfolios(portfolio=init.portf, permutations=n_portfolios, rp_method="sample", eliminate=FALSE) -opt1 <- optimize.portfolio(R=returns, portfolio=init.portf, optimize_method="random", rp=rp, reuse_moments=FALSE, trace=TRUE) -opt2 <- optimize.portfolio(R=returns, portfolio=init.portf, optimize_method="random", rp=rp, reuse_moments=TRUE, trace=TRUE) +opt_rp <- function(){ + optimize.portfolio(R=returns, + portfolio=init.portf, + optimize_method="random", + rp=rp, + trace=TRUE) +} -all.equal(opt1, opt2) -# Component 6, 10, and 11 do not match -# Component 6 is the call -# Component 10 the elapsed time -# Component 11 the end_t +opt_de <- function(){ + optimize.portfolio(R=returns, + portfolio=init.portf, + optimize_method="DEoptim", + search_size=n_portfolios, + rp=rp, + traceDE=0, + trace=TRUE) +} -# Make sure the results of opt1 and opt2 are equal -all.equal(extractStats(opt1), extractStats(opt2)) +opt_benchmark <- microbenchmark(opt_rp(), opt_de(), times=10) +comment_string <- "ES optimization benchmark with random portfolios and DEoptim" -# benchmark different ways of passing the moments to constrained_objective -benchmark( - reuse=optimize.portfolio(R=returns, portfolio=init.portf, optimize_method="random", rp=rp, reuse_moments=TRUE), - no_reuse=optimize.portfolio(R=returns, portfolio=init.portf, optimize_method="random", rp=rp, reuse_moments=FALSE), - replications=1 -)[,1:4] +zz <- file(description="sandbox/benchmarking/benchmark_output.txt", open="at") +sink(zz, append=TRUE) +cat("******\n") +Sys.time() +cat(comment_string, "\n") +opt_benchmark +cat("******\n") +sink() +close(zz) # Rprof runs -# new uses modify.args to evaluate arguments -Rprof(filename="rp_profile_reuse.txt") -optimize.portfolio(R=returns, portfolio=init.portf, optimize_method="random", rp=rp, reuse_moments=TRUE) -Rprof(NULL) +# Rprof(filename="rp_profile_reuse.txt") +# optimize.portfolio(R=returns, portfolio=init.portf, optimize_method="random", rp=rp, trace=TRUE) +# Rprof(NULL) -Rprof(filename="rp_profile_no_reuse.txt") -optimize.portfolio(R=returns, portfolio=init.portf, optimize_method="random", rp=rp, reuse_moments=FALSE) -Rprof(NULL) +# out_reuse <- summaryRprof("rp_profile_reuse.txt") +# out_no_reuse <- summaryRprof("rp_profile_no_reuse.txt") -out_reuse <- summaryRprof("rp_profile_reuse.txt") -out_no_reuse <- summaryRprof("rp_profile_no_reuse.txt") - -lapply(out_reuse, head) -lapply(out_no_reuse, head) \ No newline at end of file Added: pkg/PortfolioAnalytics/sandbox/benchmarking/benchmark_output.txt =================================================================== --- pkg/PortfolioAnalytics/sandbox/benchmarking/benchmark_output.txt (rev 0) +++ pkg/PortfolioAnalytics/sandbox/benchmarking/benchmark_output.txt 2013-12-17 21:06:07 UTC (rev 3289) @@ -0,0 +1,8 @@ +****** +[1] "2013-12-17 10:45:18 PST" +ES optimization benchmark with random portfolios and DEoptim +Unit: seconds + expr min lq median uq max neval + opt_rp() 8.539322 8.581483 8.685236 9.019323 9.510726 10 + opt_de() 42.417468 98.721399 113.836677 128.932124 142.691423 10 +****** From noreply at r-forge.r-project.org Wed Dec 18 06:07:59 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 18 Dec 2013 06:07:59 +0100 (CET) Subject: [Returnanalytics-commits] r3290 - in pkg/PortfolioAnalytics: demo sandbox/benchmarking Message-ID: <20131218050759.EA941186955@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-18 06:07:59 +0100 (Wed, 18 Dec 2013) New Revision: 3290 Added: pkg/PortfolioAnalytics/sandbox/benchmarking/performance_considerations.txt Modified: pkg/PortfolioAnalytics/demo/constrained_optim.R Log: Adding file to describe potential bottlenecks for performance considerations Modified: pkg/PortfolioAnalytics/demo/constrained_optim.R =================================================================== --- pkg/PortfolioAnalytics/demo/constrained_optim.R 2013-12-17 21:06:07 UTC (rev 3289) +++ pkg/PortfolioAnalytics/demo/constrained_optim.R 2013-12-18 05:07:59 UTC (rev 3290) @@ -1,41 +1,62 @@ -require("PerformanceAnalytics") -require("PortfolioAnalytics") -require("DEoptim") +library(PortfolioAnalytics) +require(DEoptim) + # Load the data data(edhec) #constraints -constraints <- constraint(assets = colnames(edhec[, 1:10]), min = 0.01, max = 0.4, min_sum=1, max_sum=1, weight_seq = generatesequence()) -# note that if you wanted to do a random portfolio optimization, mun_sum of .99 and max_sum of 1.01 might be more appropriate -constraints <- add.objective(constraints=constraints, type="return", name="mean", arguments=list(), enabled=TRUE) -constraints <- add.objective(constraints=constraints, type="risk_budget", name="ES", arguments=list(), enabled=TRUE, p=.95, min_prisk=.05, max_prisk=.15) +constraints <- constraint(assets = colnames(edhec[, 1:10]), min = 0.01, + max = 0.4, min_sum=0.99, max_sum=1.01, + weight_seq = generatesequence()) -#now set some additional bits -# I should have set the multiplier for returns to negative -constraints$objectives[[1]]$multiplier=-1 -# and let's set a portfolio risk target in the risk budget objective too -constraints$objectives[[2]]$target=.05 -# and clean the returns -constraints$objectives[[2]]$clean="boudt" +constraints <- add.objective(constraints=constraints, + type="return", + name="mean") -print("We'll use a search_size parameter of 1000 for this demo, but realistic portfolios will likely require search_size parameters much larger, the default is 20000 which is almost always large enough for any realistic portfolio and constraints, but will take substantially longer to run.") +constraints <- add.objective(constraints=constraints, + type="risk_budget", + name="ES", arguments=list(clean="boudt", p=0.95), + min_prisk=.05, + max_prisk=.15, + target=0.05) + +print("We'll use a search_size parameter of 1000 for this demo, but realistic + portfolios will likely require search_size parameters much larger, the + default is 20000 which is almost always large enough for any realistic + portfolio and constraints, but will take substantially longer to run.") + # look for a solution using both DEoptim and random portfolios -opt_out <- optimize.portfolio(R=edhec[,1:10], constraints=constraints, optimize_method="DEoptim", search_size=1000, trace=TRUE) +opt_out <- optimize.portfolio(R=edhec[,1:10], + constraints=constraints, + optimize_method="DEoptim", + search_size=1000, + trace=TRUE) -#we need a little more wiggle in min/max sum for random portfolios or it takes too long to converge -constraints$min_sum <- 0.99 -constraints$max_sum <- 1.01 -opt_out_random <- optimize.portfolio(R=edhec[,1:10], constraints=constraints, optimize_method="random", search_size=1000, trace=TRUE) +opt_out_random <- optimize.portfolio(R=edhec[,1:10], + constraints=constraints, + optimize_method="random", + search_size=1000, + trace=TRUE) -# now lets try a portfolio that rebalances quarterly -opt_out_rebalancing <- optimize.portfolio.rebalancing_v1(R=edhec[,1:10], constraints=constraints, optimize_method="DEoptim", search_size=1000, trace=FALSE,rebalance_on='quarters') -rebalancing_weights <- matrix(nrow=length(opt_out_rebalancing),ncol=length(opt_out_rebalancing[[1]]]$weights)) -rownames(rebalancing_weights) <- names(opt_out_rebalancing) -colnames(rebalancing_weights) <- names(opt_out_rebalancing[[1]]$weights) -for(period in 1:length(opt_out_rebalancing)) rebalancing_weights[period,] <- opt_out_rebalancing[[period]]$weights +# Optimize a portfolio that rebalances quarterly +opt_out_rebalancing <- optimize.portfolio.rebalancing(R=edhec[,1:10], + constraints=constraints, + optimize_method="random", + search_size=1000, + trace=FALSE, + rebalance_on='quarters') + +rebalancing_weights <- extractWeights(opt_out_rebalancing) rebalancing_returns <- Return.rebalancing(R=edhec,weights=rebalancing_weights) charts.PerformanceSummary(rebalancing_returns) -# and now lets rebalance quarterly with 48 mo trailing -opt_out_trailing<-optimize.portfolio.rebalancing(R=edhec[,1:10], constraints=constraints, optimize_method="DEoptim", search_size=1000, trace=FALSE,rebalance_on='quarters',trailing_periods=48,training_period=48) +# Optimize a portfolio that rebalances quarterly with 48 mo trailing +opt_out_trailing <- optimize.portfolio.rebalancing(R=edhec[,1:10], + constraints=constraints, + optimize_method="random", + search_size=1000, + trace=FALSE, + rebalance_on='quarters', + trailing_periods=48, + training_period=48) Added: pkg/PortfolioAnalytics/sandbox/benchmarking/performance_considerations.txt =================================================================== --- pkg/PortfolioAnalytics/sandbox/benchmarking/performance_considerations.txt (rev 0) +++ pkg/PortfolioAnalytics/sandbox/benchmarking/performance_considerations.txt 2013-12-18 05:07:59 UTC (rev 3290) @@ -0,0 +1,13 @@ +Version: 0.8.3 +12/17/2013 + +The functions described in the paragraphs below should be monitored and considered for any degradation in performance. + +optimize.portfolio() is the main function for portfolio optimization. The default function to calculate the portfolio moments is set.portfolio.moments(). The set.portfolio.moments() function should calculate the moments once in optimize.portfolio() and then pass the moments to constrained_objective(). constrained_objective() is the objective function for DEoptim, random portfolios, pso, and GenSA. There is a check in constrained_objective() that will calculate the moments if they are not set correctly in optimize.portfolio(). This can be very expensive in terms of performance because constrained_objective() is potentially called thousands or tens of thousands of times. + +random_portfolios() calculates a number of portfolios that satisfy weight_sum, box, group, and position limit constraints. There are 3 methods to calculate a random set of weights: +1) sample, 2) uniform, and 3) grid. The uniform and grid methods are relatively fast and the sample method has the potential to be slower. + +Generating random portfolios with the sample method is a ?brute force search? method to generate a random set of weights and can potentially be slow depending on the number of assets and combination of constraints. The sample method to generate a random set of weights is relatively fast for sum of weights, box, and position limit constraints. Including group constraints or making the constraints restrictive will increase runtime of the function. rp_sample() only handles weight_sum and box constraints. Group and position limit constraints are handled in rp_transform(), which is called in randomize_portfolio. rp_transform() uses logic from random portfolios so any improvement should be implemented in both functions. fn_map() is a wrapper for rp_transform and is used in the mapping function for DEoptim so any improvement here could be a performance gain for optimization with DEoptim. + +For optimize_method=?DEoptim?, the initial population is calculated with random_portfolios(). A set of random portfolios can be passed in by the user with the ?rp? argument. If ?rp? is not passed in, then we generate random portfolios in optimize.portfolio() used for the initial population. For a single period optimization with optimize.portfolio(), the random portfolios are only generated once. However, optimize.portfolio.rebalancing() is a wrapper for optimize.portfolio() to manage the time index to pass the returns to optimize.portfolio() for out of sample portfolio optimization with rebalancing . This results in multiple calls to optimize.portfolio(). For optimize_method=?random? and optimize_method=?DEoptim?, the random portfolios should only be generated once. Generating random portfolios at each call to optimize.portfolio() is redundant and negatively impacts performance. \ No newline at end of file From noreply at r-forge.r-project.org Thu Dec 19 20:47:08 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 19 Dec 2013 20:47:08 +0100 (CET) Subject: [Returnanalytics-commits] r3291 - pkg/PortfolioAnalytics/R Message-ID: <20131219194709.081281868B3@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-19 20:47:08 +0100 (Thu, 19 Dec 2013) New Revision: 3291 Modified: pkg/PortfolioAnalytics/R/optFUN.R pkg/PortfolioAnalytics/R/optimize.portfolio.R Log: Minor edit to optFUN to correct bug and correcting how initialpop is set for DEoptim Modified: pkg/PortfolioAnalytics/R/optFUN.R =================================================================== --- pkg/PortfolioAnalytics/R/optFUN.R 2013-12-18 05:07:59 UTC (rev 3290) +++ pkg/PortfolioAnalytics/R/optFUN.R 2013-12-19 19:47:08 UTC (rev 3291) @@ -85,6 +85,7 @@ # Remove the rows of Amat and elements of rhs.vec where rhs.vec is Inf or -Inf Amat <- Amat[!is.infinite(rhs.vec), ] + dir.vec <- dir.vec[!is.infinite(rhs.vec)] rhs.vec <- rhs.vec[!is.infinite(rhs.vec)] # Set up the quadratic objective Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R =================================================================== --- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-18 05:07:59 UTC (rev 3290) +++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-12-19 19:47:08 UTC (rev 3291) @@ -504,9 +504,9 @@ } # match the args for momentFUN .formals <- formals(momentFUN) - .formals <- modify.args(formals=.formals, arglist=NULL, ..., dots=TRUE) - if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=R, dots=TRUE) - if("portfolio" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, portfolio=portfolio, dots=TRUE) + .formals <- modify.args(formals=.formals, arglist=NULL, ..., dots=FALSE) + if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=R, dots=FALSE) + if("portfolio" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, portfolio=portfolio, dots=FALSE) .formals$... <- NULL # call momentFUN @@ -634,19 +634,21 @@ } else{ # Initial seed population is generated with random_portfolios function if rp is not passed in if(hasArg(rp_method)) rp_method=match.call(expand.dots=TRUE)$rp_method else rp_method="sample" - if(hasArg(eliminate)) eliminate=match.call(expand.dots=TRUE)$eliminate else eliminate=TRUE + # if(hasArg(eliminate)) eliminate=match.call(expand.dots=TRUE)$eliminate else eliminate=TRUE if(hasArg(fev)) fev=match.call(expand.dots=TRUE)$fev else fev=0:5 - rp <- random_portfolios(portfolio=portfolio, permutations=NP, rp_method=rp_method, eliminate=eliminate, fev=fev) + rp <- random_portfolios(portfolio=portfolio, permutations=(NP+1), rp_method=rp_method, eliminate=FALSE, fev=fev) DEcformals$initialpop <- rp } controlDE <- do.call(DEoptim.control, DEcformals) - # We are passing fn_map to the optional fnMap function to do the # transformation so we need to force normalize=FALSE in call to constrained_objective minw = try(DEoptim( constrained_objective, lower=lower[1:N], upper=upper[1:N], control=controlDE, R=R, portfolio=portfolio, env=dotargs, normalize=FALSE, fnMap=function(x) fn_map(x, portfolio=portfolio)$weights), silent=TRUE) - if(inherits(minw, "try-error")) { minw=NULL } + if(inherits(minw, "try-error")) { + message(minw) + minw=NULL + } if(is.null(minw)){ message(paste("Optimizer was unable to find a solution for target")) return (paste("Optimizer was unable to find a solution for target")) From noreply at r-forge.r-project.org Thu Dec 19 20:47:51 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 19 Dec 2013 20:47:51 +0100 (CET) Subject: [Returnanalytics-commits] r3292 - pkg/PortfolioAnalytics/vignettes Message-ID: <20131219194751.73C9C1868B3@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-19 20:47:50 +0100 (Thu, 19 Dec 2013) New Revision: 3292 Modified: pkg/PortfolioAnalytics/vignettes/ROI_vignette.Rnw pkg/PortfolioAnalytics/vignettes/ROI_vignette.pdf pkg/PortfolioAnalytics/vignettes/portfolio_vignette.Rnw pkg/PortfolioAnalytics/vignettes/portfolio_vignette.pdf pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.Rnw pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.pdf Log: Edits to fix vignettes Modified: pkg/PortfolioAnalytics/vignettes/ROI_vignette.Rnw =================================================================== --- pkg/PortfolioAnalytics/vignettes/ROI_vignette.Rnw 2013-12-19 19:47:08 UTC (rev 3291) +++ pkg/PortfolioAnalytics/vignettes/ROI_vignette.Rnw 2013-12-19 19:47:50 UTC (rev 3292) @@ -5,6 +5,8 @@ \usepackage{Rd} \usepackage{amsmath} +\VignetteIndexEntry{Portfolio Optimization with ROI in PortfolioAnalytics} + \begin{document} \title{Using the ROI solvers with PortfolioAnalytics} @@ -34,6 +36,7 @@ # Use the first 4 columns in edhec for a returns object returns <- edhec[, 1:4] +colnames(returns) <- c("CA", "CTAG", "DS", "EM") print(head(returns, 5)) # Get a character vector of the fund names @@ -55,7 +58,7 @@ \subsection{Portfolio Object} The first step is to create the portfolio object. Then add constraints and a return objective. -<<>>= +<>= # Create portfolio object portf_maxret <- portfolio.spec(assets=funds) @@ -77,9 +80,10 @@ \subsection{Optimization} The next step is to run the optimization. Note that \code{optimize\_method="ROI"} is specified in the call to \code{optimize.portfolio} to select the solver used for the optimization. -<<>>= +<>= # Run the optimization -opt_maxret <- optimize.portfolio(R=returns, portfolio=portf_maxret, optimize_method="ROI", trace=TRUE) +opt_maxret <- optimize.portfolio(R=returns, portfolio=portf_maxret, + optimize_method="ROI", trace=TRUE) @ The print method for the \code{opt\_maxret} object shows the call, optimal weights, and the objective measure @@ -109,28 +113,22 @@ @ \subsection{Visualization} -The chart of the optimal weights as well as the box constraints can be created with \code{chart.Weights}. The blue dots are the optimal weights and the gray triangles are the \code{min} and \code{max} of the box constraints. -<>= -chart.Weights(opt_maxret) +The \code{plot} method charts of the optimal weights with the box constraints along with the optimal portfolio in risk-return space. The blue dots are the optimal weights and the gray triangles are the \code{min} and \code{max} of the box constraints. +<<>>= +plot(opt_maxret, chart.assets=TRUE, xlim=c(0.02, 0.18)) @ The optimal portfolio can be plotted in risk-return space along with other feasible portfolios. The return metric is defined in the \code{return.col} argument and the risk metric is defined in the \code{risk.col} argument. The scatter chart includes the optimal portfolio (blue dot) and other feasible portfolios (gray circles) to show the overall feasible space given the constraints. By default, if \code{rp} is not passed in, the feasible portfolios are generated with \code{random\_portfolios} to satisfy the constraints of the portfolio object. Volatility as the risk metric -<>= +<>= chart.RiskReward(opt_maxret,return.col="mean", risk.col="sd", chart.assets=TRUE, xlim=c(0.01, 0.05), main="Maximum Return") @ -Expected tail loss as the risk metric -<>= -chart.RiskReward(opt_maxret, return.col="mean", risk.col="ES", - chart.assets=TRUE, xlim=c(0.02, 0.18), main="Maximum Return") -@ - \subsection{Backtesting} An out of sample backtest is run with \code{optimize.portfolio.rebalancing}. In this example, an initial training period of 36 months is used and the portfolio is rebalanced quarterly. -<<>>= +<>= bt_maxret <- optimize.portfolio.rebalancing(R=returns, portfolio=portf_maxret, optimize_method="ROI", rebalance_on="quarters", @@ -166,7 +164,7 @@ The only constraint specified is the full investment constraint, therefore the optimization problem is solving for the global minimum variance portfolio. \subsubsection{Optimization} -<<>>= +<>= # Run the optimization opt_gmv <- optimize.portfolio(R=returns, portfolio=portf_minvar, optimize_method="ROI", trace=TRUE) @@ -174,7 +172,7 @@ @ \subsubsection{Backtesting} -<<>>= +<>= bt_gmv <- optimize.portfolio.rebalancing(R=returns, portfolio=portf_minvar, optimize_method="ROI", rebalance_on="quarters", @@ -186,7 +184,7 @@ \subsubsection{Portfolio Object} Constraints can be added to the \code{portf\_minvar} portfolio object previously created. -<<>>= +<>= # Add long only constraints portf_minvar <- add.constraint(portfolio=portf_minvar, type="box", min=0, max=1) @@ -202,7 +200,7 @@ @ \subsubsection{Optimization} -<<>>= +<>= # Run the optimization opt_minvar <- optimize.portfolio(R=returns, portfolio=portf_minvar, optimize_method="ROI", trace=TRUE) @@ -210,7 +208,7 @@ @ \subsubsection{Backtesting} -<<>>= +<>= bt_minvar <- optimize.portfolio.rebalancing(R=returns, portfolio=portf_minvar, optimize_method="ROI", rebalance_on="quarters", @@ -256,7 +254,7 @@ \subsection{Optimization} Note how the constraints and objectives are passed to optimize.portfolio. -<<>>= +<>= # Run the optimization opt_qu <- optimize.portfolio(R=returns, portfolio=init_portf, constraints=qu_constr, @@ -266,7 +264,7 @@ @ \subsection{Backtesting} -<<>>= +<>= bt_qu <- optimize.portfolio.rebalancing(R=returns, portfolio=init_portf, constraints=qu_constr, objectives=qu_obj, Modified: pkg/PortfolioAnalytics/vignettes/ROI_vignette.pdf =================================================================== (Binary files differ) Modified: pkg/PortfolioAnalytics/vignettes/portfolio_vignette.Rnw =================================================================== --- pkg/PortfolioAnalytics/vignettes/portfolio_vignette.Rnw 2013-12-19 19:47:08 UTC (rev 3291) +++ pkg/PortfolioAnalytics/vignettes/portfolio_vignette.Rnw 2013-12-19 19:47:50 UTC (rev 3292) @@ -35,10 +35,10 @@ % Or whatever. Note that the encoding and the font should match. If T1 % does not look nice, try deleting the line with the fontenc. +\VignetteIndexEntry{An Introduction to Portfolio Optimization with PortfolioAnalytics} + \begin{document} -\SweaveOpts{concordance=TRUE} - \title{Introduction to PortfolioAnalytics} \author{Ross Bennett} @@ -90,7 +90,7 @@ \subsection{Leverage Constraint} The \code{leverage} constraint specifies the constraint on the sum of the weights. Aliases for the \code{leverage} constraint type include \code{weight\_sum}, \code{weight}, and \code{leverage}. Here we add a constraint that the weights must sum to 1, or the full investment constraint. -<<>>= +<>= # Add the full investment constraint that specifies the weights must sum to 1. pspec <- add.constraint(portfolio=pspec, type="weight_sum", @@ -104,7 +104,7 @@ \item The sum of the weights equal 0, i.e. the dollar neutral or active constraint. This constraint can be specified with \code{type="dollar\_neutral"} or \code{type="active"}. \end{enumerate} -<<>>= +<>= # The full investment constraint can also be specified with type="full_investment" # pspec <- add.constraint(portfolio=pspec, type="full_investment") @@ -119,7 +119,7 @@ \subsection{Box Constraint} Box constraints allows the user to specify upper and lower bounds on the weights of the assets. Here we add box constraints for the asset weights so that the minimum weight of any asset must be greater than or equal to 0.05 and the maximum weight of any asset must be less than or equal to 0.4. The values for min and max can be passed in as scalars or vectors. If min and max are scalars, the values for min and max will be replicated as vectors to the length of assets. If min and max are not specified, a minimum weight of 0 and maximum weight of 1 are assumed. Note that min and max can be specified as vectors with different weights for linear inequality constraints. -<<>>= +<>= # Add box constraints pspec <- add.constraint(portfolio=pspec, type="box", @@ -141,7 +141,7 @@ \subsection{Group Constraint} Group constraints allow the user to specify the the sum of weights by group. Group constraints are currently supported by the ROI, DEoptim, and random portfolio solvers. The following code groups the assets such that the first 3 assets are grouped together labeled GroupA and the fourth asset is in its own group labeled GroupB. The \code{group\_min} argument specifies that the sum of the weights in GroupA must be greater than or equal to 0.1 and the sum of the weights in GroupB must be greater than or equal to 0.15. The \code{group\_max} argument specifies that the sum of the weights in GroupA must be less than or equal to 0.85 and the sum of the weights in GroupB must be less than or equal to 0.55.The \code{group\_labels} argument is optional and is useful if groups is not a named list for labeling groups in terms of market capitalization, sector, etc. -<<>>= +<>= # Add group constraints pspec <- add.constraint(portfolio=pspec, type="group", groups=list(groupA=c(1, 2, 3), @@ -153,7 +153,7 @@ \subsection{Position Limit Constraint} The position limit constraint allows the user to specify limits on the number of assets with non-zero, long, or short positions. The ROI solver interfaces to the Rglpk package (i.e. using the glpk plugin) for solving maximizing return and ETL/ES/cVaR objectives. The Rglpk package supports integer programming and thus supports position limit constraints for the \code{max\_pos} argument. The quadprog package does not support integer programming, and therefore \code{max\_pos} is not supported for the ROI solver using the quadprog plugin. Note that \code{max\_pos\_long} and \code{max\_pos\_short} are not supported for either ROI solver. All position limit constraints are fully supported for DEoptim and random solvers. -<<>>= +<>= # Add position limit constraint such that we have a maximum number of three assets with non-zero weights. pspec <- add.constraint(portfolio=pspec, type="position_limit", max_pos=3) @@ -181,7 +181,7 @@ \subsection{Factor Exposure Constraint} The factor exposure constraint allows the user to set upper and lower bounds on exposures to risk factors. The exposures can be passed in as a vector or matrix. Here we specify a vector for \code{B} with arbitrary values, e.g. betas of the assets, with a market risk exposure range of 0.6 to 0.9. -<<>>= +<>= pspec <- add.constraint(portfolio=pspec, type="factor_exposure", B=c(-0.08, 0.37, 0.79, 1.43), lower=0.6, upper=0.9) @@ -208,7 +208,7 @@ \subsection{Specifying Constraints as Separate Objects} The following examples will demonstrate how to specify constraints as separate objects for all constraints types. -<<>>= +<>= # full investment constraint weight_constr <- weight_sum_constraint(min_sum=1, max_sum=1) @@ -250,7 +250,7 @@ \subsection{Portfolio Risk Objective} The portfolio risk objective allows the user to specify a risk function to minimize Here we add a risk objective to minimize portfolio expected tail loss with a confidence level of 0.95. Other default arguments to the function can be passed in as a named list to arguments. Note that the name of the function must correspond to a function in R. Many functions are available in the \verb"PerformanceAnalytics" package or a user defined function. -<<>>= +<>= pspec <- add.objective(portfolio=pspec, type='risk', name='ETL', @@ -259,7 +259,7 @@ \subsection{Portfolio Return Objective} The return objective allows the user to specify a return function to maximize. Here we add a return objective to maximize the portfolio mean return. -<<>>= +<>= pspec <- add.objective(portfolio=pspec, type='return', name='mean') @@ -267,7 +267,7 @@ \subsection{Portfolio Risk Budget Objective} The portfolio risk objective allows the user to specify constraints to minimize component contribution (i.e. equal risk contribution) or specify upper and lower bounds on percentage risk contribution. Here we specify that no asset can contribute more than 30\% to total portfolio risk. See the risk budget optimization vignette for more detailed examples of portfolio optimizations with risk budgets. -<<>>= +<>= pspec <- add.objective(portfolio=pspec, type="risk_budget", name="ETL", arguments=list(p=0.95), max_prisk=0.3) @@ -289,13 +289,13 @@ Where $\mu$ is the estimated mean asset returns, $\lambda$ is the risk aversion parameter, $lambda_{hhi}$ is the concentration aversion parameter, $HHI$ is the portfolio $HHI$, $\boldsymbol{\Sigma}$ is the estimated covariance matrix of asset returns and $\boldsymbol{w}$ is the set of weights. Here we add a weight concentration objective for the overall portfolio HHI. -<<>>= +<>= pspec <- add.objective(portfolio=pspec, type="weight_concentration", name="HHI", conc_aversion=0.1) @ The weight concentration aversion parameter by groups can also be specified. Here we add a weight concentration objective specifying groups and concentration aversion parameters by group. -<<>>= +<>= pspec <- add.objective(portfolio=pspec, type="weight_concentration", name="HHI", conc_aversion=c(0.03, 0.06), @@ -328,7 +328,7 @@ The following plots illustrate the various methods to generate random portfolios. -<>= +<>= R <- edhec[, 1:4] # set up simple portfolio with leverage and box constraints @@ -370,8 +370,7 @@ fev <- 0:5 par(mfrow=c(2, 3)) for(i in 1:length(fev)){ - rp <- random_portfolios(portfolio=pspec, permutations=2000, - rp_method='simplex', fev=fev[i]) + rp <- rp_simplex(portfolio=pspec, permutations=2000, fev=fev[i]) tmp.mean <- apply(rp, 1, function(x) mean(R %*% x)) tmp.StdDev <- apply(rp, 1, function(x) StdDev(R=R, weights=x)) plot(x=tmp.StdDev, y=tmp.mean, main=paste("FEV =", fev[i]), @@ -387,7 +386,7 @@ par(mfrow=c(1, 2)) # simplex rp_simplex <- random_portfolios(portfolio=pspec, permutations=2000, - rp_method='simplex', fev=0:5) + rp_method='simplex') tmp.mean <- apply(rp_simplex, 1, function(x) mean(R %*% x)) tmp.StdDev <- apply(rp_simplex, 1, function(x) StdDev(R=R, weights=x)) plot(x=tmp.StdDev, y=tmp.mean, main="rp_method=simplex fev=0:5", @@ -450,15 +449,16 @@ @ Run the optimization. -<<>>= +<>= opt_maxret <- optimize.portfolio(R=R, portfolio=maxret, - optimize_method="ROI", trace=TRUE) + optimize_method="ROI", + trace=TRUE) print(opt_maxret) @ Chart the weights and optimal portfolio in risk-return space. The weights and a risk-reward scatter plot can be plotted separately as shown below with the \code{chart.Weights} and \code{chart.RiskReward} functions. The \code{plot} function will plot the weights and risk-reward scatter together. -<>= +<>= plot(opt_maxret, risk.col="StdDev", return.col="mean", main="Maximum Return Optimization", chart.assets=TRUE, xlim=c(0, 0.05), ylim=c(0,0.0085)) @@ -471,14 +471,14 @@ @ Run the optimization. Note that although 'var' is the risk metric, 'StdDev' is returned as an objective measure. -<<>>= +<>= opt_minvar <- optimize.portfolio(R=R, portfolio=minvar, optimize_method="ROI", trace=TRUE) print(opt_minvar) @ Chart the weights and optimal portfolio in risk-return space. -<>= +<>= plot(opt_minvar, risk.col="StdDev", return.col="mean", main="Minimum Variance Optimization", chart.assets=TRUE, xlim=c(0, 0.05), ylim=c(0,0.0085)) @@ -492,13 +492,14 @@ @ Run the optimization. -<<>>= +<>= opt_qu <- optimize.portfolio(R=R, portfolio=qu, - optimize_method="ROI", trace=TRUE) + optimize_method="ROI", + trace=TRUE) print(opt_qu) @ -<>= +<>= plot(opt_qu, risk.col="StdDev", return.col="mean", main="Quadratic Utility Optimization", chart.assets=TRUE, xlim=c(0, 0.05), ylim=c(0, 0.0085)) @@ -511,13 +512,14 @@ @ Run the optimization. -<<>>= +<>= opt_etl <- optimize.portfolio(R=R, portfolio=etl, - optimize_method="ROI", trace=TRUE) + optimize_method="ROI", + trace=TRUE) print(opt_etl) @ -<>= +<>= plot(opt_etl, risk.col="ES", return.col="mean", main="ETL Optimization", chart.assets=TRUE, xlim=c(0, 0.14), ylim=c(0,0.0085)) @@ -525,14 +527,14 @@ \subsection{Maximize mean return per unit ETL with random portfolios} Add mean and ETL objectives. -<<>>= +<>= meanETL <- add.objective(portfolio=init, type="return", name="mean") meanETL <- add.objective(portfolio=meanETL, type="risk", name="ETL", arguments=list(p=0.95)) @ Run the optimization. The default random portfolio method is 'sample'. -<<>>= +<>= opt_meanETL <- optimize.portfolio(R=R, portfolio=meanETL, optimize_method="random", trace=TRUE, search_size=2000) @@ -547,13 +549,13 @@ @ Chart the optimal weights and optimal portfolio in risk-return space. Because the optimization was run with \code{trace=TRUE}, the chart of the optimal portfolio also includes the trace portfolios of the optimization. This is usefule to visualize the feasible space of the portfolios. The 'neighbor' portfolios relative to the optimal portfolio weights can be included the chart of the optimal weights. -<>= +<>= plot(opt_meanETL, risk.col="ETL", return.col="mean", main="mean-ETL Optimization", neighbors=25) @ Calculate and plot the portfolio component ETL contribution. -<>= +<>= pct_contrib <- ES(R=R, p=0.95, portfolio_method="component", weights=extractWeights(opt_meanETL)) barplot(pct_contrib$pct_contrib_MES, cex.names=0.8, las=3, col="lightblue") @@ -563,7 +565,7 @@ \subsection{Maximize mean return per unit ETL with ETL risk budgets} Add objectives to maximize mean return per unit ETL with 40\% limit ETL risk budgets. -<<>>= +<>= # change the box constraints to long only init$constraints[[2]]$min <- rep(0, 6) init$constraints[[2]]$max <- rep(1, 6) @@ -576,15 +578,15 @@ @ Run the optimization. Set \code{traceDE=5} so that every fifth iteration is printed. The default is to print every iteration. -<<>>= +<>= opt_rb_meanETL <- optimize.portfolio(R=R, portfolio=rb_meanETL, optimize_method="DEoptim", search_size=2000, - trace=TRUE, traceDE=5) + trace=TRUE) print(opt_rb_meanETL) @ -<>= +<>= plot(opt_rb_meanETL, risk.col="ETL", return.col="mean", main="Risk Budget mean-ETL Optimization", xlim=c(0,0.12), ylim=c(0.005,0.009)) @@ -598,7 +600,7 @@ \subsection{Maximize mean return per unit ETL with ETL equal contribution to risk} Add objective to maximize mean return per unit ETL with ETL equal contribution to risk. -<<>>= +<>= eq_meanETL <- add.objective(portfolio=init, type="return", name="mean") eq_meanETL <- add.objective(portfolio=eq_meanETL, type="risk", name="ETL", arguments=list(p=0.95)) @@ -608,7 +610,7 @@ @ Run the optimization. Set \code{traceDE=5} so that every fifth iteration is printed. The default is to print every iteration. -<<>>= +<>= opt_eq_meanETL <- optimize.portfolio(R=R, portfolio=eq_meanETL, optimize_method="DEoptim", search_size=2000, @@ -617,7 +619,7 @@ @ Chart the optimal weights and optimal portfolio in risk-return space. -<>= +<>= plot(opt_eq_meanETL, risk.col="ETL", return.col="mean", main="Risk Budget mean-ETL Optimization", xlim=c(0,0.12), ylim=c(0.005,0.009)) @@ -637,7 +639,7 @@ \end{enumerate} Combine the optimizations for easy comparison. -<<>>= +<>= opt_combine <- combine.optimizations(list(meanETL=opt_meanETL, rbmeanETL=opt_rb_meanETL, eqmeanETL=opt_eq_meanETL)) @@ -652,20 +654,20 @@ @ Chart the optimal portfolios of each optimization in risk-return space. -<>= +<>= chart.RiskReward(opt_combine, risk.col="ETL", return.col="mean", main="ETL Optimization Comparison", xlim=c(0.018, 0.024), ylim=c(0.005, 0.008)) @ Calculate the STARR of each optimization -<>= +<>= STARR <- obj_combine[, "mean"] / obj_combine[, "ETL"] barplot(STARR, col="blue", cex.names=0.8, cex.axis=0.8, las=3, main="STARR", ylim=c(0,1)) @ -<>= +<>= chart.RiskBudget(opt_combine, match.col="ETL", risk.type="percent", ylim=c(0,1), legend.loc="topright") @ Modified: pkg/PortfolioAnalytics/vignettes/portfolio_vignette.pdf =================================================================== (Binary files differ) Modified: pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.Rnw =================================================================== --- pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.Rnw 2013-12-19 19:47:08 UTC (rev 3291) +++ pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.Rnw 2013-12-19 19:47:50 UTC (rev 3292) @@ -3,7 +3,6 @@ \usepackage{bm} \usepackage{verbatim} \usepackage[latin1]{inputenc} -% \VignetteIndexEntry{Portfolio Optimization with CVaR budgets in PortfolioAnalytics} \bibliographystyle{abbrvnat} \usepackage{url} @@ -30,8 +29,9 @@ % Or whatever. Note that the encoding and the font should match. If T1 % does not look nice, try deleting the line with the fontenc. +\VignetteIndexEntry{Portfolio Optimization with CVaR budgets in PortfolioAnalytics} + \begin{document} -\SweaveOpts{concordance=TRUE} \title{Vignette: Portfolio Optimization with CVaR budgets\\ in PortfolioAnalytics} @@ -87,7 +87,7 @@ options(width=80) @ -<>=| +<>= library(PortfolioAnalytics) data(indexes) class(indexes) @@ -102,7 +102,7 @@ \subsection{Weight constraints} -<>=| +<>= # Create the portfolio specification object Wcons <- portfolio.spec( assets = colnames(indexes) ) # Add box constraints @@ -112,7 +112,7 @@ @ Given the weight constraints, we can call the value of the function to be minimized. We consider the case of no violation and a case of violation. By default, \verb"normalize=TRUE" which means that if the sum of weights exceeds \verb"max_sum", the weight vector is normalized by multiplying it with \verb"sum(weights)/max_sum" such that the weights evaluated in the objective function satisfy the \verb"max_sum" constraint. -<>=| +<>= constrained_objective( w = rep(1/4,4) , R = indexes, portfolio = Wcons) constrained_objective( w = rep(1/3,4) , R = indexes, portfolio = Wcons) constrained_objective( w = rep(1/3,4) , R = indexes, portfolio = Wcons, @@ -125,32 +125,33 @@ Suppose now we want to find the portfolio that minimizes the 95\% portfolio CVaR subject to the weight constraints listed above. -<>=| +<>= ObjSpec = add.objective( portfolio = Wcons , type="risk",name="CVaR", arguments=list(p=0.95), enabled=TRUE) @ The value of the objective function is: -<>=| +<>= constrained_objective( w = rep(1/4,4) , R = indexes, portfolio = ObjSpec) @ This is the CVaR of the equal-weight portfolio as computed by the function \verb"ES" in the \verb"PerformanceAnalytics" package of \citet{ Carl2007} -<>=| +<>= library(PerformanceAnalytics) -out<-ES(indexes, weights = rep(1/4,4),p=0.95, portfolio_method="component") +out<-ES(indexes, weights = rep(1/4,4),p=0.95, + portfolio_method="component") out$MES @ All arguments in the function \verb"ES" can be passed on through \verb"arguments". E.g. to reduce the impact of extremes on the portfolio results, it is recommended to winsorize the data using the option clean="boudt". -<>=| +<>= out<-ES(indexes, weights = rep(1/4,4),p=0.95, clean="boudt", portfolio_method="component") out$MES @ For the formulation of the objective function, this implies setting: -<>=| +<>= ObjSpec = add.objective( portfolio = Wcons , type="risk",name="CVaR", arguments=list(p=0.95,clean="boudt"), enabled=TRUE) constrained_objective( w = rep(1/4,4) , R = indexes[,1:4] , portfolio = ObjSpec) @@ -159,7 +160,7 @@ An additional argument that is not available for the moment in \verb"ES" is to estimate the conditional covariance matrix through the constant conditional correlation model of \citet{Bollerslev90}. For the formulation of the objective function, this implies setting: -<>=| +<>= ObjSpec = add.objective( portfolio = Wcons , type="risk",name="CVaR", arguments=list(p=0.95,clean="boudt"), enabled=TRUE, garch=TRUE) @@ -169,20 +170,20 @@ \subsection{Minimum CVaR concentration objective function} Add the minimum 95\% CVaR concentration objective to the objective function: -<>=| +<>= ObjSpec = add.objective( portfolio = Wcons , type="risk_budget_objective", name="CVaR", arguments=list(p=0.95, clean="boudt"), min_concentration=TRUE, enabled=TRUE) @ The value of the objective function is: -<>=| -constrained_objective( w = rep(1/4,4) , R = indexes, portfolio = ObjSpec, - trace=TRUE) +<>= +constrained_objective( w = rep(1/4,4) , R = indexes, + portfolio = ObjSpec, trace=TRUE) @ We can verify that this is effectively the largest CVaR contribution of that portfolio as follows: -<>=| +<>= ES(indexes[,1:4],weights = rep(1/4,4),p=0.95,clean="boudt", portfolio_method="component") @ @@ -191,7 +192,7 @@ We see that in the equal-weight portfolio, the international equities and commodities investment cause more than 30\% of total risk. We could specify as a constraint that no asset can contribute more than 30\% to total portfolio risk with the argument \verb"max_prisk=0.3". This involves the construction of the following objective function: -<>=| +<>= ObjSpec = add.objective( portfolio = Wcons , type="risk_budget_objective", name="CVaR", max_prisk = 0.3, arguments=list(p=0.95,clean="boudt"), enabled=TRUE) @@ -213,13 +214,14 @@ \subsection{Minimum CVaR portfolio under an upper 40\% CVaR allocation constraint} The portfolio object and functions needed to obtain the minimum CVaR portfolio under an upper 40\% CVaR allocation objective are the following: -<>= +<>= # Create the portfolio specification object ObjSpec <- portfolio.spec(assets=colnames(indexes[,1:4])) # Add box constraints ObjSpec <- add.constraint(portfolio=ObjSpec, type='box', min = 0, max=1) # Add the full investment constraint that specifies the weights must sum to 1. -ObjSpec <- add.constraint(portfolio=ObjSpec, type="full_investment") +ObjSpec <- add.constraint(portfolio=ObjSpec, type="weight_sum", + min_sum=0.99, max_sum=1.01) # Add objective to minimize CVaR ObjSpec <- add.objective(portfolio=ObjSpec, type="risk", name="CVaR", arguments=list(p=0.95, clean="boudt")) @@ -231,7 +233,7 @@ After the call to these functions it starts to explore the feasible space iteratively and is shown in the output. Iterations are given as intermediate output and by default every iteration will be printed. We set \verb"traceDE=5" to print every 5 iterations and \verb"itermax=50" for a maximum of 50 iterations. -<>= +<>= set.seed(1234) out <- optimize.portfolio(R=indexes, portfolio=ObjSpec, optimize_method="DEoptim", search_size=2000, @@ -245,7 +247,7 @@ <>= names(out) # View the DEoptim_objective_results information at the last iteration -out$DEoptim_objective_results[[601]] +out$DEoptim_objective_results[[length(out$DEoptim_objective_results)]] # Extract stats from the out object into a matrix xtract <- extractStats(out) @@ -264,7 +266,7 @@ The functions needed to obtain the minimum CVaR concentration portfolio are the following: -<>= +<>= # Create the portfolio specification object ObjSpec <- portfolio.spec(assets=colnames(indexes)) # Add box constraints @@ -284,7 +286,7 @@ This portfolio has the near equal risk contribution characteristic: -<>= +<>= print(out) # Verify results with ES function @@ -293,8 +295,9 @@ @ The 95\% CVaR percent contribution to risk is near equal for all four indexes. The neighbor portfolios can be plotted to view other near optimal portfolios. Alternatively, the contribution to risk in absolute terms can plotted by setting \verb"risk.type="absolute". -<<>>= -chart.RiskBudget(out, neighbors=25, risk.type="pct_contrib", col="blue", pch=18) +<>= +chart.RiskBudget(out, neighbors=25, risk.type="pct_contrib", + col="blue", pch=18) @ @@ -304,7 +307,7 @@ As an example, consider the minimum CVaR concentration portfolio, with estimation from inception and monthly rebalancing. Since we require a minimum estimation length of total number of observations -1, we can optimize the portfolio only for the last two months. -<>= +<>= library(iterators) set.seed(1234) out <- optimize.portfolio.rebalancing(R=indexes, portfolio=ObjSpec, Modified: pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.pdf [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3292 From noreply at r-forge.r-project.org Thu Dec 19 22:49:08 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 19 Dec 2013 22:49:08 +0100 (CET) Subject: [Returnanalytics-commits] r3293 - in pkg/PortfolioAnalytics: . tests Message-ID: <20131219214908.D4EA2186852@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-19 22:49:08 +0100 (Thu, 19 Dec 2013) New Revision: 3293 Added: pkg/PortfolioAnalytics/tests/ pkg/PortfolioAnalytics/tests/run-all.R Log: adding folder and file to run all tests Added: pkg/PortfolioAnalytics/tests/run-all.R =================================================================== --- pkg/PortfolioAnalytics/tests/run-all.R (rev 0) +++ pkg/PortfolioAnalytics/tests/run-all.R 2013-12-19 21:49:08 UTC (rev 3293) @@ -0,0 +1,4 @@ +require(testthat) +require(PortfolioAnalytics) + +try(test_package("PortfolioAnalytics")) \ No newline at end of file From noreply at r-forge.r-project.org Fri Dec 20 02:54:08 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 20 Dec 2013 02:54:08 +0100 (CET) Subject: [Returnanalytics-commits] r3294 - pkg/PortfolioAnalytics/vignettes Message-ID: <20131220015408.944DC18656A@r-forge.r-project.org> Author: rossbennett34 Date: 2013-12-20 02:54:08 +0100 (Fri, 20 Dec 2013) New Revision: 3294 Modified: pkg/PortfolioAnalytics/vignettes/ROI_vignette.Rnw pkg/PortfolioAnalytics/vignettes/ROI_vignette.pdf pkg/PortfolioAnalytics/vignettes/portfolio_vignette.Rnw pkg/PortfolioAnalytics/vignettes/portfolio_vignette.pdf pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.Rnw pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.pdf Log: Minor edits to vignettes. Had to add plot.new() before some of the chart functions... not sure why, this was not necessary to do previously. Modified: pkg/PortfolioAnalytics/vignettes/ROI_vignette.Rnw =================================================================== --- pkg/PortfolioAnalytics/vignettes/ROI_vignette.Rnw 2013-12-19 21:49:08 UTC (rev 3293) +++ pkg/PortfolioAnalytics/vignettes/ROI_vignette.Rnw 2013-12-20 01:54:08 UTC (rev 3294) @@ -5,10 +5,10 @@ \usepackage{Rd} \usepackage{amsmath} -\VignetteIndexEntry{Portfolio Optimization with ROI in PortfolioAnalytics} - \begin{document} +% \VignetteIndexEntry{Portfolio Optimization with ROI in PortfolioAnalytics} + \title{Using the ROI solvers with PortfolioAnalytics} \author{Ross Bennett} Modified: pkg/PortfolioAnalytics/vignettes/ROI_vignette.pdf =================================================================== (Binary files differ) Modified: pkg/PortfolioAnalytics/vignettes/portfolio_vignette.Rnw =================================================================== --- pkg/PortfolioAnalytics/vignettes/portfolio_vignette.Rnw 2013-12-19 21:49:08 UTC (rev 3293) +++ pkg/PortfolioAnalytics/vignettes/portfolio_vignette.Rnw 2013-12-20 01:54:08 UTC (rev 3294) @@ -35,7 +35,7 @@ % Or whatever. Note that the encoding and the font should match. If T1 % does not look nice, try deleting the line with the fontenc. -\VignetteIndexEntry{An Introduction to Portfolio Optimization with PortfolioAnalytics} +% \VignetteIndexEntry{An Introduction to Portfolio Optimization with PortfolioAnalytics} \begin{document} @@ -582,7 +582,7 @@ opt_rb_meanETL <- optimize.portfolio(R=R, portfolio=rb_meanETL, optimize_method="DEoptim", search_size=2000, - trace=TRUE) + trace=TRUE, traceDE=5) print(opt_rb_meanETL) @ @@ -594,6 +594,7 @@ Chart the contribution to risk in percentage terms. <>= +plot.new() chart.RiskBudget(opt_rb_meanETL, risk.type="percentage", neighbors=25) @ @@ -627,6 +628,7 @@ Chart the contribution to risk in percentage terms. It is clear in this chart that the optimization results in a near equal risk contribution portfolio. <>= +plot.new() chart.RiskBudget(opt_eq_meanETL, risk.type="percentage", neighbors=25) @ @@ -668,6 +670,7 @@ @ <>= +plot.new() chart.RiskBudget(opt_combine, match.col="ETL", risk.type="percent", ylim=c(0,1), legend.loc="topright") @ Modified: pkg/PortfolioAnalytics/vignettes/portfolio_vignette.pdf =================================================================== (Binary files differ) Modified: pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.Rnw =================================================================== --- pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.Rnw 2013-12-19 21:49:08 UTC (rev 3293) +++ pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.Rnw 2013-12-20 01:54:08 UTC (rev 3294) @@ -3,7 +3,6 @@ \usepackage{bm} \usepackage{verbatim} \usepackage[latin1]{inputenc} -\bibliographystyle{abbrvnat} \usepackage{url} @@ -29,7 +28,7 @@ % Or whatever. Note that the encoding and the font should match. If T1 % does not look nice, try deleting the line with the fontenc. -\VignetteIndexEntry{Portfolio Optimization with CVaR budgets in PortfolioAnalytics} +% \VignetteIndexEntry{Portfolio Optimization with CVaR budgets in PortfolioAnalytics} \begin{document} @@ -46,7 +45,7 @@ \section{General information} -Risk budgets are a central tool to estimate and manage the portfolio risk allocation. They decompose total portfolio risk into the risk contribution of each position. \citet{ BoudtCarlPeterson2010} propose several portfolio allocation strategies that use an appropriate transformation of the portfolio Conditional Value at Risk (CVaR) budget as an objective or constraint in the portfolio optimization problem. This document explains how risk allocation optimized portfolios can be obtained under general constraints in the \verb"PortfolioAnalytics" package of \citet{PortfolioAnalytics}. +Risk budgets are a central tool to estimate and manage the portfolio risk allocation. They decompose total portfolio risk into the risk contribution of each position. \citet{BoudtCarlPeterson2010} propose several portfolio allocation strategies that use an appropriate transformation of the portfolio Conditional Value at Risk (CVaR) budget as an objective or constraint in the portfolio optimization problem. This document explains how risk allocation optimized portfolios can be obtained under general constraints in the \verb"PortfolioAnalytics" package of \citet{PortfolioAnalytics}. \verb"PortfolioAnalytics" is designed to provide numerical solutions for portfolio problems with complex constraints and objective sets comprised of any R function. It can e.g.~construct portfolios that minimize a risk objective with (possibly non-linear) per-asset constraints on returns and drawdowns \citep{CarlPetersonBoudt2010}. The generality of possible constraints and objectives is a distinctive characteristic of the package with respect to RMetrics \verb"fPortfolio" of \citet{fPortfolioBook}. For standard Markowitz optimization problems, use of \verb"fPortfolio" rather than \verb"PortfolioAnalytics" is recommended. @@ -256,8 +255,14 @@ @ It can be seen from the charts that although US Bonds has a higher weight allocation, the percentage contribution to risk is the lowest of all four indexes. -<<>>= + +<>= +plot.new() chart.Weights(out) +@ + +<>= +plot.new() chart.RiskBudget(out, risk.type="pct_contrib", col="blue", pch=18) @ @@ -272,7 +277,8 @@ # Add box constraints ObjSpec <- add.constraint(portfolio=ObjSpec, type='box', min = 0, max=1) # Add the full investment constraint that specifies the weights must sum to 1. -ObjSpec <- add.constraint(portfolio=ObjSpec, type="full_investment") +ObjSpec <- add.constraint(portfolio=ObjSpec, type="weight_sum", + min_sum=0.99, max_sum=1.01) # Add objective for min CVaR concentration ObjSpec <- add.objective(portfolio=ObjSpec, type="risk_budget_objective", name="CVaR", arguments=list(p=0.95, clean="boudt"), @@ -295,7 +301,9 @@ @ The 95\% CVaR percent contribution to risk is near equal for all four indexes. The neighbor portfolios can be plotted to view other near optimal portfolios. Alternatively, the contribution to risk in absolute terms can plotted by setting \verb"risk.type="absolute". -<>= + +<>= +plot.new() chart.RiskBudget(out, neighbors=25, risk.type="pct_contrib", col="blue", pch=18) @ @@ -347,8 +355,9 @@ @ -Of course, DE is a stochastic optimizer and typically will only find a near-optimal solution that depends on the seed. The function \verb"optimize.portfolio.parallel" in \verb"PortfolioAnalytics" allows to run an arbitrary number of portfolio sets in parallel in order to develop "confidence bands" around your solution. It is based on Revolution's \verb"foreach" package \citep{foreach}. +Of course, DE is a stochastic optimizer and typically will only find a near-optimal solution that depends on the seed. The function \verb"optimize.portfolio.parallel" in \verb"PortfolioAnalytics" allows to run an arbitrary number of portfolio sets in parallel in order to develop "confidence bands" around your solution. It is based on Revolution's \verb"foreach" package \citep{foreach}. +\bibliographystyle{abbrvnat} \bibliography{PA} Modified: pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.pdf =================================================================== --- pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.pdf 2013-12-19 21:49:08 UTC (rev 3293) +++ pkg/PortfolioAnalytics/vignettes/risk_budget_optimization.pdf 2013-12-20 01:54:08 UTC (rev 3294) @@ -12,11 +12,16 @@ KJ?????Zq?T???;??$X???%"Y?KN)?o>?,0+?@???+??*?e???Y?????/h? ?g?$???4?.???E?S3??L z0?(???e -?c????#x? ?????W?Ob???Yk?K/?? &!?G?|???hNt?jj????wdY???N????L???'?8?????n]t?Op???PL?;@?}mM??%?????5D?????)??#?{????h?$?Q??Ae?????M??????{????3Z?h? ??????_???:=????t??p?n????0?????F9*/*$}?0????f4?5Nbl?a??C??+sF??PKEV??TA?y ??L DL??l+???? -K????}B???b????p3w?o???@?c???0??q?fk?Sr6e?z0?t????f?X<\@?/<??cC?}?4?C???x\:?V???LN4B??????nk?G??9???:Ti???=???&???C -?? ?????O??? -?S??I?????z~?CD%!b??[ O??*3??3f?N??l&%a&? \?I??3?K??ll4?>??=?Y:??d?r??@?D???????c??h?G?@Wag????2%??>M??)15Nh[%c?M=??4a?e??'????!BC????1ER??.?xFtO?q?y?z???~{??"YfG?@?x???4l\?W?????Aw??a[6?n(??????| -3?P?4??l,??3??\? Spr? +?c????G???wM??J??}?????^?OAL?y; +???Gs"?TSC}??#??EGv???e:'>??96?????v??3~?C??b?????kk??-?Mf-?!*5?@?M??????E?D?&?? +*??fg?hm?v?????j??v-?~??wV??ZUM??5-?E??+"* ?o?Zx?.&P??,?1?vJ5g{0) 3I^??O???i\2gc??????y???&????J'??<8F??{F{>?? +;#???)???i??L??qB?*Cn???? ?.? <E?X? +jLW??)???vy?3??{"?c??????Q??M!?2;????6??'???C?K?8y???z3?F~??xm3?? w???a?z?rL?????#N ???tC?O,U???S???8???Y?gca??????Og?r? endstream endobj 14 0 obj << @@ -138,13 +143,16 @@ endstream endobj 40 0 obj << -/Length 983 +/Length 985 /Filter /FlateDecode >> stream -x??W?o?6~?_!?"6????!-???a??=dE K????\IN???;??g)HV?q???????????????q???W???_??%d???h?q@v??3D|?p??N? *5g?; K??v???zb\T?=Q[?T????`r)???u*????%@`??}?u??s??|9|??????#Z????yY?M???t???J?? ???q?g:?uq???'|?o?,??:??m?->??4??02 ?[Y?(?i?'??Q?D???K??n ?)???IO?W#????^???{????R???)???????E *???q'CF?-d?????*?S3 ?4?i?^?Ag?Qg ???*$??V??/?iX[?9'?Dv"??? 8R????cnY? c?Mj4?R??%~2??3 f? ^?`Q????m???a?????S????W??????C?'???S?-z?1???????1?W???????;?9??W??z*i6?*?.??wsd?9?"d0??C?jP?q?7P???,/?w??9B-?????;2?????????W??B[??&/????^l??.?wGyq?Y????8{?6??A???w??`u8?|?MtZ_?sB1?PL6/??(?>??SQ????????u?? -?"?F??1??oL8A??3?{m??R??|?????`??Q???|???j????p? "D,?yC?wCE??6???"???r}?v?Z???!?z?? H??????6????IP?D?TIE?P?q???g?t?????????A.?O???<b??j?????~????Q?F?]??jX?[?aI?aH@??4r???-??? ??l?????#?)??|??a???S??????,????8???????"???2?a???H???P??? +x??Wmo?6??_!??????????I?a?0??>?E K????\IN????D???%???E??????????????q?????????????[??< ?;??">w??H'L??3????%??\;????1.??????????l0???Q?:??l?? 0??>??:???t??~??G?C?-?jG? +??,??:N?f???`?O?#?v??8?S???8z??#?g?? ?j??m7???tX?q\?????y?%ft???'??N????? +??Q??fA??????8o?uB??l:}??/^E?????B??4?????W?????P;??S??A??'??c?????O??{????R???)???????E *??wq'CF? +d?????*?3 ?4?i?^?Ag?Qgs???*$??V??/6iX[?9?Dv"??? 8R????cnY? c?Mj4?R??%^?????3 ???W?????U???Z?0c?w +???M????????~?a?!??n??????=???u?j?@?????+e??????Z??????y???V=?4?t?? +?t???;?9??D2 ??=??^5(?8??mi??=I;?\2?6?s?~?I?"&2???????f?jFq??ta?I$I?A??????4?<u?FWC?R;|"_??W??lS>??R?_?G}=???????;/???1???S|a??X???>d?!{??G????&??? endstream endobj 44 0 obj << @@ -188,143 +196,594 @@ endstream endobj 50 0 obj << -/Length 1602 +/Length 1438 /Filter /FlateDecode >> stream -x?????6?}?B?E/3?H]E??4?"i???M???,Q6Yrt????P???l?+?C?????8??&a?6 ?;???7????,0n??????;C??)xk??'$2 -jx?P??g???py???QB]nP?!? R -#>?ck??Q???????o???r??????.w ?,?*2??^?????????????wW/???\E?f??w4?!x<~?X?Kl?A??tE$??????Hy -???X??P????U??q??l?j??x??$Y?2K?G?#F????????B?r~??TT??R.??????????z??Q|??:????????Um?c?]??? -???U?0P5-?f]P?R??q??*??S?z,? W?kw??]%Y.?cr??W? -B??9???s???N? -?W?a???M?@)N|??^??2d??QV???$p???l????Y?/4?6-E$??5I??e?La?i`tNG"???&??!?F -?z#k??4? -o?m????D??g???s???;???? -}? ??m?? -?????{bS??m?T????\?gG?i?Av??m?6???PnAM?6?j???ls?0N????u?S?=?6?T???H??1?_0?#?9?k)w?????rq??k -u|b9t???(?t?~????bm???tz??t?K???-DI -!???????8??x??1??<+???B?!m?g??n?H[????? ?NW???L#q+ -L????,!?Tp`y???Js?? 8??&?a?UI"R>E??,X????????I.??g?G?_?5??????????} -ky?2u -?qo.`????G????@u?DFM??RK:'hA????????BB?R%(?L?W??????2???;? -Z?)U???}\c?7A????G@<????^}e? ?\????????O???s ????h???*{p?]??W????? -???M?o?U??h??,???*??km? -?.t|;????:H;`8 ??i?+?C?`???^ y??????=??????????x?q?_?yMG???^??q?p?? ????????lO7????u?2??/D ?X>UO?R?T?:??m???q?-?????????????Z?zL??????V3,  ? -?P?????????_??? +x??ko?6?{~??`?3?,?z??tM?u?e???+Y?m?????&??;?'Yr?l??vj?x??-???"n?4v????????$?;?^O?![??????????? ?v=?c?{???1?H ??}ly??1{????NS??dW???N???????U??%?D??>?d??????^"bnGFv?,E??????r??\??=@??Ka:????o +? D?`?? +???eB??7???Q?\??K?p?2? ????????gq??b; ???????F????!=?!_?.n??0)?~?|~, ?????/??????yd |?J?|{???H?u?{????R???B??????f?u??:H??e?|U5}????? $a???w>I?X_?3???f???].u???m??????nEJ??"Z\? ??SJ?9???????-? ??????:E;?g???{?t????z||W?t??=j??????h??'??.??JB|?:?????[???"????????=??????????????$?#??:Mu??g|???e'A???K\~?I?xP?=??v???? +?t??S;Wv???? +??B0%??????^6??Q +??g?wS?]p?nJ9?6???fS,F??\?z??????j? +?N ??}#??In???tx?M???F??4"?.z??? ?X?V-5> stream -x??Xmo?6??_!?"1+??( -??`????4?>dA@???M????J???????;?>>?5?????^? ?k?!??^?i???L?8??J{??/;???y?s??? 7????'.?G?v??"IdL6?Z??1^ P-Xw ~D??(??2?? -y???@ ^??????????????D&aR2?b???z-?=?????6???O????????????? -???{?? W??\???l?l???; -=;?z~n7?????F]}???f???*?o? -????\?#??;??S.U??p0????U?b?L,????Rh -9??&????J?.?u?:??C?S?ag?5??)????U??????_}3??8??u?Fxp]iT???}o?#Fd???? ?P?E1 \?$?_ at x??~???TMs??n??????j7?:???8?*??)? -?W?R}?z???#E??#=/??T??(?} ??w????8?V.?E?t h?)?/???j?E ?o??&???0i3??&?????b1???Z????z???"??,S_??}?4L????}/??g???/C?$ ? ???~?~d0??t A???A??;Fj??}D??*?[3?K9e*???????PzT37u?j??????Y????:?yi?[j?2`i?`7T?;W??k;_W?#?j??^?5?l?b-h?&?We??(1???t ?? ?W; -hY???y?? -??e??????? -R)??'C>H)TS?+????? [??o?o?OR,l?_??t??v??6N??X?? ??N q???n??IC^6q?4 ?4??.l???hO8 C|b?iSd ?????????????lI???VL?V???:]v????;^???&C@?wo???q?[???? $???&????x?~?rK?u? ??? +x??X?o?6?_!?&1?oI???:????C?L?*??Jr??????dI??8E??y?x??x??}????qp?S???s?? v`???q?P(CM?>?{w?h?O'4?q?H?N)??;qv??9#???a?#????Y??q?J???j~rv.B'??T:??H??9>g??/?+????TP?????????7PvJ|???:????+?zU?I???.???$_???:?T?8????????O?R????r?????e?t???E%?U**???)??c??R?Q<\?_???????YKjUf??????(j ??D?%?T????"??/?????U?/+??`???>m?:Q??????tv.y??I r?o??lY.!e?z:?l|]dY??3Z?) ???}???P??J?8?=????G??}s??TTmJuGk????kBAz?6q??er???"?3????B8?$?`=2D???]?]\/8?f?? ???30dK?:????iQ|?????s"??pr?? +?cn-x??O?8'->&?????rD +???L?=?THL[??r?Gj????9?????:?\?Z???w???We??Q?Vv?KTEz????JK'U???t?T???]???-??)g??5?A^??3nS??????????=??@0 +??TQ +*?Sn??_?$pp??\??O???i??LM??O?????4???u???H(?!2?T"O?A?4??(?> stream -x??Y[o?6~??????IQ?b~??????X??% Y?mv???????;I?T???? -4yL? y.?s?Q-?]?K8?????G??K???/?F?F6?s?Q?#?????;?j$?>?p?@??QW???~?[??,>?? ?`??RG?Z;$^j????i?????~7?0??WO?????????nZ?y*?"?./I??#O???????CS??z7???)?L4???????X>$v??????Q???? Is???c????|P?P5$&Q4?S??$??F?S?P??Sm????kn< ?8???z6????0?nW?Y???????cp\?????R9o??n?^?u?n??+c????'1bzcBw?L?j????2??.??????I???P??l?p?????A&i?|??a??Shq???G?-.?????????z????E=??&?????I????P?????6????3?^?58;]"9;??_? ??p?$?nO ?????????}/??]?7?{?}???q???*G?'|????s???9??Sp?gzl`? -??v????+-W??x?K>??!l?!?????Sf??EU??K??????RcbM?}?)?E6?DX???}?????\}g&y?o_????{5?????v??????z?[??Q???}#??.?0??<5*???????=??$?)?&???`?g!?E -??g -$+?p>?U??$FQ?s&?"????? +x??W?o?0~???T????>???=???&?a-?KW?B?i!-???.qH +4 at l?4??s?|????0*?"????~Y????-F??q?U?j[??PY?O?l??D??XP?%a?Q? ?V9/P0?h?T C?)?>? i?p?g}?o?]*K,B????$?? F*cN?#r?99?F??N????m?#???V???7p?F???l_|m????f?n??Fh?:_???y1?????????&x??^????R4 +??n^?z?[Q?U?7:??????h????L??0?????yv?d??2s???O??K?!?Byez?*/gWx)?C?`!> stream -x???n????_A8K?Ygx+??Mw?HQ ?c??) ?I?P?v8?????3gH?2??k?@??5?3?~e?(??U????z???A??4N??}???g"??$???]????Z?y??ok?v???"???[w?hs?[k??6???{?h???2??a?J??V???#???C?Z?, ??V??????8 U???e???! ?|?? -0X????m3???????k??B???W?"?'dXn?B???UtDO???b*?@???#w?Z????OI1Q+/2I???e???6:?@3???7? A?"&d?s??o????????A??~1?????W?????\?(X???:]???IY??$ ? -?W????? ?{Bg"?m"????????4^??(a??d??X?n???we???NVH?t????$j{ ??? ??>???6q???^?ynY????????$ ?>W?? C??+?o]4&,???????l?^}5N????9??;4???K???A?y? -?u???H??o?!??i??Vk??????U???O????????K?x3y?"~h6: ?4 -??bj??|?p?0?>?"?h?{?#p?L?e?4u2x?k5PoOt???R?U?L?$??[P'??,OYS?LywVF??n-?????l??9Q??"?cP9?O-?|????ww?@?'?AI2?`&??;l?*l??lx??c8.???\?C??/K? [??????N??U??????$!{ ~??>?$?????Q????F????H??f?????p???s -?P???????W$DsGq?*?s$$& -????e9?I: ?,?w???}???6 &???w|???FE?,?N?+?c???mv?!?R???@?-5?.??r??1??G??w?-]?p? -y?????5OJ??/??E?;?h???!?????%??/??r?7??F??Y?x???nx??O?4?????-rH??H????!???F???#??]???x????/?S??B?e??a?^-)f"?j~?Y]~?&?}?Pl\???u}??{? ???????????gm?f?o@????^???,?K???????~(;Z???w??k?^?K?!~??l? ???J?~????[??m???:??%????TJ? ??\xn^?R?6^$? +x???MOA ???#qhP??=??? +???z(??Tj!T? +????3? ???rYvg??g??;Xb1???_???r?~F??^?E??Sy??Too????5#0h"Y?l?? +?????|????z +?~n?&?G?4f??????$?4?y3?2?kdG?????|?????dj???????R?,x?/ L?"???/E?????>???+0????S??-'???? ??,?|? +??H@????S?~?Ve????/???bu???????rV?pys????: +ee\*????,1?*c??A??Qj,0-??#GYs??+0?#@??$L??u?a??T?f??g???!=?V?9*???V?1???????l????Sy??dJ?r8TZWW +A?-? ???N???8Dam?Y? ??9&???]???\NY?_?2]>???<>e?????I??z<4???????[?Pm????7p???8+p> stream -x??X[o?6~?? ?>?@??*Jy???@Qt???i?1??hP$W??m?~?"m??S?FT$E? ???<o?Q?5E??gs{???Z??????u?????N???G?? ????yD?D`*?f??60B!???~|T%X?s?b?sd??*s??t??N,A?8?j8?^h?}????C???$x?p??>H??` -??(1????%?????'?X??*? ? ?FE???? ??"????m??3?rzV??"?B6(??????u???$?d?7?BN??k??n????{E????u? |?????C???:/?????/^?'']]?V????c?????.??lH????V?b%#?????{8?5~?kug?0F???#?5Z??jcj?o?i??f? ??????????,~????v???v?p???%Y?????1??????Y?[?fG??y[??=?37???u?g??Z?-mO?+/e?????W/7w;??`n??u X????[?8_?????@?R??jK????O??8????>?>??5O?G?lW_??? - ?/l???????(?x[?U}9 )? ????%??f?[????\?"??P -???????U?|??~Z?????\~?9o+??DF?.V?B?u???&?????&???6??!????uf??-b?b???\a??j????????yI??????I??i? qBx???c?M?Ox??Z??*?7? ??F??C??? +x??T?n?0??+?"?}?I????Em?,YFm3?d????H???v?=??Y???|?????i?~4??&A +?? ???????4|q?sB?A??Hi????X'>.8?T d$6???DU?p1?Kv{=K?w?" p???BF??0Xp?fs?=???d?????'?tf?LqBR??U?Lh??`?s? v?Q???p??3??N??5??? ???P????'o??_W#8??_??=??jteT`+??z? ??;`?lZ???x?dL?ep?????qk?2iW?d1???? +~W??Y??j?]???K?^??n}????"m???Y?1SG P?? ??.?\, ??m??????e??m?/??vv:^?XKv<^8???1^??Zs?]???U??88 9?N???N??V????? +?z4B?F??C?D????\?G?????-???o?Q?c?k? +Z[9?????????;H?)???91^?? ???P???>1?b`z??????v?r(?????u/??a?,?? +???(?x????????? endstream endobj -66 0 obj << -/Length 2036 +61 0 obj << +/Type /XObject +/Subtype /Form +/FormType 1 +/PTEX.FileName (./figure/unnamed-chunk-181.pdf) +/PTEX.PageNumber 1 +/PTEX.InfoDict 66 0 R +/BBox [0 0 432 288] +/Resources << +/ProcSet [ /PDF /Text ] +/Font << >> +/ExtGState << +>>/ColorSpace << +/sRGB 67 0 R +>>>> +/Length 20 /Filter /FlateDecode >> stream -x??XQo?6~???'?kZ$EI p?nv?????/}?. -??c???KI????f8??r?I???% -?!?}3?????UD?{7??????(???/uys?x??@3??$?Yl??LK?r??Qzyf??k??%?SV?????5?`?9????m???a???????-???6?5?[7U??]na????G??Lj9 .''???????????G@??p ???Hy|??$?6.? q*mK -?????4????3???????????C s?!b?fG?oVM??P?RM?2d???j?q?Gc?s??Twe????H???:?U?w_?1??y???????.q=??????`I???J?@L??Lp#?U?C?]??s~??;??u???L??+Z??" -v??????2]C??J,eC?hEn?fm,?Uh8?LkU?T?????I^??????.????=Y?%?(\1??@??r??x?)?E t+??+1?e??W?-????R -??P??rQ??T:???V???b?L?????`Li?}?n?nwN -"3h??E?b?zy?O????(????????w ??????T?g????\?AP?O"???????'X???MR ???]???_?????q? -??????/:g??,?Co????+????~C^^??k????@(?S?}??I?]G D&???8?0???I@??????? ?? ??? =???;??/14?*f??G??rk0*???LF?0????G?)?,?DI??? -?e???2?#>P-L)?*FJ??e=???^?????????G???#4+?? - ??;??2?=????dr??W] ?Hr[Bj?3????O?g???W??%?y?7?~?8B`;S??@??c?tBp_??2WO?J????7?j??$^?????????Hq???Xg?GB?HyQ?Z??O? ?t?Q.%??g?????r?%?D?????{?0?z???????Hq?C?m?m?=???6?^5/?Uo?9?D?~>E?m_?A]?????2?(????`$`$? ?}F2??x0F? ????b6M?q#???K x???-??XU}???!\????[c??*5???6>1?4I?k??,kz??=???+?R???OT??R????=_,,????0???Pu?6??? k?????b*Ed?B??E,c?????[?q? ?!3???(????Qi?????%??I8???08T??`?X???o?PS??Ml?{??tF=? ????????p><8?y> +stream +x???wTS????7?P????khRH +?H?.*1 J??"6DTpDQ??2(???C??"??Q??D?qp?Id???y?????~k????g?}??????LX ? ?X??????g` ?l?p??B?F?|??l???? ??*????????Y"1P??????\?8=W?%?O???4M?0J?"Y?2V?s?,[|??e9?2?<?s??e???'??9???`???2?&c?tI?@?o??|N6(??.?sSdl-c?(2?-?y?H?_??/X??????Z.$??&\S???????M????07?#?1??Y?rf??Yym?";?8980m-m?(?]????v?^??D???W~? +??e????mi]?P????`/???u}q?|^R??,g+???\K?k)/????C_|?R????ax??8?t1C^7nfz?D????p? ?????u?$??/?ED??L L??[???B?@???????????????X?!@~(* {d+??} ?G???????????}W?L??$?cGD2?Q????Z4 E@?@??????A(?q`1???D ??????`'?u?4?6pt?c?48.??`?R0??)? +?@???R?t C???X??CP?%CBH@??R?????f?[?(t? +C??Qh?z#0 ??Z?l?`O8?????28.????p|??O???X +????:??0?FB?x$ !???i@?????H???[EE1PL? ??????V?6??QP??>?U?(j +?MFk?????t,:??.FW???????8???c?1?L&?????9???a??X?:??? +?r?bl1? +{{{;?}?#?tp?8_\?8??"?Ey?.,?X?????%?%G??1?-??9????????K??l?.??oo???/?O$?&?'=JvM??x??????{????=Vs\?x? ????N???>?u?????c?Kz???=s?/?o?l????|??????y???? ??^d]???p?s?~???:;???/;]??7|?????W????p???????Q?o?H?!?????V????sn??Ys}?????????~4??]? =>?=:?`??;c??'?e??~??!?a???D?#?G?&}'/?^?x?I??????+?\????w?x?20;5?\?????_??????e?t???W?f^??Qs?-?m???w3????+??~???????O?~???? +endstream +endobj +73 0 obj << +/Length 385 +/Filter /FlateDecode +>> +stream +x??TMo?0 ??WX?@ZCR???mL?mSo?4?R>4?]W4???-E?? T?n???8g(?M1;7??>?@S@??*Ak8\0! Hc?u?U?0g%???zb??q?V?f?=????iW?=SG??[G????0????(+???D?n$ 2N*?????????f?AS +V_????N??????W?a?G:G +# +???]B??y?Y?'????Y???O?-~l???R?C??m?X????W4??Ut?8l at wu????GQ?????p3?????-2m?O=??7?PE?[PV?????#\D@?I??m?C?J'O??$[??b?9?"A4 ?l?6?x?I/K?'???^??Kw??%&?0????_b??A?"?w"??8?A]???8u?F???A?9? +endstream +endobj +62 0 obj << +/Type /XObject +/Subtype /Form +/FormType 1 +/PTEX.FileName (./figure/unnamed-chunk-182.pdf) +/PTEX.PageNumber 1 +/PTEX.InfoDict 74 0 R +/BBox [0 0 432 288] +/Resources << +/ProcSet [ /PDF /Text ] +/Font << /F2 75 0 R/F3 76 0 R>> +/ExtGState << +>>/ColorSpace << +/sRGB 77 0 R +>>>> +/Length 989 +/Filter /FlateDecode +>> +stream +x??V?n\7 ???????????6?"Z??YY????? +w??K?z??M&L?91J???O???L?<{??????????jf~???*i??5???????yr-??/?? +endstream +endobj +79 0 obj +<< +/Alternate /DeviceRGB +/N 3 +/Length 2596 +/Filter /FlateDecode +>> +stream +x???wTS????7?P????khRH +?H?.*1 J??"6DTpDQ??2(???C??"??Q??D?qp?Id???y?????~k????g?}??????LX ? ?X??????g` ?l?p??B?F?|??l???? ??*????????Y"1P??????\?8=W?%?O???4M?0J?"Y?2V?s?,[|??e9?2?<?s??e???'??9???`???2?&c?tI?@?o??|N6(??.?sSdl-c?(2?-?y?H?_??/X??????Z.$??&\S???????M????07?#?1??Y?rf??Yym?";?8980m-m?(?]????v?^??D???W~? +??e????mi]?P????`/???u}q?|^R??,g+???\K?k)/????C_|?R????ax??8?t1C^7nfz?D????p? ?????u?$??/?ED??L L??[???B?@???????????????X?!@~(* {d+??} ?G???????????}W?L??$?cGD2?Q????Z4 E@?@??????A(?q`1???D ??????`'?u?4?6pt?c?48.??`?R0??)? +?@???R?t C???X??CP?%CBH@??R?????f?[?(t? +C??Qh?z#0 ??Z?l?`O8?????28.????p|??O???X +????:??0?FB?x$ !???i@?????H???[EE1PL? ??????V?6??QP??>?U?(j +?MFk?????t,:??.FW???????8???c?1?L&?????9???a??X?:??? +?r?bl1? [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3294 From noreply at r-forge.r-project.org Mon Dec 23 07:14:36 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 23 Dec 2013 07:14:36 +0100 (CET) Subject: [Returnanalytics-commits] r3295 - in pkg/FactorAnalytics: R sandbox Message-ID: <20131223061436.EF742184FF2@r-forge.r-project.org> Author: chenyian Date: 2013-12-23 07:14:36 +0100 (Mon, 23 Dec 2013) New Revision: 3295 Modified: pkg/FactorAnalytics/R/.Rhistory pkg/FactorAnalytics/R/fitFundamentalFactorModel.R pkg/FactorAnalytics/sandbox/test.vignette.r Log: debug: 1. assign the right colnames to industry model in fitFundamentalFactorModel.R 2. assign the correct weights to wls method in fitFundamentalFactorModel.R Modified: pkg/FactorAnalytics/R/.Rhistory =================================================================== --- pkg/FactorAnalytics/R/.Rhistory 2013-12-20 01:54:08 UTC (rev 3294) +++ pkg/FactorAnalytics/R/.Rhistory 2013-12-23 06:14:36 UTC (rev 3295) @@ -1,512 +1,512 @@ -eigenvector <- eigen(cov(data))$vectors -eigenvalues <- eigen(cov(data))$values -abline(a=0,b=eigenvector[2,1]/eigenvector[1,1],col="red") -abline(a=0,b=eigenvector[2,2]/eigenvector[1,2],col="red") -covvar <- cbind(c(2,1),c(1,1)) -data <- rmvnorm(100,mean=c(0,0),sigma=covvar) -eigenvector <- eigen(cov(data))$vectors -eigenvector -eigenvalues <- eigen(cov(data))$values -eigenvalues -plot(data) -abline(a=0,b=eigenvector[2,1]/eigenvector[1,1],col="red") -abline(a=0,b=eigenvector[2,2]/eigenvector[1,2],col="red") -eigenvector <- eigen(cor(data))$vectors -eigenvector -eigenvalues <- eigen(cor(data))$values -eigenvalues -plot(data) -abline(a=0,b=eigenvector[2,1]/eigenvector[1,1],col="red") -abline(a=0,b=eigenvector[2,2]/eigenvector[1,2],col="red") -covvar <- cbind(c(2,-1),c(-1,1)) -data <- rmvnorm(100,mean=c(0,0),sigma=covvar) -eigenvector <- eigen(cor(data))$vectors -eigenvector -eigenvalues <- eigen(cor(data))$values -eigenvalues -plot(data) -abline(a=0,b=eigenvector[2,1]/eigenvector[1,1],col="red") -abline(a=0,b=eigenvector[2,2]/eigenvector[1,2],col="red") -covvar <- cbind(c(0,-1),c(-1,0)) -data <- rmvnorm(100,mean=c(0,0),sigma=covvar) -covvar <- cbind(c(0,1),c(1,0)) -data <- rmvnorm(100,mean=c(0,0),sigma=covvar) -eigen(covvar) -covvar <- cbind(c(0,1,0),c(1,0,1),c(0,1,0)) -covvar -eigen(covvar) -covvar <- cbind(c(1,1,0),c(1,1,1),c(0,1,1)) -covvar -eigen(covvar) -covvar <- cbind(c(2,1,0),c(1,1,1),c(0,1,1)) -covvar -eigen(covvar) -cor(covvar) -covvar <- cbind(c(1,1,0),c(1,1,1),c(0,1,1)) -covvar -eigen(covvar) -cor(covvar) -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -p <- 0.9 -q <- 0.1 -r <- 0.8 -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -is.positive.definite(chol) -eigen(covvar) -covvar -chol <- cbind(c(2,p,q),c(0,1,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -is.positive.definite(chol) -eigen(covvar) -chol <- cbind(c(20,p,q),c(0,1,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -eigen(covvar) -data <- rmvnorm(100,mean=c(0,0,0),sigma=covvar) -install.packages("scatterplot3d") -library(mvtnorm) -library(scatterplot3d) -? scatterplot3d -scatterplot3d(data) -trans3d(data) -trans3d(data[,1],data[,2],data[,3]) -scatterplot3d(data,highlight.3d=TRUE, col.axis="blue", -col.grid="lightblue", main="scatterplot3d - 1", pch=20) -eigen(covvar) -eigenvector <- eigen(cor(data))$vectors -eigenvector -eigenvector <- eigen(cov(data))$vectors -eigenvector -p <- 10 -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -p <- 1 -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,0,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -p <- .1 -chol <- cbind(c(1,p,q),c(0,0,r),c(0,0,1)) -covvar <- chol%*%t(chol) -p <- .1 -p <- .1 -q <- 0.1 -r <- 0.8 -chol <- cbind(c(1,p,q),c(0,0,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,1)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,0.7)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.65)) -covvar <- chol%*%t(chol) -covvar -is.positive.definite(chol) -eigen(covvar) -r <- 10 -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.65)) -covvar <- chol%*%t(chol) -covvar -r <- 1 -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.65)) -covvar <- chol%*%t(chol) -covvar -r <- 0.1 -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.65)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.9)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.98)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.999)) -covvar <- chol%*%t(chol) -covvar -eigen(covvar) -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.997)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.9999)) -covvar <- chol%*%t(chol) -covvar -r <- 0.5 -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.9999)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.8)) -covvar <- chol%*%t(chol) -covvar -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.9)) -covvar <- chol%*%t(chol) -covvar -eigen(covvar) -chol <- cbind(c(1,p,q),c(0,1,r),c(0,0,.9)) -data <- rmvnorm(100,mean=c(0,0,0),sigma=covvar) -pc <- princomp(data) -summary(pc) -plot(pc) -loadings(pc) -eigen(cov(data)) -data <- rmvnorm(100,mean=c(1,0,0),sigma=covvar) -eigen(cov(data)) -pc <- princomp(data) -summary(pc) -loadings(pc) -data <- rmvnorm(100,mean=c(0,0,0),sigma=covvar) -# download data small scale experiment -# using the finance sector provided by CNN money -library(quantmod) -library(PerformanceAnalytics) -symbol.vec=c("AAN","AB","ACAS","ACY","AFL","AIG","AMG","AXP","BAC","BGCP", -"C","CCNE","DB","GS","HCC","IHC","JPM","KEY","PLFE","TCHC") -getSymbols(symbol.vec, from ="2000-01-03", to = "2012-05-10") -# extract monthly adjusted closing prices -l <- length(symbol.vec) -db.m.price <- to.monthly(AAN)[, "AAN.Adjusted", drop=FALSE] -colnames(db.m.price) <- "AAN" -db.m.ret <- CalculateReturns(db.m.price, method="compound")[-1,] -for (i in (2:l)) { -name.price <- paste(symbol.vec[i],"m","price",sep=".") -stock <- as.name(symbol.vec[i]) -db.m.new <- to.monthly(eval(stock))[,"eval(stock).Adjusted",drop=FALSE] -colnames(db.m.new) <- symbol.vec[i] -db.m.price <- cbind(db.m.price,db.m.new) -# calculate log-returns -db.m.ret.new <- CalculateReturns(db.m.new, method="compound")[-1,] -db.m.ret <- cbind(db.m.ret,db.m.ret.new) +nrow=6) +gplot(t(adj.mat),gmode="digraph",label=c(1,2,3,4,5,6),vertex.cex=2, +arrowhead.cex = 1) +gplot(t(adj.mat1),gmode="digraph",label=c(1,2,3,4,5,6),vertex.cex=2, +arrowhead.cex = 1) +gplot(t(adj.mat1),gmode="digraph",label=c(1,2,3,4,5,6),vertex.cex=2, +arrowhead.cex = 1) +gplot(t(adj.mat),gmode="digraph",label=c(1,2,3,4,5,6),vertex.cex=2, +arrowhead.cex = 1) +rm(list=ls()) +library(factorAnalytics) +library(fEcofin) +ts.berndt<-xts(berndtInvest[,-1],as.Date(berndtInvest[,1])) +data(stat.fm.data) +View(sfm.dat) +install.packages("~/R-project/returnanalytics/pkg/FactorAnalytics/sandbox/fEcofin_2100.77.zip-UWunsafe", repos = NULL) +install.packages("~/R-project/returnanalytics/pkg/FactorAnalytics/sandbox/fEcofin_2100.77.zip", repos = NULL) +library(fEcofin) +? fEconfin +fEconfin +help(pakcage=fEconfin) +help(package=fEconfin) +help(package=fEcofin) +data(berndtInvest) +ts.berndt<-xts(berndtInvest[,-1],as.Date(berndtInvest[,1])) +berndt<-ts.berndt['1978/1987'] +returns<-berndt[,c(-10,-17)] +tickers <- names(returns) +num.tickers <- length(tickers) +dates <- index(returns) +num.dates <- length(dates) +sector<-c("OTHER","OTHER","OIL","TECH","TECH","OIL","OTHER","OTHER", +"TECH","OIL","OIL","OTHER","TECH","OIL","OTHER") +stacked.returns <- data.frame( +DATE=rep(dates,num.tickers), +TICKER=rep(tickers,each=num.dates), +RETURN=c(coredata(returns)), +SECTOR=rep(sector,each=num.dates), +stringsAsFactors=FALSE) +head(stacked.returns) +barra <- fitFundamentalFactorModel(data=stacked.returns,exposure.names="SECTOR", +datevar="DATE",returnsvar="RETURN", +assetvar="TICKER",wls=TRUE) +head(barra$factor.returns) +barra$beta +barra.cov <- factorModelCovariance(barra$beta, barra$factor.cov$cov, barra$resid.variance) +barra.cor <- cov2cor(barra.cov) +round(barra.cor,2) +View(stacked.returns) +returns = berndtInvest[,-c(1,11,18)] +n.stocks = ncol(returns) +tech.dum = oil.dum = other.dum = matrix(0,n.stocks,1) +tech.dum[c(4,5,9,13),] = 1 +oil.dum[c(3,6,10,11,14),] = 1 +other.dum = 1 - tech.dum - oil.dum +B = cbind(tech.dum,oil.dum,other.dum) +dimnames(B) = list(colnames(returns),c("TECH","OIL","OTHER")) +B +returns = t(returns) +F.hat = solve(crossprod(B))%*%t(B)%*%returns +E.hat = returns - B%*%F.hat +diagD.hat = apply(E.hat,1,var) +Dinv.hat = diag(diagD.hat^(-1)) +H = solve(t(B)%*%Dinv.hat%*%B)%*%t(B)%*%Dinv.hat +round(H[,1:8],5) +apply(H,1,sum) +F.hat = H%*%returns +E.hat = returns - B%*%F.hat +diagD.hat = apply(E.hat,1,var) +F.hat = t(F.hat) +F.hat +round(H[,1:8],5) +H +B +returns +View(berndtInvest) +H +names(barra) +barra$factor.returns +H +F.hat +head(barra$factor.returns) +head(F.hat) +oil.f.ret <- barra$returns[,1] +oth.f.ret <- barra$returns[,1]+barra$returns[,2] +tech.f.ret <- barra$returns[,1]+barra$returns[,3] +head(oil.f.ret) +oil.f.ret <- barra$factor.returns[,1] +tech.f.ret <- barra$factor.returns[,1]+ barra$factor.returns[,3] +oth.f.ret <- barra$factor.returns[,1]+barra$factor.returns[,2] +head(oil.f.ret) +head(F.hat) +head(F.hat)[,2] +head(barra$factor.returns) +head(F.hat) +head(cbind(tech.f.ret,oil.f.ret,oth.f.ret)) +tickers +cbind(tickers,sector) +barra$beta +names(barra) +? fitFundamentalFactorModel +barra.cov2 <- barra$factor.cov +barra.cov2 +barra.cov2 <- barra$returns.cov +barra.cov2 +barra.cor2 <- cov2cor(barra.cov2) +barra.cor2 <- cov2cor(barra.cov2$cov) +cov.ind = B%*%var(F.hat)%*%t(B) + diag(diagD.hat) +sd = sqrt(diag(cov.ind)) +cor.ind = cov.ind/outer(sd,sd) +cor.samp <- cor(t(returns)) +View(cor.samp) +View(barra.cor2) +data(berndtInvest) +ts.berndt<-xts(berndtInvest[,-1],as.Date(berndtInvest[,1])) +berndt<-ts.berndt['1978/1987'] +returns<-berndt[,c(-10,-17)] +tickers <- names(returns) +num.tickers <- length(tickers) +dates <- index(returns) +num.dates <- length(dates) +sector<-c("OTHER","OTHER","OIL","TECH","TECH","OIL","OTHER","OTHER", +"TECH","OIL","OIL","OTHER","TECH","OIL","OTHER") +stacked.returns <- data.frame( +DATE=rep(dates,num.tickers), +TICKER=rep(tickers,each=num.dates), +RETURN=c(coredata(returns)), +SECTOR=rep(sector,each=num.dates), +stringsAsFactors=FALSE) +head(stacked.returns) +data=stacked.returns +exposure.names="SECTOR" +datevar="DATE", +datevar="DATE" +returnsvar="RETURN" +assetvar="TICKER" +wls=TRUE +full.resid.cov=FALSE +assets = unique(data[[assetvar]]) +timedates = as.Date(unique(data[[datevar]])) +data[[datevar]] <- as.Date(data[[datevar]]) +if (length(timedates) < 2) +stop("At least two time points, t and t-1, are needed for fitting the factor model.") +if (!is(exposure.names, "vector") || !is.character(exposure.names)) +stop("exposure argument invalid---must be character vector.") +if (!is(assets, "vector") || !is.character(assets)) +stop("assets argument invalid---must be character vector.") +wls <- as.logical(wls) +full.resid.cov <- as.logical(full.resid.cov) +robust.scale = FALSE +standardized.factor.exposure = FALSE +numTimePoints <- length(timedates) +numExposures <- length(exposure.names) +numAssets <- length(assets) +# check if exposure.names are numeric, if not, create exposures. factors by dummy variables +which.numeric <- sapply(data[, exposure.names, drop = FALSE],is.numeric) +exposures.numeric <- exposure.names[which.numeric] +# industry factor model +exposures.factor <- exposure.names[!which.numeric] +if (length(exposures.factor) > 1) { +stop("Only one nonnumeric variable can be used at this time.") } -head(db.m.price) -dim(db.m.price) -dim(db.m.ret) -corr.m <- cor(db.m.ret) -corr.m.inv <- solve(corr.m) -db.pc <- princomp(db.m.ret) -summary(db.pc) -centrality <- loadings(db.pc)[,1] -centrality -eigen(corr.m.inv) -centrality -centrality.inv <- eigen(corr.m.inv)$vectors[,1] -eigen(corr.m)$vectors[,1] -cov.m.inv <- solve(cov(db.m.ret)) -centrality.inv <- eigen(cov.m.inv)$vectors[,1] -centrality.inv -eigen(cov(db.m.ret))$vectors[,1] -centrality -centrality.inv -head(db.m.ret) -names(centrality.inv) <- colnames(db.m.ret) -centrality.inv -covvar <- cbind(c(0.8,0.1,0.1),c(0.8,0.1,.1),c(.8,.1,.1)) -covvar -covvar <- cbind(c(0.8,0.8,0.8),c(0.1,0.1,.1),c(.1,.1,.1)) -covvar -eigen(covvar) -covvar <- cbind(c(0.5,0.5,0.5),c(0.4,0.4,.4),c(.1,.1,.1)) -covvar -eigen(covvar) -sum(eigen(covvar)$vectors[,1]^2) -eigen(covvar)$vectors[,1]^2 -sd(eigen(covvar)$vectors[,1]) -covvar <- cbind(replicate(3,c(.33,.33,.33)) -covvar <- cbind(replicate(3,c(.33,.33,.33))) -covvar -covvar <- cbind(replicate(3,c(.33,.33,.33))) -covvar -eigen(covvar) -sd(eigen(covvar)$vectors[,1]) -covvar <- cbind(c(0.5,0.4,0.5),c(0.4,0.5,.4),c(.1,.1,.1)) -covvar -eigen(covvar) -covvar <- cbind(c(0.5,0.4,0.3),c(0.4,0.5,.6),c(.1,.1,.1)) -covvar -eigen(covvar) -sd(eigen(covvar)$vectors[,1]) -covvar <- cbind(c(0.5,0.4,0.3),c(0.4,0.5,.5),c(.1,.1,.2)) -covvar -eigen(covvar) -sd(eigen(covvar)$vectors[,1]) -covvar <- cbind(c(0,0.7,0.5),c(0.9,0,.5),c(.1,0.3,0)) -covvar -eigen(covvar) -eigen(t(covvar) -eigen(t(covvar)) -eigen(t(covvar)) -covvar -t(covvar) -eigen(t(covvar)) -covvar <- cbind(c(0.1,0.7,0.5),c(0.8,0.1,.2),c(.1,0.2,0.3)) -covvar -t(covvar) -eigen(t(covvar)) -sd(eigen(covvar)$vectors[,1]) -eigen(covvar) -t(covvar) -eigen(t(covvar)) -covvar <- cbind(c(0.8,0.8,0.8),c(0.1,0.1,.1),c(.1,0.1,0.1)) -covvar -eigen(covvar) -t(covvar) -eigen(t(covvar)) -sd(eigen(covvar)$vectors[,1]) -sd(eigen(t(covvar))$vectors[,1]) -t(covvar) -library("rmgarch") -? dcc -? DCC.fit -? dccfit -eigen(diag(2)) -eigen(matrix(rep(1,4),nrow=2)) -eigen(matrix(c(1,-1,-1,1),nrow=2)) -covvar <- matrix(rep(1,9),nrow=3) -n <- length(covvar[1,]) -alpha <- eigen(cov(covvar))$values[1] -10^(-3) -solve(diag(n)-alpha*cov(covvar))%*%rep(1,n) -alpha <- eigen(covvar)$values[1] -10^(-3) -solve(diag(n)-alpha*cov(covvar))%*%rep(1,n) -eigen(covvar)$values -alpha <- eigen(covvar)$values[1] -10^(-3) -solve(diag(n)-alpha*cov(covvar))%*%rep(1,n) -kalz <- function(covvar) { -n <- length(covvar[1,]) -alpha <- eigen(covvar)$values[1] -10^(-3) -kalz.ec <- solve(diag(n)-alpha*cov(covvar))%*%rep(1,n) -return(kalz.ec) +exposures.factor +regression.formula <- paste("~", paste(exposure.names, collapse = "+")) +if (length(exposures.factor)) { +regression.formula <- paste(regression.formula, "- 1") +data[, exposures.factor] <- as.factor(data[,exposures.factor]) +exposuresToRecode <- names(data[, exposure.names, drop = FALSE])[!which.numeric] +contrasts.list <- lapply(seq(length(exposuresToRecode)), +function(i) function(n, m) contr.treatment(n, contrasts = FALSE)) +names(contrasts.list) <- exposuresToRecode +} else { +contrasts.list <- NULL } -kalz(covvar) -covvar2 <- matrix(rep(.1,9),nrow=3) -kalz(covvar2) -kalz <- function(covvar) { -n <- length(covvar[1,]) -alpha <- eigen(covvar)$values[1] -10^(-1) -kalz.ec <- solve(diag(n)-alpha*cov(covvar))%*%rep(1,n) -return(kalz.ec) +# turn characters into formula +regression.formula <- eval(parse(text = paste(returnsvar,regression.formula))) +# RETURN ~ BOOK2MARKET +regression.formula +wls.classic <- function(xdf, modelterms, conlist, w) { +assign("w", w, pos = 1) +model <- try(lm(formula = modelterms, data = xdf, contrasts = conlist, +weights = w, singular.ok = FALSE)) +if (is(model, "Error")) { +mess <- geterrmessage() +nn <- regexpr("computed fit is singular", mess) +if (nn > 0) { +cat("At time:", substring(mess, nn), "\n") +model <- lm(formula = modelterms, data = xdf, +contrasts = conlist, weights = w) } -# example of all 1 matrix -covvar <- matrix(rep(1,9),nrow=3) -kalz(covvar) -# example of all .1 matrix -covvar2 <- matrix(rep(.1,9),nrow=3) -kalz(covvar2) -kalz <- function(covvar) { -n <- length(covvar[1,]) -alpha <- eigen(covvar)$values[1] -10^(-2) -kalz.ec <- solve(diag(n)-alpha*cov(covvar))%*%rep(1,n) -return(kalz.ec) +else stop(mess) } -# example of all 1 matrix -covvar <- matrix(rep(1,9),nrow=3) -kalz(covvar) -# example of all .1 matrix -covvar2 <- matrix(rep(.1,9),nrow=3) -kalz(covvar2) -covvar3 <- eigen(matrix(c(1,0,0,0,1,0,0,0,1),nrow=3)) -covvar3 -covvar3 <- matrix(c(1,0,0,0,1,0,0,0,1),nrow=3) -covvar3 -kalz(covvar3) -covvar -covvar2 -covvar2 <- matrix(c(1,0.1,0.1,0.1,1,0.1,0.1,0.1,1),nrow=3) -kalz(covvar2) -covvar2 <- matrix(c(1,0.1,0.1,0.1,1,0.1,0.1,0.1,1),nrow=3) -kalz(covvar2) -covvar2 -diag(covvar2) <- c(0,0,0) -covvar2 -kalz(covvar2) -matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3) -covvar4 <- matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3) -kalz(covvar4) -covvar4 -kalz(matrix(c(1,1,-.1,1,1,-.1,-.1,-.1,1),nrow=3)) -matrix(c(1,1,-.1,1,1,-.1,-.1,-.1,1),nrow=3) -kalz(matrix(c(1,1,.1,1,1,.1,.1,.1,1),nrow=3)) -kalz <- function(covvar) { -n <- length(covvar[1,]) -alpha <- (eigen(covvar)$values[1])^(-1) -10^(-2) -kalz.ec <- solve(diag(n)-alpha*cov(covvar))%*%rep(1,n) -return(kalz.ec) } -covvar <- matrix(rep(1,9),nrow=3) -kalz(covvar) -covvar2 <- matrix(c(1,0.1,0.1,0.1,1,0.1,0.1,0.1,1),nrow=3) -kalz(covvar2) -covvar3 <- matrix(c(1,0,0,0,1,0,0,0,1),nrow=3) -kalz(covvar3) -covvar4 <- matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3) -kalz(covvar4) -kalz(matrix(c(1,1,-.1,1,1,-.1,-.1,-.1,1),nrow=3)) -kalz(matrix(c(1,1,.1,1,1,.1,.1,.1,1),nrow=3)) -covvar4 <- matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3) -kalz(covvar4) -covvar4 <- matrix(c(1,1,-.9,1,1,-.9,-.9,-.9,1),nrow=3) -kalz(covvar4) -kalz(matrix(c(1,1,-.1,1,1,-.1,-.1,-.1,1),nrow=3)) -kalz(matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3)) -kalz(matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3)) -kalz(matrix(c(1,1,-.1,1,1,-.1,-.1,-.1,1),nrow=3)) -kalz(matrix(c(1,1,.1,1,1,.1,.1,.1,1),nrow=3)) -matrix(c(1,1,.1,1,1,.1,.1,.1,1),nrow=3) -kalz(matrix(c(1,1,0,1,1,0,0,0,1),nrow=3) -kalz(matrix(c(1,1,0,1,1,0,0,0,1),nrow=3)) -########################################################### -kalz(matrix(c(1,1,0,1,1,0,0,0,1),nrow=3)) -matrix(c(1,1,0,1,1,0,0,0,1),nrow=3) -########################################################### -kalz(matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3)) -kalz(matrix(c(1,1,-.1,1,1,-.1,-.1,-.1,1),nrow=3)) -kalz(matrix(c(1,1,.5,1,1,.5,.5,.5,1),nrow=3)) -kalz(matrix(c(1,1,-.5,1,1,-.5,-.5,-.5,1),nrow=3)) -kalz(matrix(c(1,1,.9,1,1,.9,.9,.9,1),nrow=3)) -kalz(matrix(c(1,1,-.9,1,1,-.9,-.9,-.9,1),nrow=3)) -library(matrixcalc) -install.packages("matrixcalc") -is.positive.definite(matrix(c(1,1,-.1,1,1,-.1,-.1,-.1,1),nrow=3)) -is.positive.definite(matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3)) -library(matrixcalc) -is.positive.definite(matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3)) -is.positive.definite(matrix(c(1,1,-.1,1,1,-.1,-.1,-.1,1),nrow=3)) -is.positive.definite(matrix(c(1,1,.1,1,1,.1,.1,.1,1),nrow=3)) -is.positive.definite(matrix(c(1,1,0,1,1,0,0,0,1),nrow=3)) -is.positive.definite(matrix(c(1,1,0,1,1,0,0,0,1),nrow=3)) -is.positive.definite(diag(3)) -is.positive.definite(matrix(c(1,1,-1,1,1,-1,-1,-1,1),nrow=3)) -library(mvtnorm) -library(sna) -library(matrixcalc) -library(corpcor) -chol <- cbind(c(1,0.1,0.1,0.1,0.1),c(0,0.99,0.1,0.1,0.2),c(0,0,0.98,0.4,0.5), -c(0,0,0,0.9,0.5),c(0,0,0,0,0.7)) -covvar <- chol%*%t(chol) -covvar -is.positive.definite(covvar) -eigen(covvar) -eigen(solve(covvar)) -is.positive.definite(covvar) -gplot(covvar,gmode="graph",edge.lwd=15,label=c(1,2,3,4,5)) -eigen(covvar) -? gplot -install.packages(c("JGR","Deducer","DeducerExtras")) -library(JGR) -JGR() -install.packages("rJava") -JPR() -JGR() -library(JGR) -plot.lm -library(leaps) -library(PerformanceAnalytics) -library(lars) -library(robust) -library(ellipse) -library(MASS) -# -# fitMacroeconomicFactormodel -# -# load data from the database -setwd("C:/Users/Yi-An Chen/Documents/R-project/factoranalytics/pkg/factorAnalytics/data") -# data(managers.df) -load("managers.df.rda") -ret.assets = managers.df[,(1:6)] -factors = managers.df[,(7:9)] -# fit the factor model with OLS -setwd("C:/Users/Yi-An Chen/Documents/R-project/factoranalytics/pkg/factorAnalytics/R") -source("fitMacroeconomicFactorModel.r") -source("factorModelCovariance.r") -source("factorModelSdDecomposition.r") -source("factorModelEsDecomposition.r") -source("factorModelVaRDecomposition.r") -fit.macro <- fitMacroeconomicFactorModel(ret.assets,factors,fit.method="OLS", factor.set = 3, -variable.selection="all subsets",decay.factor = 0.95) -source("factorModelPerformanceAttribution.r") -fm.attr <- factorModelPerformanceAttribution(fit.macro) -fm.attr[[1]] -fm.attr[[2]] -fm.attr[[3]] -fit <- fitMacroeconomicFactorModel(ret.assets,factors,fit.method="OLS", factor.set = 3, -variable.selection="all subsets",decay.factor = 0.95) -fm.attr <- factorModelPerformanceAttribution(fit) -fit$ret.assets -factors -benchmark = managers.df[,8] -fit$ret.assets - benchmark -fit = fitMacroeconomicFactorModel(port.ret,fit$factors) -port.ret = fit$ret.assets - benchmark -fit = fitMacroeconomicFactorModel(port.ret,fit$factors) -fit$call -fit <- fitMacroeconomicFactorModel(ret.assets,factors,fit.method="OLS", factor.set = 3, -variable.selection="all subsets",decay.factor = 0.95) -fit$call -eval(fit$call) -fit$call -ret.assets = fit$ret.assets - benchmark -fit.1 = eval(fit$call) -eval(fit$call) -setwd("C:/Users/Yi-An Chen/Documents/R-project/factoranalytics/pkg/factorAnalytics/data") -# data(managers.df) -load("managers.df.rda") -ret.assets = managers.df[,(1:6)] -factors = managers.df[,(7:9)] -# fit the factor model with OLS -setwd("C:/Users/Yi-An Chen/Documents/R-project/factoranalytics/pkg/factorAnalytics/R") -source("fitMacroeconomicFactorModel.r") -source("factorModelCovariance.r") -source("factorModelSdDecomposition.r") -source("factorModelEsDecomposition.r") -source("factorModelVaRDecomposition.r") -fit <- fitMacroeconomicFactorModel(ret.assets,factors,fit.method="OLS", factor.set = 3, -variable.selection="all subsets",decay.factor = 0.95) -source("factorModelPerformanceAttribution.r") -fm.attr <- factorModelPerformanceAttribution(fit) -fm.attr[[1]] -source("factorModelPerformanceAttribution.r") -fm.attr <- factorModelPerformanceAttribution(fit) -source("factorModelPerformanceAttribution.r") -fm.attr <- factorModelPerformanceAttribution(fit) -source("factorModelPerformanceAttribution.r") -fm.attr <- factorModelPerformanceAttribution(fit) -benchmark=NULL -if(benchmark != NULL) +wls.classic <- function(xdf, modelterms, conlist, w) { +assign("w", w, pos = 1) +model <- try(lm(formula = modelterms, data = xdf, contrasts = conlist, +weights = w, singular.ok = FALSE)) +if (is(model, "Error")) { +mess <- geterrmessage() +nn <- regexpr("computed fit is singular", mess) +if (nn > 0) { +cat("At time:", substring(mess, nn), "\n") +model <- lm(formula = modelterms, data = xdf, +contrasts = conlist, weights = w) } -if(benchmark != NULL) { +else stop(mess) } -benchmark != NULL -benchmark[1] != NULL -class(benchmark) -as.logic(benchmark) -? logic -? as.numeric -as.logical(benchmark) -(as.logical(benchmark) != NULL) -source("factorModelPerformanceAttribution.r") -fm.attr <- factorModelPerformanceAttribution(fit) -source("factorModelPerformanceAttribution.r") -fm.attr <- factorModelPerformanceAttribution(fit) -fm.attr[[1]] -fm.attr[[2]] -fm.attr[[3]] -benchmark = managers.df[,8] -fm.attr.b <- factorModelPerformanceAttribution(fit,benchmark=benchmark) -fm.attr.b[[1]] -fm.attr[[1]] -fm.attr[[2]] -source("plot.FM.attribution.r") -plot(fm.attr,date="2006-12-30") -plot(fm.attr.b,date="2006-12-30") -source("summary.FM.attribution.r") -summary(fm.attr) -summary(fm.attr.b) +tstat <- rep(NA, length(model$coef)) +tstat[!is.na(model$coef)] <- summary(model, cor = FALSE)$coef[,3] +alphaord <- order(names(model$coef)) +c(length(model$coef), model$coef[alphaord], tstat[alphaord], +model$resid) +} +resids <- by(data = data, INDICES = as.numeric(data[[datevar]]), +FUN = function(xdf, modelterms, conlist) { +lm(formula = modelterms, data = xdf, contrasts = conlist, +singular.ok = TRUE)$resid +}, +modelterms = regression.formula, conlist = contrasts.list) +resids <- apply(resids, 1, unlist) +weights <- if (covariance == "robust") +apply(resids, 1, scaleTau2)^2 +else apply(resids, 1, var) +FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]), +FUN = wls.classic, modelterms = regression.formula, +conlist = contrasts.list, w = weights) +covariance = "classic" +wls = TRUE +regression = "classic" +if (!wls) { +if (regression == "robust") { +# ols.robust +FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]), +FUN = ols.robust, modelterms = regression.formula, +conlist = contrasts.list) +} else { +# ols.classic +FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]), +FUN = ols.classic, modelterms = regression.formula, +conlist = contrasts.list) +} +} else { +if (regression == "robust") { +# wls.robust +resids <- by(data = data, INDICES = as.numeric(data[[datevar]]), +FUN = function(xdf, modelterms, conlist) { +lmRob(modelterms, data = xdf, contrasts = conlist, +control = lmRob.control(mxr = 200, mxf = 200, +mxs = 200))$resid +}, modelterms = regression.formula, conlist = contrasts.list) +resids <- apply(resids, 1, unlist) +weights <- if (covariance == "robust") +apply(resids, 1, scaleTau2)^2 +else apply(resids, 1, var) +FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]), +FUN = wls.robust, modelterms = regression.formula, +conlist = contrasts.list, w = weights) +} +else { +# wls.classic +resids <- by(data = data, INDICES = as.numeric(data[[datevar]]), +FUN = function(xdf, modelterms, conlist) { +lm(formula = modelterms, data = xdf, contrasts = conlist, +singular.ok = TRUE)$resid +}, +modelterms = regression.formula, conlist = contrasts.list) +resids <- apply(resids, 1, unlist) +weights <- if (covariance == "robust") +apply(resids, 1, scaleTau2)^2 +else apply(resids, 1, var) +FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]), +FUN = wls.classic, modelterms = regression.formula, +conlist = contrasts.list, w = weights) +} +} +FE.hat +FE.hat[1] +FE.hat[[1]] +(length(exposures.factor)) +exposures.factor +length(levels(data[,exposures.factor])) +(length(exposures.factor)>0) +if (length(exposures.factor)>0) { +numCoefs <- length(exposures.numeric) + length(levels(data[,exposures.factor])) +ncols <- 1 + 2 * numCoefs + numAssets +fnames <- c(exposures.numeric, paste(exposures.factor, +levels(data[, exposures.factor]), sep = "")) +cnames <- c("numCoefs", fnames, paste("t", fnames, sep = "."), +assets) +} else { +numCoefs <- 1 + length(exposures.numeric) +ncols <- 1 + 2 * numCoefs + numAssets +cnames <- c("numCoefs", "(Intercept)", exposures.numeric, +paste("t", c("(Intercept)", exposures.numeric), sep = "."), +assets) +} +FE.hat.mat <- matrix(NA, ncol = ncols, nrow = numTimePoints, +dimnames = list(as.character(timedates), cnames)) +for (i in 1:length(FE.hat)) { +names(FE.hat[[i]])[1] <- "numCoefs" +nc <- FE.hat[[i]][1] +names(FE.hat[[i]])[(2 + nc):(1 + 2 * nc)] <- paste("t", +names(FE.hat[[i]])[2:(1 + nc)], sep = ".") +if (length(FE.hat[[i]]) != (1 + 2 * nc + numAssets)) +stop(paste("bad count in row", i, "of FE.hat")) +names(FE.hat[[i]])[(2 + 2 * nc):(1 + 2 * nc + numAssets)] <- assets +idx <- match(names(FE.hat[[i]]), colnames(FE.hat.mat)) +FE.hat.mat[i, idx] <- FE.hat[[i]] +} +coefs.names <- colnames(FE.hat.mat)[2:(1 + numCoefs)] +# estimated factors returns ordered by time +f.hat <- xts(x = FE.hat.mat[, 2:(1 + numCoefs)], order.by = timedates) +# check for outlier +gomat <- apply(coredata(f.hat), 2, function(x) abs(x - median(x, +na.rm = TRUE)) > 4 * mad(x, na.rm = TRUE)) +if (any(gomat, na.rm = TRUE) ) { +cat("\n\n*** Possible outliers found in the factor returns:\n\n") +for (i in which(apply(gomat, 1, any, na.rm = TRUE))) print(f.hat[i, +gomat[i, ], drop = FALSE]) +} +tstats <- xts(x = FE.hat.mat[, (2 + nc):(1 + 2 * nc)], order.by = timedates) +# residuals for every asset ordered by time +resids <- xts(x = FE.hat.mat[, (2 + 2 * numCoefs):(1 + 2 * +numCoefs + numAssets)], order.by = timedates) +Cov.factors <- covClassic(coredata(f.hat), distance = FALSE,na.action = na.omit) +resid.vars <- apply(coredata(resids), 2, var, na.rm = TRUE) +D.hat <- if (full.resid.cov) { +covClassic(coredata(resids), distance = FALSE, na.action = na.omit) +} else { diag(resid.vars) } +B.final <- matrix(0, nrow = numAssets, ncol = numCoefs) +colnames <- coefs.names +B.final +B.final[, match("(Intercept)", colnames, 0)] +B.final[, match("(Intercept)", colnames, 0)] <- 1 +B.final +numeric.columns <- match(exposures.numeric, colnames, 0) +# only take the latest beta to compute FM covariance +B.final[, numeric.columns] <- as.matrix(data[ (data[[datevar]] == timedates[numTimePoints]), exposures.numeric]) +rownames(B.final) = assets +colnames(B.final) = colnames(f.hat) +B.final +(length(exposures.factor)) +if (length(exposures.factor)>0) { +B.final[, grep(exposures.factor, x = colnames)][cbind(seq(numAssets), +(data[ data[[datevar]] == timedates[numTimePoints], +exposures.factor]))] <- 1 +} +B.final +cov.returns <- B.final %*% Cov.factors$cov %*% t(B.final) + +if (full.resid.cov) { D.hat$cov +} else { D.hat } +mean.cov.returns = tapply(data[[returnsvar]],data[[assetvar]], mean) +Cov.returns <- list(cov = cov.returns, mean=mean.cov.returns, eigenvalues = eigen(cov.returns, +only.values = TRUE, symmetric = TRUE)$values) +# report residual covaraince if full.resid.cov is true. +if (full.resid.cov) { +Cov.resids <- D.hat +} +else { +Cov.resids <- diag(resid.vars) +} +f.hat +head(barra$factor.returns) +barra <- fitFundamentalFactorModel(data=stacked.returns,exposure.names="SECTOR", +datevar="DATE",returnsvar="RETURN", +assetvar="TICKER",wls=TRUE,full.resid.cov=FALSE) +head(barra$factor.returns) +head(f.hat) +(!(length(exposures.factor)>0)) +setwd("C:/Users/Yi-An Chen/Documents/R-project/returnanalytics/pkg/FactorAnalytics/R") +source(fitFundamentalFactorModel) +source("fitFundamentalFactorModel.r") +barra <- fitFundamentalFactorModel(data=stacked.returns,exposure.names="SECTOR", +datevar="DATE",returnsvar="RETURN", +assetvar="TICKER",wls=TRUE,full.resid.cov=FALSE) +names(barra) +head(barra$factor.returns) +barra$beta +data(berndtInvest) +ts.berndt<-xts(berndtInvest[,-1],as.Date(berndtInvest[,1])) +berndt<-ts.berndt['1978/1987'] +returns<-berndt[,c(-10,-17)] +tickers <- names(returns) +num.tickers <- length(tickers) +dates <- index(returns) +num.dates <- length(dates) +sector<-c("OTHER","OTHER","OIL","TECH","TECH","OIL","OTHER","OTHER", +"TECH","OIL","OIL","OTHER","TECH","OIL","OTHER") +stacked.returns <- data.frame( +DATE=rep(dates,num.tickers), +TICKER=rep(tickers,each=num.dates), +RETURN=c(coredata(returns)), +SECTOR=rep(sector,each=num.dates), +stringsAsFactors=FALSE) +head(stacked.returns) +setwd("C:/Users/Yi-An Chen/Documents/R-project/returnanalytics/pkg/FactorAnalytics/R") +barra <- fitFundamentalFactorModel(data=stacked.returns,exposure.names="SECTOR", +datevar="DATE",returnsvar="RETURN", +assetvar="TICKER",wls=TRUE,full.resid.cov=FALSE) +names(barra) +head(barra$factor.returns) +setwd("C:/Users/Yi-An Chen/Documents/R-project/returnanalytics/pkg/FactorAnalytics/R") +source("fitFundamentalFactorModel.r") +barra <- fitFundamentalFactorModel(data=stacked.returns,exposure.names="SECTOR", +datevar="DATE",returnsvar="RETURN", +assetvar="TICKER",wls=TRUE,full.resid.cov=FALSE) +names(barra) +head(barra$factor.returns) +barra$beta +barra.cov <- factorModelCovariance(barra$beta, barra$factor.cov$cov, barra$resid.variance) +barra.cor <- cov2cor(barra.cov) +round(barra.cor,2) +returns = berndtInvest[,-c(1,11,18)] +n.stocks = ncol(returns) +tech.dum = oil.dum = other.dum = matrix(0,n.stocks,1) +tech.dum[c(4,5,9,13),] = 1 +oil.dum[c(3,6,10,11,14),] = 1 +other.dum = 1 - tech.dum - oil.dum +B = cbind(tech.dum,oil.dum,other.dum) +dimnames(B) = list(colnames(returns),c("TECH","OIL","OTHER")) +B +returns = t(returns) +barra_ols = lm(returns ~ -1 + B) +sbarra_ols = summary(barra_ols) +e.hat = resid(barra_ols) +e.var = apply(e.hat,1,var) +e.var.inv = e.var^-1 +barra_fgls = lm(returns ~ -1 + B, weights = e.var.inv) +sbarra_fgls = summary(barra_fgls) +f.hat = coef(barra_fgls) +f.hat +e.hat_fgls = resid(barra_fgls) +e.var_fgls = apply(e.hat_fgls,1,var) +cov.ind.lm = B %*% var(t(f.hat)) %*% t(B) + diag(e.var_fgls) +all.equal(cov.ind,cov.ind.lm) +cor.ind.lm <- cov2cor(cov.ind.lm) +round(cor.ind.lm,2) +cov.ind.lm = B %*% var(t(f.hat)) %*% t(B) + diag(e.var_fgls) +all.equal(cov.ind,cov.ind.lm) +F.hat = solve(crossprod(B))%*%t(B)%*%returns +# compute N x T matrix of industry factor model residuals +E.hat = returns - B%*%F.hat +# compute residual variances from time series of errors +diagD.hat = apply(E.hat,1,var) +Dinv.hat = diag(diagD.hat^(-1)) +# multivariate FGLS regression to estimate K x T matrix of factor returns +H = solve(t(B)%*%Dinv.hat%*%B)%*%t(B)%*%Dinv.hat +round(H[,1:8],5) +# note: rows of H sum to one +apply(H,1,sum) +# create factor mimicking portfolios +F.hat = H%*%returns +E.hat = returns - B%*%F.hat +diagD.hat = apply(E.hat,1,var) +F.hat = t(F.hat) +all.equal(cov.ind,cov.ind.lm) +cov.ind = B%*%var(F.hat)%*%t(B) + diag(diagD.hat) +sd = sqrt(diag(cov.ind)) +cor.ind = cov.ind/outer(sd,sd) +cor.samp <- cor(t(returns)) +all.equal(cov.ind,cov.ind.lm) +cor.ind.lm <- cov2cor(cov.ind.lm) +round(cor.ind.lm,2) +barra_ols = lm(returns ~ -1 + B) +sbarra_ols = summary(barra_ols) +e.hat = resid(barra_ols) +e.var = apply(e.hat,1,var) +# e.var.inv = e.var^-1 +e.var.inv = e.var +barra_fgls = lm(returns ~ -1 + B, weights = e.var.inv) +sbarra_fgls = summary(barra_fgls) +f.hat = coef(barra_fgls) +e.hat_fgls = resid(barra_fgls) +e.var_fgls = apply(e.hat_fgls,1,var) +cov.ind.lm = B %*% var(t(f.hat)) %*% t(B) + diag(e.var_fgls) +all.equal(cov.ind,cov.ind.lm) +barra.cov <- factorModelCovariance(barra$beta, barra$factor.cov$cov, barra$resid.variance) +all.equal(cov.ind.lm,barra.cov) +? lm +setwd("C:/Users/Yi-An Chen/Documents/R-project/returnanalytics/pkg/FactorAnalytics/R") +source("fitFundamentalFactorModel.r") +barra <- fitFundamentalFactorModel(data=stacked.returns,exposure.names="SECTOR", +datevar="DATE",returnsvar="RETURN", +assetvar="TICKER",wls=TRUE,full.resid.cov=FALSE) +head(barra$factor.returns) +barra.cov <- factorModelCovariance(barra$beta, barra$factor.cov$cov, barra$resid.variance) +barra.cor <- cov2cor(barra.cov) +round(barra.cor,2) +barra_ols = lm(returns ~ -1 + B) +sbarra_ols = summary(barra_ols) +e.hat = resid(barra_ols) +e.var = apply(e.hat,1,var) +e.var.inv = e.var^-1 +barra_fgls = lm(returns ~ -1 + B, weights = e.var.inv) +sbarra_fgls = summary(barra_fgls) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3295