R/lter.R

In BayerSe/trexreg: Truncated Expectation Regression

#' Lower-Truncated Expectation Regression
#'
#' TBA
#'
#' @export
lter <- function(...) UseMethod('lter')

lter.default <- function(...) {
  stop('This method should not be called directly.
       Use the formula interface instead.')
}

lter.formula <- function(formula, data = parent.frame(), lq, early_stopping=10, ...) {
  chkDots(...)
  if(is.matrix(data)) {
    data <- as.data.frame(data)
  }

  # Preparation steps
  formula <- Formula::Formula(formula)
  formula <- lter.check_formula(formula)
  mf <- stats::model.frame(formula = formula, data = data, na.action = stats::na.pass)
  terms <- attr(mf, 'terms')

  # Extract data
  xm <- stats::model.matrix(formula, mf, rhs=1)
  xl <- stats::model.matrix(formula, mf, rhs=2)
  y <- stats::model.response(mf)

  # Fit model
  fit <- uter.fit(xm = cbind(1, -xm[,-1]), xu = cbind(1, -xl[,-1]), y = -y,
                  uq = 1-lq, early_stopping = early_stopping)
  class(fit) <- c('ter', 'lter')

  # Store multiple objects
  fit$formula <- formula
  fit$coefficients$coef_lq <- -fit$coefficients$coef_uq
  fit$coefficients$coef_mean <- -fit$coefficients$coef_mean
  fit$coefficients$coef_uq <- NA

  fit$call <- match.call()
  fit$terms <- terms
  fit$xlevels <- stats::.getXlevels(terms, mf)
  fit$data <- data
  fit$y <- y
  fit$xm <- xm
  fit$xl <- xl
  fit$lq <- lq
  fit$uq <- 1

  fit
}

vcov.lter <- function(object, ...) {
  object$xm <- cbind(1, -object$xm[,-1])
  object$xu <- cbind(1, -object$xl[,-1])
  object$y <- -object$y
  object$uq <- 1 - object$lq
  object$coefficients$coef_mean <- -object$coefficients$coef_mean
  object$coefficients$coef_uq <- -object$coefficients$coef_lq

  vcov <- vcov.uter(object)
  # Adjust covariance

  # colnames(vcov) <- rownames(vcov) <- c(colnames(object$xm),
  #                                       colnames(object$xl))

  vcov
}