# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR Description. See the 
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU Library General 
# Public License along with this library; if not, write to the 
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, 
# MA 02111-1307 USA

# Copyrights (C)
# for this R-port: 
#   1999 - Diethelm Wuertz, GPL
#   2007 - Rmetrics Foundation, GPL
#   Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
# for code accessed (or partly included) from other sources:
#   see Rmetric's copyright and license files


################################################################################
# FUNCTION:                   DESCRIPTION:
#  .covRisk                    Computes Covariance Risk
#  .varRisk                    Computes Value at Risk
#  .cvarRisk                   Computes Conditional Value at Risk
# FUNCTION:                   PORTFOLIO UTILITIES: 
#  .cfgFit                     Fits bivariate tail dependency parameter lambda
#  .lambdaTailRisk             Fits tail lambda for multivariate data
################################################################################


.covRisk <- 
    function(data, weights)
{   
    # A function implemented by Rmetrics

    # Description:
    #   Computes Covariance Risk for assets given weights and alpha
    
    # FUNCTION:
    
    # Data:
    Data = as.matrix(data)
    nAssets = dim(Data)[2]
    
    # Mean Vector and Covariance:
    mu = colMeans(Data)
    Sigma = cov(Data)
    
    # Return and Risk:
    return = as.numeric( weights %*% mu )
    risk = sqrt( as.numeric( weights %*% Sigma %*% weights ) )
    
    # Return Value:
    list(risk = risk, return = return)
}
    
    
# ------------------------------------------------------------------------------


.varRisk <- 
    function(x, weights, alpha = 0.05)
{   
    # A function implemented by Rmetrics

    # Description:
    #   Computes VaR for assets given weights and alpha
    
    # Arguments:
    #   x - any univariate or multivariate object which can
    #       be transformed into a matrix
    #   weights - a numeric vector, the weights vector
    #   alpha - a numeric value, the quantile
    
    # FUNCTION:
    
    # VaR:
    X = as.matrix(x) %*% weights
    VaR = quantile(X, alpha, type = 1) 
    names(VaR) <- paste("VaR.", alpha*100, "%", sep = "")
    
    # Return Value:
    VaR
} 


# ------------------------------------------------------------------------------


.cvarRisk <- 
    function(x, weights, alpha = 0.05)
{   
    # A function implemented by Rmetrics

    # Description:
    #   Computes CVaR for assets given weights and alpha
    
    # Arguments:
    #   x - any univariate or multivariate object which can
    #       be transformed into a matrix
    #   weights - a numeric vector, the weights vector
    #   alpha - a numeric value, the quantile
    
    # FUNCTION:
    
    # CVaR:
    X = as.matrix(x) %*% weights
    VaR = quantile(X, alpha, type = 1)
    CVaR = c(CVaR = VaR - 0.5 * mean(((VaR-X) + abs(VaR-X))) / alpha) 
    names(CVaR) <- paste("CVaR.", alpha*100, "%", sep = "")
    
    # Return Value:
    CVaR
} 


################################################################################


.cfgFit <- 
    function(x, y, tail = c("upper", "lower"))
{
    # Description:
    #   Fits bivariate tail dependency parameter lambda
    
    # Arguments:
    #   data - multivariate time series object of class S4 or a numeric
    #       matrix 
    #   tail - which tail should be considered? 
    
    # FUNCTION:
    
    # Match Arguments:
    tail = match.arg(tail)
    
    # If Lower Tail:
    if(tail == "lower") {
        x = 1-x
        y = 1-y
    }
    
    # Fit lambda:
    lambda = NULL
    n = length(x)
    for(i in 1:n){
        lambda = c(lambda,
            log(sqrt(log(1/x[i])*log(1/y[i]))/log(1/max(x[i],y[i])^2)))
    }
    ans = (2-2*exp(sum(lambda/n)))
    attr(ans, "control") <- c(tail = tail)
    
    # Return Value:
    ans
}


# ------------------------------------------------------------------------------


.lambdaTailRisk <- 
    function(data, tail = c("upper", "lower"), margins = "norm", ...)
{
    # Description:
    #   Fits tail dependency parameter lambda for multivariate data
    
    # Arguments:
    #   data - multivariate time series object of class S4 or a numeric
    #       matrix 
    #   tail - which tail should be considered? 
    
    # Example:
    #   r = rarchmCopula(60, alpha = 2, type = "4")
    #   .cfgFit(r[, 1], r[, 2])
    #   x = cbind(qnorm(r[, 1]), qnorm(r[, 2]))
    #   .lambdaTailRisk(x)
    
    # FUNCTION:
    
    # Check Data:
    if(is.timeSeries(data)) data = data@Data
    n = ncol(data)
    
    # Normal Margins - Create Bivariate Copulae:
    x = data
    for (i in 1:n) {
        y = as.vector(data[, i])
        x[, i] = pnorm(y, mean(y), sd(y))
    }
    
    # Match Arguments:
    tail = match.arg(tail)
    
    # Compute Tail Risks:
    riskMatrix = diag(n)
    # Compute lambda:
    for ( i in 1:(n-1) ) {
        for ( j in (i+1):n ) {
            riskMatrix[i, j] = riskMatrix[j, i] = 
                .cfgFit(x[, i], x[, j], tail = tail)
        }
    }
    attr(riskMatrix, "control") <- c(tail = tail)
    
    # Return Value:
    riskMatrix
}


################################################################################