R/check.R

In ameras: Analyze Multiple Exposure Realizations in Association Studies

new_amerasfit <- function(x = list()) {
  stopifnot(is.list(x))
  structure(
    x,
    class = "amerasfit"
  )
}

check_df <- function(x, nm="data") {
  
  if (!is.data.frame(x)) stop(paste0("ERROR: ", nm, " must be a data frame"))
  if (!nrow(x)) stop(paste0("ERROR: ", nm, " has no rows"))  
  if (!ncol(x)) stop(paste0("ERROR: ", nm, " has no columns"))
  NULL  
}

check_family <- function(x, nm="family") {
  valid <- c("gaussian", "binomial", "poisson", "prophaz", "multinomial", "clogit")
  check_char_vec(x, nm, valid=valid, def=NULL, len=1) 
}

check_doseRRmod <- function(x, nm="doseRRmod") {
  valid <- c("ERR","EXP","LINEXP")
  check_char_vec(x, nm, valid=valid, def=NULL, len=1) 
}

check_Y <- function(v, data, family) {
  nm <- "Y"
  check_vars(data, v, nm, minlen=1, maxlen=0)
  vec <- data[, v, drop=TRUE]
  if(family != "multinomial"){
    binary <- nonneg <- integer <- 0
    if (family %in% c("binomial", "prophaz", "clogit")) {
      binary <- 1
    } else if (family == "poisson") {
      nonneg  <- 1
      integer <- 1 
    }
    check_num_vec(vec, nm, binary=binary, nonneg=nonneg, integer=integer)
    NULL
  } else { # multinomial 
    check_factor_vec(vec, nm)
    NULL
  }
}

check_D <- function(vars, data, methods) {
  
  nm <- "dosevars"
  check_vars(data, vars, nm, minlen=1, maxlen=0)
  for (v in vars) {
    vec <- data[, v, drop=TRUE]
    nm2 <- paste0(nm, ":", v)
    check_num_vec(vec, nm2)
  }
  if(length(vars)==1 &  any(c("ERC", "MCML", "FMA", "BMA") %in% methods)) stop("Multiple exposure replicates required for ERC, MCML, FMA, and BMA. With a single exposure vector, use RC")
  NULL
}

check_M <- function(vars, data) {
  
  nm <- "M"
  check_vars(data, vars, nm, minlen=0, maxlen=0)
  for (v in vars) {
    vec <- data[, v, drop=TRUE]
    nm2 <- paste0(nm, ":", v)
    check_num_vec(vec, nm2, binary=1)
  }
  NULL
}

check_X <- function(vars, data) {
  
  nm <- "X"
  check_vars(data, vars, nm, minlen=0, maxlen=0)
  for (v in vars) {
    vec <- data[, v, drop=TRUE]
    nm2 <- paste0(nm, ":", v)
    check_num_vec(vec, nm2)
  }
  NULL
}

check_offset <- function(v, data) {
  if (!length(v)) return(NULL)
  nm <- "offset"
  check_vars(data, v, nm, minlen=0, maxlen=0)
  check_num_vec(data[, v, drop=TRUE], nm, nonneg=1)
  
  NULL
}

check_setnr <- function(v, data) {
  nm <- "setnr"
  check_vars(data, v, nm, minlen=1, maxlen=1)
  check_num_vec(data[, v, drop=TRUE], nm, nonneg=1, integer=1)
  
  nset_noncontributing <- sum(table(data[,v, drop=TRUE])==1)
  if(nset_noncontributing>0) warning(paste0("Data contains ", nset_noncontributing, " matched sets of size 1 that do not contribute to model estimation"))
  
  NULL
}

check_entry_exit <- function(entry, exit, data) {
  
  nm1 <- "entry"
  nm2 <- "exit"
  check_vars(data, entry, nm1, minlen=0, maxlen=0)
  check_vars(data, exit,  nm2, minlen=1, maxlen=1)
  vec2 <- data[, exit, drop=TRUE]
  check_num_vec(vec2, nm2)
  if (length(entry)) {
    vec1 <- data[, entry, drop=TRUE]
    check_num_vec(vec1, nm1)
    tmp <- entry > exit
    tmp[is.na(tmp)] <- FALSE
    if (any(tmp)) stop(paste0("ERROR: ", nm1, " > ", nm2, " for some values")) 
  }
  
  NULL
}

check_methods <- function(x) {
  
  nm    <- "methods"
  valid <- c("RC","ERC","MCML","FMA","BMA")
  ret   <- check_char_vec(x, nm, valid=valid, def="RC", len=0)
  ret   <- unique(ret)
  ret
}

check_deg <- function(x) {
  if (!length(x)) return(2)
  nm <- "deg"
  check_integer(x, nm, minlen=1, maxlen=1, min=1, max=2) 
  x
}

check_inpar <- function(x, family, M, X, deg, multinom_levels=0) {
  if (!length(x)) return(NULL)
  nm <- "inpar"
  if (family == "gaussian") {
    len <- 2+length(X)+length(M)*deg+deg
  } else if (family %in% c("binomial", "poisson")) {
    len <- 1+length(X)+length(M)*deg+deg 
  } else if (family %in% c("prophaz", "clogit")) {
    len <- length(X)+length(M)*deg+deg
  } else if (family=="multinomial"){
    len <- (multinom_levels-1) * (1+length(X)+length(M)*deg+deg) 
  } else {
    stop("ERROR")
  }
  check_num_vec(x, nm, binary=0, nonneg=0, integer=0, len=len)
  x
}


check_factor_vec <- function(x, nm, len=0) {
  
  if (!is.factor(x)) stop(paste0("ERROR: ", nm, " must be numeric"))
  if (len && (len != length(x))) {
    stop(paste0("ERROR: ", nm, " must be a numeric vector of length ", len))
  }
  
  if (length(levels(x))<3) stop(paste0("ERROR: ", nm, " must have at least 3 levels"))
  
  if (length(levels(x)) > length(unique(x))) stop(paste0("ERROR: ", nm, " contains unused levels"))
  
  NULL
}

check_num_vec <- function(x, nm, binary=0, nonneg=0, integer=0, len=0) {
  
  if (!is.numeric(x)) stop(paste0("ERROR: ", nm, " must be numeric"))
  if (len && (len != length(x))) {
    stop(paste0("ERROR: ", nm, " must be a numeric vector of length ", len))
  }
  tmp <- !is.finite(x)
  if (any(tmp)) stop(paste0("ERROR: ", nm, " must contain finite values"))
  if (binary) {
    tmp <- !(x %in% 0:1)
    if (any(tmp)) stop(paste0("ERROR: ", nm, " must contain binary (0 - 1) values"))
  }
  if (nonneg) {
    tmp <- x < 0
    if (any(tmp)) stop(paste0("ERROR: ", nm, " must contain non-negative values"))
  }
  if (integer) check_integer(x, nm, minlen=0, maxlen=0, min=NULL, max=NULL)  
  
  NULL
}

check_vars <- function(data, vars, nm, minlen=0, maxlen=0) {
  
  nv <- length(vars)
  if (minlen && (minlen == maxlen) && (nv != minlen)) stop(paste0("ERROR: ", nm, " must have length ", minlen))
  if (nv < minlen) stop(paste0("ERROR: ", nm, " must have length >= ", minlen))
  if (!nv) return(NULL)
  if (!is.vector(vars)) stop(paste0("ERROR: ", nm, " must be a vector of indices or variable names"))
  
  nc <- ncol(data)
  cx <- colnames(data)
  if (is.numeric(vars)) {
    check_integer(vars, nm, minlen=minlen, maxlen=nc, min=1, max=nc)
  } else if (is.character(vars)) {
    check_char_vec(vars, nm, valid=cx, def=NULL) 
  } else {
    stop(paste0("ERROR: ", nm, " must be a vector of indices or variable names"))
  }
  if (any(duplicated(vars))) stop(paste0("ERROR: ", nm, " contains duplicated values"))
  
  unique(vars)
  
}

getCharVecStr <- function(x, sep=",") {
  
  ret <- paste0("'", x, "'")
  ret <- paste0(ret, collapse=sep)
  ret
  
}

check_char_vec <- function(x, nm, valid=NULL, def=NULL, len=0) {
  
  n <- length(x)
  if (len && (n != len)) stop(paste0("ERROR: ", nm,  " must have length ", len))
  if (!n) return(def)
  if (!is.character(x)) stop(paste0("ERROR: ", nm,  " must be character"))
  if (length(valid)) {
    tmp <- !(x %in% valid)
    if (any(tmp)) {
      err <- getCharVecStr(x[tmp])
      stop(paste0("ERROR ", nm, " contains invalid values: ", err))
    }  
  }
  x
}

check_integer <- function(x, nm, minlen=1, maxlen=0, min=NULL, max=NULL) {
  
  n <- length(x)
  if (minlen && (minlen == maxlen) && (n != minlen)) stop(paste0("ERROR: ", nm, " must have length ", minlen))
  if (minlen && (n < minlen)) stop(paste0("ERROR: ", nm, " must have length >= ", minlen))
  if (!is.numeric(x)) stop(paste0("ERROR: ", nm, " must be integer"))
  if (any(!is.finite(x))) stop(paste0("ERROR: ", nm, " must be integer"))
  if (any(x != floor(x))) stop(paste0("ERROR: ", nm, " must be integer"))
  if (length(min) && any(x < min)) stop(paste0("ERROR: ", nm, " must be >= ", min))
  if (length(max) && any(x > max)) stop(paste0("ERROR: ", nm, " must be <= ", max)) 
  
  NULL
}

# Function to check that an object is a string
isString <- function(obj) {
  
  if ((length(obj) == 1) && is.character(obj)) {
    ret <- TRUE
  } else {
    ret <- FALSE
  }
  
  ret
  
} # END: isString

check_string <- function(obj, valid, parm) {
  
  # obj:   A character string (length 1)
  # valid: Character vector of valid values
  # parm:  The name of the argument being checked
  
  errFlag <- 0
  
  # Check for errors
  if (!isString(obj)) errFlag <- 1 
  if (!errFlag) {
    obj <- trimws(obj)
    if (!(obj %in% valid)) errFlag <- 1
  }
  if (errFlag) {
    msg <- getCharVecStr(valid)
    msg <- paste0("ERROR: ", parm, " contains the invalid values ", msg)
    stop(msg)
  }
  
  obj
  
} # END: check.string