R/helper_functions.R

In BayerSe/trexreg: Truncated Expectation Regression

#' @export
find_type_of_truncation <- function(interval) {
  eps <- .Machine$double.eps^0.5
  if ((interval[1] <= eps) & ((1 - eps <= interval[2]))) {
    ret <- 'no_truncation'
  } else if (interval[1] <= eps) {
    ret <- 'upper_truncation'
  } else if (1 - eps < interval[2]) {
    ret <- 'lower_truncation'
  } else {
    ret <- 'double_truncation'
  }
  ret
}

ter.lin_mod <- function(par, x) {
  x %*% par
}

check.x <- function(x) {
  if(!is.matrix(x))
    stop("'x' is not a matrix or could not be converted to a matrix")
  if(NROW(x) == 0 || NCOL(x) == 0)
    stop("'x' is empty")
  if(anyNA(x))
    stop("NA in 'x'")
  # checking just the first column of x suffices because x is a matrix
  # is.logical allowed because qr etc. treat logical vars as numeric
  if(!is.numeric(x[,1]) && !is.logical(x[,1]))
    stop("non-numeric column in 'x'")
  # ensure all columns in x are named (needed for names in vcov etc.)
  # use the same naming convention as lm (prefix for unnamed cols is "V")
  missing.colnames <-
    if(is.null(colnames(x))) 1:NCOL(x)
  else                     nchar(colnames(x)) == 0
  colnames(x)[missing.colnames] <-
    c("(Intercept)",
      paste("V", seq_len(NCOL(x) - 1), sep = ""))[missing.colnames]
  duplicated <- which(duplicated(colnames(x)))
  if(length(duplicated))
    stop("column name \"", colnames(x)[duplicated[1]],
         "\" in 'x' is duplicated")
  x
}

check.y <- function(x, y) {
  # as.vector(as.matrix(y)) is necessary when y is a data.frame
  # (because as.vector alone on a data.frame returns a data.frame)
  y <- as.vector(as.matrix(y))
  if(length(y) == 0)
    stop("'y' is empty")
  if(anyNA(y))
    stop("NA in 'y'")
  if(!is.numeric(y) && !is.logical(y))
    stop("'y' is not numeric or logical")
  if(length(y) != nrow(x))
    stop("nrow(x) is ", nrow(x), " but length(y) is ", length(y))
  y
}

#' @export
nter.check_formula <- function(formula) {
  if (length(formula)[2] > 1) {
    stop('With no truncation you must not have more than one formula object.')
  }

  formula
}

#' @export
lter.check_formula <- function(formula) {
  if (length(formula)[2] == 1) {
    formula <- Formula::as.Formula(formula(formula),
                                   formula(formula, lhs = 0, rhs = 1))
  } else if (length(formula)[2] > 2) {
    stop('With single truncation you must not have more than two formula objects.')
  }

  formula
}

uter.check_formula <- lter.check_formula

#' @export
dter.check_formula <- function(formula) {
  if (length(formula)[2] == 1) {
    formula <- Formula::as.Formula(formula(formula),
                                   formula(formula, lhs = 0, rhs = 1),
                                   formula(formula, lhs = 0, rhs = 1))
  } else if (length(formula)[2] == 2) {
    stop('With double truncation you must have either one or three formula objects.')
  } else if (length(formula)[2] > 3) {
    stop('With double truncation you must not have more than three formula objects.')
  }

  formula
}