R/utilsChecks.R

In gamCopula: Generalized Additive Models for Bivariate Conditional Dependence Structures and Vine Copulas

var2char <- function(var) {
  deparse(substitute(var))
}

valid.logical <- function(x) {
  !is.null(x) && length(x) == 1 && !is.na(x) &&
    (is.logical(x) || (x == 0) || (x == 1))
}

msg.logical <- function(x) {
  paste("'", x, "' should take 0/1 or FALSE/TRUE.", sep = "")
}

valid.unif <- function(x) {
  !is.null(x) && length(x) == 1 && !is.na(x) &&
    is.numeric(x) && x >= 0 && x <= 1
}

msg.unif <- function(x) {
  paste("'", x, "' should be a real number in [0,1].", sep = "")
}

valid.real <- function(x) {
  !is.null(x) && is.numeric(x) && length(x) == 1 && !is.na(x)
}

msg.real <- function(x) {
  paste("'", x, "' should be a real number.", sep = "")
}

valid.posint <- function(x) {
  !is.null(x) && length(x) == 1 && !is.na(x) &&
    is.numeric(x) && as.integer(x) == x && x > 0
}

msg.posint <- function(x) {
  paste("'", x, "' should be a positive integer.", sep = "")
}

valid.family <- function(x) {
  valid.posint(x) && is.element(x, get.familyset())
}

msg.family <- function(x) {
  paste("Copula family not implemented. '", x,
    "' should be in {",
    paste(get.familyset(), collapse = ","), "}.",
    sep = ""
  )
}

valid.familypos <- function(x, tau) {
  tau > 0 && !is.element(x, c(23, 24, 33, 34))
}

msg.familypos <- function(x) {
  "This copula family cannot be used for positively dependent data."
}

valid.familyneg <- function(x, tau) {
  tau < 0 && !is.element(x, c(3, 4, 13, 14))
}

msg.familyneg <- function(x) {
  "This copula family cannot be used for negatively dependent data."
}

valid.familyset <- function(x) {
  !is.null(x) && ((length(x) == 1 && (is.na(x) || valid.family(x))) ||
    all(sapply(x, valid.family)))
}

msg.familyset <- function(x) {
  paste("'", x, "' should be either NA or a vector with elements in {",
    paste(get.familyset(), collapse = ","), "}.",
    sep = ""
  )
}

valid.familysetpos <- function(x, tau) {
  any(sapply(x, function(y) valid.familypos(y, tau)))
}

msg.familysetpos <- function(x) {
  paste("'", x, "' needs at least ",
    "one bivariate copula family for positive dependence.",
    sep = ""
  )
}

valid.familysetneg <- function(x, tau) {
  any(sapply(x, function(y) valid.familyneg(y, tau)))
}

msg.familysetneg <- function(x) {
  paste("'", x, "' needs at least ",
    "one bivariate copula family for negative dependence.",
    sep = ""
  )
}

valid.covariates <- function(x, msg) {
  if (!is.vector(x) || !is(x, "character")) {
    return(msg)
  }
  if (!(length(x) == 1 && is.na(x))) {
    l <- length(x)
  } else {
    l <- 0
  }
  return(l)
}