pair_risk_contribution report is out of date

[nassuphis]

remove tsne plots, they dont add any value

add lasso regression to identify exposures
add look-through to identify exposures

[nassuphis]

removed this funciton, no more tSNE in the report unless people want to see it

plot_tsne_grid<-function(fn,tsne,pictures){
  s<-(floor(sqrt(length(pictures)))+1)^2
  k<-sqrt(s)
  m<-diag(k)
  gx<-as.vector(col(m))
  gy<-as.vector(row(m))
  tx<-rescale(tsne$Y[,1],range(gx))
  ty<-rescale(tsne$Y[,2],range(gy))
  tsnex<-matrix(tx,ncol=1)[,rep(1,length(gx))]
  tsney<-matrix(ty,ncol=1)[,rep(1,length(gy))]
  gridx<-matrix(gx,nrow=1)[rep(1,length(tx)),]
  gridy<-matrix(gy,nrow=1)[rep(1,length(ty)),]
  dx<-(tsnex-gridx)^2
  dy<-(tsney-gridy)^2
  d<-dx+dy
  t2g <- solve_LSAP(d)
  par(mai=c(0,0,0,0))
  plot(gx,gy,col="white",axes=FALSE,xlab="",ylab="",main="")
  for(i in seq_along(pictures))rasterImage(
    image=pictures[[i]][[fn]],
    xleft=gx[t2g[i]]-0.49,
    ybottom=gy[t2g[i]]-0.49,
    xright=gx[t2g[i]]+0.49,
    ytop=gy[t2g[i]]+0.49,
    interpolate=TRUE
  )
  abline(
    h=setdiff(unique(gx),range(gx)[1])-0.5,
    v=setdiff(unique(gy),range(gy)[1])-0.5,
    col=rgb(0.5,0.5,0.5,0.5)
  )
}

[nassuphis]

pair_risk_contribution plots:

1. DUKE managers
2. DUKE manager risk
3. DUKE manager risk contributions
4. DUKE manager correlations
5. DUKE manager factor exposures
6. DUKE pairs gros s vs gross rank
7. DUKE pair position as multiple of ADV
8. pair risk stdev vs pair rank
9. pair risk vs pair gross
10. marginal pair sdev vs pair
    11 histogram of daily pair correlation

[nassuphis]

actual size vs size required for 4% volatility is a metric we care about.
marginal risk contribution can be computed using FRAPO
volatility trajectories can be computed by manager and by pair.

[nassuphis]

the "Manager Factor Exposures" section needs to stay, but the contents is not good.

the "split plots" are pretty useless:

split_plot<-function(
  x,
  f,
  factor_state_fun=sign,
  state_col=rainbow(length(all_states),alpha=0.5),
  cex=2
){
  
  all_states<-sort(unique(factor_state_fun(f)))
  #state_col<-rainbow(length(all_states),alpha=0.5)
  states<-match(factor_state_fun(f),all_states)
  the_split<-data.table(
    state=states,
    value=x,
    factor=f,
    x=do.call(c,split(seq_along(states),states)),
    y=do.call(c,mapply(cumsum,split(x,states),SIMPLIFY=FALSE)),
    col=do.call(c,split(state_col[states],states))
  )
  par(mai=c(0.1,0.1,0.1,0.1))
  plot(
    x=the_split$x,
    y=the_split$y,
    col=the_split$col,
    pch=19,
    cex=cex,
    axes=FALSE,
    xlab="",
    ylab=""
  )
  par(mai=c(1.02,0.82,0.82,0.42))
  the_split
}


pms<-colnames(manager_local_pnl)
fs<-c(
  "SMX Index","UKX Index","MCX Index",
  "SXXP Index",
  "MSEEMOMO Index","MSEEGRW Index","MSEEVAL Index",
  "USO US Equity","EEM US Equity","TLT US Equity",
  "COINXBE SS Equity"
)
pic_w<-paste0(round(18/(length(pms)+1),digits=1),"cm")
pic_h<-paste0(round(21/length(fs),digits=1),"cm")
log_code(split_pics<-data.table(
    factors=sub("( Index$)|( Equity$)","",fs),
    t(structure(outer(pms,fs,FUN=Vectorize(function(pm,fac){
      res<-make_plot(
        x0<-split_plot(
          manager_local_pnl[,pm],
          factor_local_tret[,fac],
          state_col=c(rgb(1,0,0,0.5),rgb(0.2,0.2,0.2,0.5),rgb(0,1,0,0.5))
        ),
        width=pic_w,
        height=pic_h
      )
      res
    })),dimnames=list(pms,gsub(" Index$","",fs))))
))
split_align=paste0("m{",pic_w,"}")

[nassuphis]

we should have tables and basis points

[nassuphis]

the key theme of the report should be pair diversification, which can be shown using the vol trajectories and factor exposures

[nassuphis]

vol trajectory code, should be a function, its useful

# vol trajectories are computed by taking costituents largest vol first
tri<-function(n,d=1,s=1)(s*row(diag(n))<s*col(diag(n)))+d*diag(n)
log_code(vols<-weights*(cbind(apply(x,2,sd))[,rep(1,ncol(weights))]))
log_code(vol_ord<-structure(apply(-vols,2,.%>%rank(ties="f")),dimnames=dimnames(vols)))
log_code(res<-mapply(function(ptf){
  a1<-(weights[,rep(ptf,nrow(weights))]*diag(nrow(vols))[vol_ord[,ptf],]%*%tri(nrow(vols)))
  a2<-total_gross*a1%*%diag(1/colSums(a1))
  apply(x%*%a2,2,sd)
},ptf=colnames(vol_ord))%>%
{ rownames(.)<-paste0("vol_rank_",1:nrow(.)); . })

[nassuphis]

volatility_trajectory<-function(
  returns,
  ptf
){
  vol=ptf*apply(returns[,names(ptf)],2,sd)
  vol_rank=rank(vol,ties.method="first")
  weight_matrix <- cbind(ptf=ptf)[,rep(1,length(ptf))]
  mask_matrix <- diag(length(vol))[vol_rank,] %*% tri(length(vol))
  trajectory_matrix <- weight_matrix * mask_matrix
  normalized_trajectory_matrix <- trajectory_matrix %*% diag(sum(ptf)/colSums(trajectory_matrix))
  apply(returns%*%normalized_trajectory_matrix,2,sd)
}

[nassuphis]

the current report
pair_risk_contribution.pdf