Update xts::indexClass to xts::tclass

R/bt.r

@@ -43,7 +43,7 @@ bt.merge <- function
 	# put all dates into one large vector
 	itemp = 1
 	for( i in 1:nsymbols ) {
-		all.dates[itemp : (itemp + ncount[i] -1)] = attr(b[[ symbolnames[i] ]], 'index')
+		all.dates[itemp : (itemp + ncount[i] -1)] = xts::.index(b[[ symbolnames[i] ]])
 		itemp = itemp + ncount[i]
 	}
 
@@ -55,7 +55,7 @@ bt.merge <- function
 	if(!is.null(dates)) { 
 		class(unique.dates) = c('POSIXct', 'POSIXt')	
 		temp = make.xts(integer(len(unique.dates)), unique.dates) 		
-		unique.dates = attr(temp[dates], 'index')
+		unique.dates = xts::.index(temp[dates])
 	}
 
 	# date map
@@ -990,8 +990,8 @@ bt.trade.summary <- function
 		out = list()
 		out$stats = cbind(
 			bt.trade.summary.helper(trades),
-			bt.trade.summary.helper(trades[trades[, 'weight'] >= 0, ]),
-			bt.trade.summary.helper(trades[trades[, 'weight'] <0, ])
+			bt.trade.summary.helper(trades[trades[, 'weight'] >= 0, , drop=F]),
+			bt.trade.summary.helper(trades[trades[, 'weight'] <0, , drop=F])
 		)
 		colnames(out$stats) = spl('All,Long,Short')
 

R/bt.test.r

@@ -5500,7 +5500,7 @@ bt.aaa.test <- function()
 	getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T)
 
 
-	# contruct another back-test environment with split-adjusted prices, do not include dividends
+	# contruct another back-test enviroment with split-adjusted prices, do not include dividends
 	# http://www.fintools.com/wp-content/uploads/2012/02/DividendAdjustedStockPrices.pdf
 	# http://www.pstat.ucsb.edu/research/papers/momentum.pdf
 	data.price <- new.env()
@@ -7894,7 +7894,11 @@ bt.cluster.portfolio.allocation.test1 <- function()
 						RP=risk.parity.portfolio(),
 
 						C.EW = distribute.weights(equal.weight.portfolio, cluster.group),
-						C.RP=distribute.weights(risk.parity.portfolio(), cluster.group)
+						C.RP=distribute.weights(risk.parity.portfolio(), cluster.group),
+
+						IVP = inverse.variance.portfolio,
+						C.IVP=distribute.weights(inverse.variance.portfolio, cluster.group, inverse.variance.portfolio),
+						HRP = hierarchical.risk.parity						
 			)
 	) 		
 

R/data.r

@@ -501,7 +501,7 @@ get.CRB <- function(...)
       out[, 'Volume'] = 0
   #out = make.xts( out, as.Date(temp[,1], '%m/%d/%y'))
   out = make.xts( out, as.POSIXct(temp[,1], tz = Sys.getenv('TZ'), format='%m/%d/%y'))  
-    indexClass(out) = 'Date'  
+    xts::tclass(out) = 'Date'  
 
   return(out)
 }   
@@ -1276,7 +1276,7 @@ bundes.bank.data <- function(symbol) {
 
   #hist = make.xts(as.double(temp[,2]), as.Date(temp[,1], '%Y-%m-%d'))    
   hist = make.xts(as.double(temp[,2]), as.POSIXct(temp[,1], tz = Sys.getenv('TZ'), format='%Y-%m-%d'))
-    indexClass(hist) = 'Date'     
+    xts::tclass(hist) = 'Date'     
     colnames(hist)='Close'
   return( hist[!is.na(hist)] )
 }
@@ -1308,7 +1308,7 @@ fx.sauder.data <- function(start.year, end.year, base.cur, target.curs) {
 
   #hist = make.xts(as.matrix(temp[,-c(1:3)]), as.Date(temp[,2], '%Y/%m/%d'))    
   hist = make.xts(as.matrix(temp[,-c(1:3)]), as.POSIXct(temp[,2], tz = Sys.getenv('TZ'), format='%Y/%m/%d'))
-    indexClass(hist) = 'Date'
+    xts::tclass(hist) = 'Date'
     colnames(hist) = gsub(paste('.', base.cur, sep=''), '', colnames(hist))
 
   return( hist[!is.na(hist[,1]),] )
@@ -1349,7 +1349,7 @@ getSymbols.PI <- function
     temp = read.delim(filename, header=TRUE, sep=',')   
     #out = make.xts(temp[,-1], as.Date(temp[,1],'%m/%d/%Y'))
     out = make.xts(temp[,-1], as.POSIXct(temp[,1], tz = Sys.getenv('TZ'), format='%m/%d/%Y'))
-      indexClass(out) = 'Date'
+      xts::tclass(out) = 'Date'
       out$Adjusted = out$Close
 
 cat(i, 'out of', len(Symbols), 'Reading', Symbols[i], '\n', sep='\t')         
@@ -1858,7 +1858,7 @@ data.ff <- function(
   # url
   period = ifna(map[periodicity[1]], periodicity[1])
   filename.zip = paste(name[1], period, file.suffix, '.zip', sep='')
-  filename.txt = paste(name[1], period, '.txt', sep='')
+  filename.txt = paste(name[1], period, gsub('_','.',file.suffix), sep='')  
   url = paste('http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/ftp/', filename.zip, sep='')
 
   # download zip archive
@@ -1884,19 +1884,67 @@ data.ff <- function(
 
   if(len(files) == 1) {
   	filename = paste(temp.folder, '/', filename.txt, sep='')
-  	return( data.ff.internal.one.file(filename) )
+	if(file.suffix != '_CSV')	
+  	  return( data.ff.internal.one.file(filename) )
+	else
+  	  return( data.ff.internal.one.file.csv(filename) )	
   }
 
   data = env()
   library(stringr)
   names = str_trim(str_match(files,'.*/(.*)\\..*')[,2])
   for(i in 1:len(files))
-  	data[[ names[i] ]] = data.ff.internal.one.file(files[i])
+  	if(file.suffix != '_CSV')  
+  	  data[[ names[i] ]] = data.ff.internal.one.file(files[i])
+	else
+  	  data[[ names[i] ]] = data.ff.internal.one.file.csv(files[i])
 
   data  
 }  
 
 
+data.ff.internal.one.file.csv = function(filename) {  
+  out = readLines(filename)
+    index = which(nchar(out) == 0)
+
+  data.index = grep('^[ 0-9\\.\\+-\\,]+$', out)
+    temp.index = which(diff(data.index) > 1)
+  data.index = matrix(data.index[sort(c(1, temp.index, temp.index+1, len(data.index)))], nc=2, byrow=T)
+
+  # extract sections  
+  data = list() 
+  for(i in 1:nrow(data.index)) {
+    start.index = data.index[i,1] - 2
+	name = trim(out[start.index])
+	if(nchar(name) == 0) name = 'data'
+    colnames = scan(text = out[start.index+1], what='', sep=',', quiet=T)	
+
+    # re-read data  
+    temp =  matrix(scan(filename, what = double(), sep=',', quiet=T,
+      skip = (data.index[i,1]-1),  
+      nlines = (data.index[i,2] - data.index[i,1]+1))
+      , nc=len(colnames), byrow=T)
+
+    date.format = '%Y%m%d'  
+    date.format.add = ''
+    date.format.n = nchar(paste(temp[1,1]))
+
+    if( date.format.n == 6 ) {
+      date.format.add = '01'    
+    } else if( date.format.n == 4 ) {
+      date.format.add = '0101'  
+    } 
+
+    find.name = function(name,data, i=0) if( is.null(data[[name]]) ) name else find.name(paste(name,i+1), data, i+1)    
+    name = find.name(name, data)
+
+    data[[name]] = make.xts(temp[,-1], as.Date(paste(temp[,1], date.format.add, sep=''),date.format))
+      colnames(data[[name]]) = colnames[-1]
+  }
+  data
+}
+
+
 # internal helper function
 data.ff.internal.one.file = function(filename) {  
   out = readLines(filename)

R/plota.r

@@ -212,7 +212,7 @@ plota <- function
 	}
 
 	# create plot frame, do not plot data
-	temp.x = attr(y, 'index')	
+	temp.x = xts::.index(y)
 	plot( temp.x, y1, xlab = xlab, ylab = ylab, main = main,
 		type = 'n', yaxt = 'n', xaxt = 'n', ylim = ylim, log = log, ... )
 
@@ -294,7 +294,7 @@ plota2Y <- function(
 	# plot
 	par(new = TRUE)
 	xlim = par('usr')[1:2]
-	plot( attr(y1, 'index') , y1[,1], xlim = xlim, xaxs = 'i', type = type,
+	plot( xts::.index(y1) , y1[,1], xlim = xlim, xaxs = 'i', type = type,
 		yaxt = 'n', xaxt = 'n', xlab = '', ylab = '', axes = F, ... )
 
 		# Y axis rotation
@@ -337,7 +337,7 @@ plota.lines <- function(
 {
 	if(has.Cl(y)) y1 = Cl(y) else y1 = y[,1]	
 
-	temp.x = attr(y, 'index')
+	temp.x = xts::.index(y)
 
 	if( type == 'l' & len(col) > 1 ) {
 		for( icol in unique(col) ) {
@@ -494,7 +494,7 @@ plota.dx <- function
 
 	# R by default extends xrange by 1.08
 	xlim = par('usr')[1:2]
-	xportion = min(1, diff(unclass(range(attr(y1, 'index'))))*1.08 / diff(xlim) )
+	xportion = min(1, diff(unclass(range(xts::.index(y1))))*1.08 / diff(xlim) )
 	return( xportion * diff(xlim) / ( 2* nrow(y1)  ) )
 }
 
@@ -549,7 +549,7 @@ plota.x.highlight.helper <- function
 	if(par('ylog')) temp.y = 10^temp.y
 
 
-	temp.x = attr(y, 'index')		
+	temp.x = xts::.index(y)		
 	for( i in seq(1,len(hl_index),2) ) {		
 		rect(temp.x[hl_index[i]] - dx/2, temp.y[1],
 			temp.x[hl_index[(i + 1)]] + dx/2, temp.y[2],
@@ -648,7 +648,7 @@ plota.candle <- function
 	} else if ( dxi0 < 1.75 ) {
 		plota.ohlc.lwd(y, col = col, lwd = 1)
 	} else {
-		temp.x = attr(y, 'index')
+		temp.x = xts::.index(y)
 
 		rect(temp.x - dx/10, Lo(y), temp.x + dx/10, Hi(y), 
 			col = plota.control$col.border, border = plota.control$col.border)
@@ -677,7 +677,7 @@ plota.ohlc <- function
 	} else if ( dxi0 < 1.75 ) {
 		plota.ohlc.lwd(y, col = col, lwd = 1)
 	} else {
-		temp.x = attr(y, 'index')
+		temp.x = xts::.index(y)
 
 		rect(temp.x - dx/8, Lo(y), temp.x + dx/8, Hi(y), col = col, border = col)
 		segments(temp.x - dx/2, Op(y), temp.x, Op(y), col = col)	
@@ -702,7 +702,7 @@ plota.hl <- function
 	if( dxi0 < 1.75 ) {
 		plota.hl.lwd(y, col = col, lwd = 1)
 	} else {
-		temp.x = attr(y, 'index')
+		temp.x = xts::.index(y)
 
 		rect(temp.x - dx/2, Lo(y), temp.x + dx/2, Hi(y), 
 			col = col, border = border)
@@ -720,7 +720,7 @@ plota.ohlc.lwd <- function
 )
 {
 	dx = plota.dx(y)
-	temp.x = attr(y, 'index')	
+	temp.x = xts::.index(y)	
 
 	segments(temp.x, Lo(y), temp.x, Hi(y), lwd = lwd, lend = 2,  ...)
 	segments(temp.x - dx/2, Op(y), temp.x, Op(y), lwd = lwd, lend = 2, ...)
@@ -737,7 +737,7 @@ plota.hl.lwd <- function
 	...					# other parameters to segments
 )
 {
-	temp.x = attr(y, 'index')	
+	temp.x = xts::.index(y)	
 
 	segments(temp.x, Lo(y), temp.x, Hi(y), lwd = lwd, lend = 2, ...)
 }
@@ -757,7 +757,7 @@ plota.volume <- function
 	# convert dx to line width
 	dxi0 = ( dx / xinch() ) * 96
 
-	temp.x = attr(y, 'index')	
+	temp.x = xts::.index(y)	
 
 	if( dxi0 < 1.75 ) {
 		segments(temp.x, 0, temp.x, Vo(y), col = col, lwd = 1, lend = 2)	

R/strategy.r

@@ -901,6 +901,82 @@ ef.portfolio <- function(percent = 0.5)
 }	
 
 
+
+
+# The inverse-variance portfolio
+#' @export 
+inverse.variance.portfolio = function(ia, constraints) {
+	risk.index = get.risky.asset.index(ia)
+
+	x = 1 / diag(ia$cov[risk.index, risk.index])
+	w = x / sum(x)
+
+	set.risky.asset(w, risk.index)	
+}
+
+# Hierarchical Risk Parity  by Dr. Marcos López de Prado
+# https://papers.ssrn.com/sol3/papers.cfm?abstract_id=2708678
+# https://quantdare.com/hierarchical-risk-parity/
+# http://gallery.rcpp.org/articles/hierarchical-risk-parity/
+# https://quantstrattrader.wordpress.com/2017/05/22/the-marcos-lopez-de-prado-hierarchical-risk-parity-algorithm/
+
+# Compute variance per cluster
+get.cluster.var = function(mcov, index) {
+	get.ivp = function(mcov) {  
+	  ivp = 1 / diag(mcov)
+	  ivp / sum(ivp)
+	}
+
+	mcov.slice = mcov[index, index, drop=F]
+	w = get.ivp(mcov.slice)
+	cVar  = t(w) %*% as.matrix(mcov.slice) %*% w
+	cVar[1]
+}
+
+# Compute HRP alloc
+get.rec.bipart = function(mcov, index) {
+    w = rep(1, ncol(mcov))
+    index = list(index) # initialize all items in one cluster
+    while(length(index) > 0) {
+        new.index = list()
+        for(i in index) {
+            mid.index = 1:floor(length(i)/2)
+            index0 = i[mid.index]
+            index1 = i[-mid.index]
+            cVar0 = get.cluster.var(mcov, index0)
+            cVar1 = get.cluster.var(mcov, index1)
+            alpha = 1 - cVar0/(cVar0 + cVar1)
+            w[index0] = w[index0] * alpha
+            w[index1] = w[index1] * (1-alpha)
+            if(length(index0) > 1) new.index = c(new.index, list(index0))
+            if(length(index1) > 1) new.index = c(new.index, list(index1))
+			index = new.index
+        }
+    }
+    w
+}
+
+# Hierarchical Risk Parity  by Dr. Marcos López de Prado
+# https://papers.ssrn.com/sol3/papers.cfm?abstract_id=27
+#' @export 
+hierarchical.risk.parity = function(ia, constraints) {
+	risk.index = get.risky.asset.index(ia)
+
+	clust.order = hclust(dist(ia$correlation[risk.index, risk.index]), method = 'single')$order
+
+	# Optionally use short-term risk (20 day) and oroignal correlation
+	#risk = apply(mlast(ia$hist.returns,20) , 2, sd, na.rm = T)
+	#mcov = ia$correlation * (risk %*% t(risk))	
+
+	mcov = ia$cov
+
+	w = get.rec.bipart(mcov[risk.index, risk.index], clust.order)
+
+	set.risky.asset(w, risk.index)	
+}	
+
+
+
 #*****************************************************************	
 # Tracking Error minimization:
 # http://www.mathworks.com/matlabcentral/answers/59587-how-to-use-the-objective-function-minimize-te-in-quadprog