R/dtriangle.R

In barryrowlingson/opVaR: Computes operational risk

dtriangle <-
function (q, a = 0, b = 1, c = 0.5) 
{
    q1 <- length(q)
    a1 <- length(a)
    b1 <- length(b)
    c1 <- length(c)
    dTest <- function(X) {
        if (any(is.na(X))) {
            if (any(is.nan(X))) 
                return(NaN)
            else return(NA)
        }
        else if (X[2] > X[4] | X[3] < X[4] | (X[1] == X[2] & 
            X[2] == X[4])) {
            warning("values required to be  a <= c <= b (at least one strict inequality)")
            return(NaN)
        }
        else if (any(is.infinite(X[2:4]))) {
            return(NaN)
        }
        else if (X[1] <= X[2]) {
            return(0)
        }
        else if (X[2] != X[4] & X[1] < X[4]) {
            return(2 * (X[1] - X[2])/(X[3] - X[2])/(X[4] - X[2]))
        }
        else if (X[4] != X[3] & X[1] >= X[4] & X[1] < X[3]) {
            return(2 * (X[3] - X[1])/(X[3] - X[2])/(X[3] - X[4]))
        }
        else if (X[1] >= X[3]) {
            return(0)
        }
    }
    k <- max(q1, a1, b1, c1)
    if (k == 1) 
        return(dTest(c(q, a, b, c)))
    params <- matrix(nrow = k, ncol = 4)
    tryCatch({
        params[, 1] <- q
        params[, 2] <- a
        params[, 3] <- b
        params[, 4] <- c
    }, error = function(X) {
        stop(paste(" -- Argument Lengths: length of q = ", q1, 
            ", a = ", a1, ", b = ", b1, ", c = ", c1, " -- ", 
            X, sep = ""))
    })
    return(apply(params, 1, dTest))
}