#===========================================================
# R CODE FOR 
#    FUNCTIONS USED FOR SIMULATION STUDY AND EXAMPLE IN
#   "COPULA-BASED MEASURES OF ASYMMETRY BETWEEN
#    THE LOWER AND UPPER TAIL PROBABILITIES"
#     
#    BY SHOGO KATO, TOSHINAO YOSHIBA AND SHINTO EGUCHI  
#===========================================================

library(copula)
library(boot)
library(xts)
library(rugarch)

# Calculation of alpha^hat(u): alpha_hat
#
# INPUT:
# dat: copula sample -- (n,2) matrix
# ulevel: value of the tuning parameter u
# 
# OUTPUT:
# value of alpha^hat(u)
#

alpha_hat=function(dat,ulevel){
  lowerTail= dat<=ulevel
  T_L=sum(apply(lowerTail,1,prod))
  upperTail= dat>=1-ulevel
  T_U=sum(apply(upperTail,1,prod))
  if((T_U==0)&&(T_L==0)) value=0 else{value=log(T_U/T_L)}
  return(value)
}


# Asymptotic confidence intervals of alpha^hat(u): alpha_hat_ci
#
# INPUT:
# dat: copula sample -- (n,2) matrix
# ulevel: value of the tuning parameter u
# p: parameter to construct 100*(1-p)% confidence intervals
# 
# OUTPUT:
# lbound: lower bound of the 100*(1-p)% asymptotic confidence intervals
# ubound: upper bound of the 100*(1-p)% asymptotic confidence intervals
#

alpha_hat_ci=function(dat,ulevel,p){
  lowerTail= dat<=ulevel
  T_L=sum(apply(lowerTail,1,prod))
  upperTail= dat>=1-ulevel
  T_U=sum(apply(upperTail,1,prod))
  ubound=alpha_hat(dat,ulevel)-qnorm(p/2)*sqrt((T_L+T_U)/(T_L*T_U))
  lbound=alpha_hat(dat,ulevel)+qnorm(p/2)*sqrt((T_L+T_U)/(T_L*T_U))
  return(c(lbound,ubound))
}


# Probability that the true value of alpha(u) lies in its asymptotic confidence interval for Clayton copula: coverage_alpha
#
# INPUT:
# n_vec: sample sizes -- vector
# ulevel_set: values of the tuning parameter u -- vector
# theta: parameter of Clayton copula
# p: parameter to construct 100*(1-p)% asymptotic confidence intervals
# 
# OUTPUT:
# coverage_prob: probabilities that the true value of alpha(u) lies in its asymptotic confidence interval for Clayton copula for each value of the index u and sample size n -- (#n_vec,#ulevel_set) matrix
#

coverage_alpha=function(n_vec,ulevel_set,theta,p){
  coverage_prob=matrix(0,length(n_vec),length(ulevel_set))
  r=1000
  set.seed(6)
  for(j in 1:length(n_vec)){
    n=n_vec[j]
    for(i in 1:r){
    u=rCopula(n,clay)
    xvals_hat=ulevel_set
    for(k in 1:length(xvals_hat)){
      ten_theo_alpha_hat=alpha_clay(xvals_hat[k],theta)
      ten_alpha_hat_ci=alpha_hat_ci(u,xvals_hat[k],p)
      if(is.na(ten_alpha_hat_ci[1])==TRUE) ten_alpha_hat_ci[1]=-Inf
      if(is.na(ten_alpha_hat_ci[2])==TRUE) ten_alpha_hat_ci[2]=Inf
      ten_coverage_prob=(ten_alpha_hat_ci[1]<=ten_theo_alpha_hat)&&(ten_alpha_hat_ci[2]>=ten_theo_alpha_hat)
      coverage_prob[j,k]=coverage_prob[j,k]+ten_coverage_prob
      }
  }
  }
  coverage_prob=coverage_prob/r
  return(coverage_prob)
}


# Set of tuning parameters used for analysis: find_ulevel
#
# INPUT:
# dat: copula sample -- (n,2) matrix
# 
# OUTPUT:
# u_min: value of u_{min}
# ulevel_sub2: set of the tuning parameters defined by {u in [u_{min},0.5); alpha(u_i)!=alpha(u_{i+1}) } with u_{min}=min{u; T_L,T_U>=30}.
#

find_ulevel=function(dat){
  min_TUTL=0
  u_min=0
  n_min=0
  ulevel_full=sort(c(dat[,1],1-dat[,1],dat[,2],1-dat[,2]))
  while(min_TUTL<30){
    n_min=n_min+1
    u_min=ulevel_full[n_min]
    lowerTail= dat<=u_min
    T_L=sum(apply(lowerTail,1,prod))
    upperTail= dat>=1-u_min
    T_U=sum(apply(upperTail,1,prod))
    min_TUTL=min(T_L,T_U)
  }
  
  ulevel_sub=ulevel_full[(ulevel_full>=u_min)&(ulevel_full<=0.5)]
  n_ulevel_sub=length(ulevel_sub)
  ulevel_sub2=NULL
  pre_T_L=pre_T_U=-10
  
  for(j in 1:n_ulevel_sub){
    lowerTail= dat<=ulevel_sub[j]
    T_L=sum(apply(lowerTail,1,prod))
    upperTail= dat>=1-ulevel_sub[j]
    T_U=sum(apply(upperTail,1,prod))
    if((pre_T_L!=T_L)||(pre_T_U!=T_U)) ulevel_sub2=c(ulevel_sub2,ulevel_sub[j])
    pre_T_L=T_L
    pre_T_U=T_U
  }
  return(list(u_min,ulevel_sub2))
}




# Set of tuning parameters used for analysis: find_ulevel_mod2
#
# INPUT:
# dat: copula sample -- (n,2) matrix
# u_min: minimum value of u
# 
# OUTPUT:
# ulevel_sub2: set of the tuning parameters defined by {u in [u_{min},0.5); alpha(u_i)!=alpha(u_{i+1}) } with u_{min}=min{u; T_L,T_U>=30}.
#

find_ulevel_mod2=function(dat,u_min){
  ulevel_full=sort(c(dat[,1],1-dat[,1],dat[,2],1-dat[,2]))
  
  ulevel_sub=ulevel_full[(ulevel_full>=u_min)&(ulevel_full<=0.5)]
  n_ulevel_sub=length(ulevel_sub)
  ulevel_sub2=NULL
  pre_T_L=pre_T_U=-10
  
  for(j in 1:n_ulevel_sub){
    lowerTail= dat<=ulevel_sub[j]
    T_L=sum(apply(lowerTail,1,prod))
    upperTail= dat>=1-ulevel_sub[j]
    T_U=sum(apply(upperTail,1,prod))
    if((pre_T_L!=T_L)||(pre_T_U!=T_U)) ulevel_sub2=c(ulevel_sub2,ulevel_sub[j])
    pre_T_L=T_L
    pre_T_U=T_U
  }
  return(ulevel_sub2)
}


# Calculation of alpha^*(u): alpha_star
#
# INPUT:
# dat: copula sample -- (n,2) matrix
# ulevel: value of the tuning parameter u
# 
# OUTPUT:
# value of alpha^*(u)
#

alpha_star=function(dat,ulevel){
  dat=mkPseudoDat(dat)$u
  lowerTail= dat<=ulevel
  T_L=sum(apply(lowerTail,1,prod))
  upperTail= dat>=1-ulevel
  T_U=sum(apply(upperTail,1,prod))
  return(log(T_U/T_L))
}


# Confidence intervals of alpha^*(u): alpha_star_ci
#
# INPUT:
# dat: bivariate sample -- (n,2) matrix
# ulevel: value of the tuning parameter u
# p: parameter to construct 100*(1-p)% confidence intervals
# 
# OUTPUT:
# lower and upper bounds of the 100*(1-p)% confidence intervals
#

alpha_star_ci=function(ulevel,dat,p){
  set.seed(1)
  boot_result=boot(dat,function(x,ind) alpha_star(x[ind,],ulevel),R=999)
  boot_ci=boot.ci(boot_result,conf=1-p,type="basic")$basic[c(4,5)]
  return(boot_ci)
}


# Distribution function of Clayton copula: clayton
#
# INPUT:
# u1: the first argument
# u2: the second argument
# theta: parameter
# 
# OUTPUT:
# Value of Clayton copula
#

clayton=Vectorize(function(u1,u2,theta) max(u1^(-theta)+u2^(-theta)-1,0)^(-1/theta))


# Value of alpha(u) for Clayton copula: alpha_clay
#
# INPUT:
# u: tuning parameter 
# theta: parameter of Clayton copula
# 
# OUTPUT:
# Value of alpha(u) for Clayton copula
#

alpha_clay=function(u,theta) log((2*u-1+clayton(1-u,1-u,theta))/clayton(u,u,theta))


# Transformation of observations using empirical distribution: mkPseudoDat
#
# INPUT:
# bivariate sample -- (N,2) matrix
# 
# OUTPUT:
# x: original sample
# u: copula sample transformed via empirical distribution 

mkPseudoDat <- function(orgdat){
  dim <- ncol(orgdat);
  N <- nrow(orgdat);
  u <- x <- matrix(0,nrow=N,ncol=dim);
  for(j in 1:dim){
    x[,j] <- orgdat[,j];
    Fx <- ecdf(x[,j]);
    u[,j] <- Fx(x[,j])*N/(N+1);
  }
  list(x=x,u=u);
}


# Residuals of AR-GARCH model fitted to daily return data: stdRes3Stocks
#
# INPUT:
# filename: name of the .csv file providing stock data
# obsperiod: period of observations of stock data
# spec: specification of AR-GARCH model
# pair: bivariate vector selecting two stock indices of interest 
#
# OUTPUT:
# Residuals of AR-GARCH model fitted to daily return data

stdResStocks<- function(filename,obsperiod,spec,pair){
  SPdat<-as.xts(read.zoo(filename,header=T,sep=","));
  SPdatAdj<-SPdat[!apply(is.na(SPdat),1,prod),];
  listRes <- list();
  for(j in 1:2){
    x <- SPdatAdj[,pair[j]];
    y <- x[!is.na(x)];
    ry <- diff(log(y));
    if(pair[j]==2){ ry <- lag(ry,k=-1); } ## For NK225
    fit <- ugarchfit(spec=spec, data=ry[obsperiod]);
    res <- residuals(fit,standardize=FALSE);
    listRes <- c(listRes,list(res));
  }
  mdat <- merge.xts(listRes[[1]],listRes[[2]],join="inner");
  mkPseudoDat(mdat);
}


# Set of tuning parameters starting with modified u_{min}: find_ulevel_mod
#
# INPUT:
# dat: copula sample -- (n,2) matrix
# 
# OUTPUT:
# u_min: value of u_{min}
# ulevel_sub2: set of the tuning parameters defined by {u in [u_{min},0.5); alpha(u_i)!=alpha(u_{i+1}) } with u_{min}=min{u; T_L,T_U>=30, 3*sigma(0.5)<sigma(u)}.
#

find_ulevel_mod=function(dat){
  N=nrow(dat)
  ulevel_full=sort(c(dat[,1],1-dat[,1],dat[,2],1-dat[,2]))
  ulevel_full=ulevel_full[ulevel_full<=0.5]
  n_ulevel_full=length(ulevel_full)
 
  ulevel_sub=NULL
  pre_T_L=pre_T_U=0
  
  for(j in 1:n_ulevel_full){
    lowerTail= dat<=ulevel_full[j]
    T_L=sum(apply(lowerTail,1,prod))
    upperTail= dat>=1-ulevel_full[j]
    T_U=sum(apply(upperTail,1,prod))
    if((pre_T_L!=T_L)||(pre_T_U!=T_U)) ulevel_sub=c(ulevel_sub,ulevel_full[j])
    pre_T_L=T_L
    pre_T_U=T_U
  }
  
  min_TLTU=0
  u_min=0
  n_min=0
  
  C_05_dat= dat<=0.5
  C_05=sum(apply(C_05_dat,1,prod))/N
  C_05_cri=3*sqrt(2/C_05)
  est_sd=1000
  
  while((min_TLTU<30)||(est_sd>C_05_cri)){
    n_min=n_min+1
    u_min=ulevel_sub[n_min]
    lowerTail= dat<=u_min
    T_L=sum(apply(lowerTail,1,prod))
    upperTail= dat>=1-u_min
    T_U=sum(apply(upperTail,1,prod))
    min_TLTU=min(T_L,T_U)
    est_sd=sqrt(N)*sqrt((T_L+T_U)/(T_L*T_U))
  }
  
  ulevel_sub2=ulevel_sub[ulevel_sub>=u_min]
  
  return(list(u_min,ulevel_sub2))
}


# Test based on the test statistic in Theorem 5: a_test
#
# INPUT:
# dat: copula sample -- (n,2) matrix
# ulevel: a vector of tuning parameters
# alpha0: alpha under the null hypothesis
# 
# OUTPUT:
# T_value: value of the test statistic
# p_T: p-value
#

a_test=function(dat,ulevel,alpha0){
  
  m=length(ulevel)
  sigma=matrix(1,m,m)
  a=1:m
  
  for(j in 1:m){
    lowerTail= dat<=ulevel[j]
    T_L=sum(apply(lowerTail,1,prod))
    upperTail= dat>=1-ulevel[j]
    T_U=sum(apply(upperTail,1,prod))
    a[j]=log(T_U/T_L)-alpha0(ulevel[j])
    sigma_t=(T_L+T_U)/(T_L*T_U)
    for(k in 1:j) sigma[j,k]=sigma_t
  }
  
  for(j in 1:(m-1)){
    for(k in (j+1):m){
      sigma[j,k]=sigma[k,j]
    }
  }
  
  T_value=t(a)%*%solve(sigma)%*%a
  p_T=pchisq(T_value,m,lower=F)
  
  return(c(T_value,p_T))
}


# Calculation related to the measure of Rosco and Joe (2013): rosco_joe_ele
#
# INPUT:
# dat: copula sample -- (N,2) matrix
# u1: 1st argument of empirical copula
# u2: 2nd argument of empirical copula
# 
# OUTPUT:
# Absolute difference between an empirical copula and its reflected one
#

rosco_joe_ele=function(dat,u1,u2){
  
  N=nrow(dat)
  lowerTail= cbind(dat[,1]<=u1,dat[,2]<=u2)
  C_12=sum(apply(lowerTail,1,prod))/N
  upperTail= cbind(dat[,1]>=1-u1,dat[,2]>=1-u2)
  CR_12=sum(apply(upperTail,1,prod))/N
  sigma3t=abs(C_12-CR_12)
  
  return(sigma3t)
}


# Calculation of a modified version of the measure of Krupskii (2017): krup_rho
#
# INPUT:
# dat: copula sample -- (n,2) matrix
# ulevel: index of the measure
# a: weighting function
# 
# OUTPUT:
# Value of a modified version of the measure of Krupskii (2017)
#

krup_rho=function(dat,ulevel,a){
  
  dat_lt=dat[as.logical(apply(dat<=ulevel,1,prod)),]
  dat_l=cbind(a(1-dat_lt[,1]/ulevel),a(1-dat_lt[,2]/ulevel))
  cor_l=cor(dat_l[,1],dat_l[,2])
  
  dat_ut=dat[as.logical(apply(dat>=1-ulevel,1,prod)),]
  dat_u=cbind(a(1-(1-dat_ut[,1])/ulevel),a(1-(1-dat_ut[,2])/ulevel))
  cor_u=cor(dat_u[,1],dat_u[,2])
  
  return(cor_u-cor_l)
}