## Auxiliary Functions in One Page
# CHECKERS
# (1) check_null : if NULL, return TRUE
# HANDLERS
# (1) handle_weight : a weight vector that sums to 1 (warning)
# (2) handle_ivec : an integer vector
# handle_ivec_pos : an integer vector of positive values
# handle_ivec_nonneg : an integer vector of nonnegative values
# (3) handle_cts : just a continuous vector
# handle_cts_bdd : bounded vector of real numbers
# handle_cts_nonneg : nonneg vector of real numbers
# handle_cts_pos : pos vector of real numbers
# (4) handle_binary : {0,1} only
# CHECKER -----------------------------------------------------------------
# (1) check_null
#' @keywords internal
check_null <- function(obj){
if ((length(obj)==0)&&(is.null(obj))){
return(TRUE)
} else {
return(FALSE)
}
}
# HANDLER -----------------------------------------------------------------
# (1) handle_weight
#' @keywords internal
handle_weight <- function(fname, weight, n){
if (check_null(weight)){
weight = rep(1, n)
}
if (length(weight)!=n){
stop(paste0("* ",fname," : weight vector is not of same length."))
}
if (any(is.infinite(weight))||any(is.na(weight))){
stop(paste0("* ",fname," : weight vector contains NA or Inf values."))
}
if (any(weight<0)){
stop(paste0("* ",fname," : weight vector should contain no negative numbers."))
}
return(weight)
}
# (2) handle_ivec
#' @keywords internal
handle_ivec <- function(fname, x){
xname = deparse(substitute(x))
if (!is.vector(x)){
stop(paste0("* ",fname," : ",xname," should be a vector."))
}
if (any(is.na(x))||any(is.infinite(x))){
stop(paste0("* ",fname," : ",xname," should not contain any NA or Inf values."))
}
x = round(x)
return(x)
}
# (2) handle_ivec_pos
#' @keywords internal
handle_ivec_pos <- function(fname, x){
xname = deparse(substitute(x))
if (!is.vector(x)){
stop(paste0("* ",fname," : ",xname," should be a vector."))
}
x = round(x)
if (any(is.na(x))||any(is.infinite(x))){
stop(paste0("* ",fname," : ",xname," should not contain any NA or Inf values."))
}
if (any(x<=0)){
stop(paste0("* ",fname," : ",xname," should only contain positive integers."))
}
return(x)
}
# (3) handle_ivec_nonneg : an integer vector of nonnegative values
#' @keywords internal
handle_ivec_nonneg <- function(fname, x){
xname = deparse(substitute(x))
if (!is.vector(x)){
stop(paste0("* ",fname," : ",xname," should be a vector."))
}
x = round(x)
if (any(is.na(x))||any(is.infinite(x))){
stop(paste0("* ",fname," : ",xname," should not contain any NA or Inf values."))
}
if (any(x<0)){
stop(paste0("* ",fname," : ",xname," should only contain nonnegative integers."))
}
return(x)
}
# (3) handle_cts : just a continuous vector
#' @keywords internal
handle_cts <- function(fname, x){
xname = deparse(substitute(x))
if (!is.vector(x)){
stop(paste0("* ",fname," : ",xname," should be a vector."))
}
if (any(is.na(x))||any(is.infinite(x))){
stop(paste0("* ",fname," : ",xname," should not contain any NA or Inf values."))
}
return(x)
}
# (3) handle_cts_bdd : bounded vector of real numbers
#' @keywords internal
handle_cts_bdd <- function(fname, x, lower=0, upper=1, include.boundary=TRUE){
xname = deparse(substitute(x))
if (!is.vector(x)){
stop(paste0("* ",fname," : ",xname," should be a vector."))
}
if (any(is.na(x))||any(is.infinite(x))){
stop(paste0("* ",fname," : ",xname," should not contain any NA or Inf values."))
}
if (include.boundary){
if (any(x>upper)||any(x<lower)){
stop(paste0("* ",fname," : ",xname," should have values in [",lower,",",upper,"]."))
}
} else {
if (any(x>=upper)||any(x<=lower)){
stop(paste0("* ",fname," : ",xname," should have values in (",lower,",",upper,")."))
}
}
return(x)
}
# (3) handle_cts_nonneg : nonnegative vector of real numbers
#' @keywords internal
handle_cts_nonneg <- function(fname, x){
xname = deparse(substitute(x))
if (!is.vector(x)){
stop(paste0("* ",fname," : ",xname," should be a vector."))
}
if (any(is.na(x))||any(is.infinite(x))){
stop(paste0("* ",fname," : ",xname," should not contain any NA or Inf values."))
}
if (any(x<0)){
stop(paste0("* ",fname," : ",xname," should have nonnegative real numbers."))
}
return(x)
}
# (3) handle_cts_pos : positive real numbers
#' @keywords internal
handle_cts_pos <- function(fname, x){
xname = deparse(substitute(x))
if (!is.vector(x)){
stop(paste0("* ",fname," : ",xname," should be a vector."))
}
if (any(is.na(x))||any(is.infinite(x))){
stop(paste0("* ",fname," : ",xname," should not contain any NA or Inf values."))
}
if (any(x<=0)){
stop(paste0("* ",fname," : ",xname," should have nonnegative real numbers."))
}
return(x)
}
# (4) handle_binary : {0,1} only
#' @keywords internal
handle_binary <- function(fname, x){
xname = deparse(substitute(x))
if (!is.vector(x)){
stop(paste0("* ",fname," : ",xname," should be a vector."))
}
if (any(is.na(x))||any(is.infinite(x))){
stop(paste0("* ",fname," : ",xname," should not contain any NA or Inf values."))
}
xx = round(x)
ux = unique(xx)
if (all((ux %in% c(0,1))==TRUE)){
return(xx)
} else {
stop(paste0("* ",fname," : ",xname," should be a binary vector composed of {0,1}."))
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.