R/dGEV.R

In ExtremalDep: Extremal Dependence Models

dGEV <- function(x, loc, scale, shape, log = FALSE) {
  if (is.vector(x) || is.vector(loc) || is.vector(scale) || is.vector(shape)) {
    n <- max(c(length(x), length(loc), length(scale), length(shape)))
    vals <- cbind(rep(x, length = n), rep(loc, length = n), rep(scale, length = n), rep(shape, length = n))
    result <- apply(vals, 1, function(y) {
      .C("dGEV", as.double(y[1]), as.double(y[2]), as.double(y[3]), as.double(y[4]),
        res = double(1), DUP = TRUE, NAOK = TRUE
      )$res
    })
  } else {
    result <- .C("dGEV", as.double(x), as.double(loc), as.double(scale), as.double(shape),
      res = double(1), DUP = TRUE, NAOK = TRUE
    )$res
  }

  if (log) {
    return(log(result))
  } else {
    return(result)
  }
}


pGEV <- function(q, loc, scale, shape, lower.tail = TRUE) {
  if (is.vector(q) || is.vector(loc) || is.vector(scale) || is.vector(shape)) {
    n <- max(c(length(q), length(loc), length(scale), length(shape)))
    vals <- cbind(rep(q, length = n), rep(loc, length = n), rep(scale, length = n), rep(shape, length = n))
    result <- apply(vals, 1, function(y) {
      .C("pGEV", as.double(y[1]), as.double(y[2]), as.double(y[3]), as.double(y[4]),
        res = double(1), DUP = TRUE, NAOK = TRUE
      )$res
    })
  } else {
    result <- .C("pGEV", as.double(q), as.double(loc), as.double(scale), as.double(shape),
      res = double(1), DUP = TRUE, NAOK = TRUE
    )$res
  }

  if (lower.tail) {
    return(result)
  } else {
    return(1 - result)
  }
}

qGEV <- function(p, loc, scale, shape) {
  if (is.vector(p) || is.vector(loc) || is.vector(scale) || is.vector(shape)) {
    n <- max(c(length(p), length(loc), length(scale), length(shape)))
    vals <- cbind(rep(p, length = n), rep(loc, length = n), rep(scale, length = n), rep(shape, length = n))
    result <- apply(vals, 1, function(y) {
      .C("qGEV", as.double(y[1]), as.double(y[2]), as.double(y[3]), as.double(y[4]),
        res = double(1), DUP = TRUE, NAOK = TRUE
      )$res
    })
  } else {
    result <- .C("qGEV", as.double(p), as.double(loc), as.double(scale), as.double(shape),
      res = double(1), DUP = TRUE, NAOK = TRUE
    )$res
  }

  return(result)
}