R/package-auxiliary.R

In kyoustat/T4mle: What the Package Does Using Title Case

## 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}."))
  }
}