R/qc.R

In ipeglim: Imprecise Inferential Framework on Statistical Reasoning

#' @title Quality Control of Estimates
#' @description Replacement of estimates
#'
#' @param x 
#' @param ... other arguments to be passed to the function \code{qc}.
#'
#' @details
#' Special cares are needed on the use of estimates produced from the Laplace
#' approximation in the regression model because of its failure.
#' 
#' @author Chel Hee Lee <\email{gnustats@@gmail.com}>
#' @export 
qcLA <- function(x, level=0, verbose=FALSE, ...){
  
  # naming convention
  stage <- x$stage
  m1 <- x$m1
  method <- x$method
  xtms <- x$xtms
  
  stopifnot(class(x)=="imprecise", stage %in% c("update", "summary"), x$method=="LA")
  
  # identification of extreme points which will be replaced.
  est <- do.call(rbind, lapply(m1, "[[", "cfs"))
  sratio <- do.call(rbind, lapply(m1, "[[", "sratio"))

  idx <- unique(rownames(which(is.na(sratio), arr.ind=TRUE)))
  tmp <- xtms[idx]
  
  fixtms <- lapply(X=names(tmp), FUN=function(a){
    xtms.i <- a
    a <- tmp[[a]]
    a <- as.vector(a)
    op <- cpef2reg(b=a, B=x$B, y=x$y, X=x$X, ztrunc=x$ztrunc, method="MH", start=x$init, initrun=FALSE, verbose=TRUE)
    return(op)
  })
  names(fixtms) <- idx
  
  for(i in which(names(m1) %in% idx)){
    if (verbose) {
      message(sQuote(names(m1)[i]), " is replaced.")
    }
    x$m1[i] <- fixtms[i]
  }
  
  x$qcLA <- TRUE
  # TODO
  # control level 0 - only replace NA by MH
  # control level 1 - sratio is not in the tolerance in each dimension
  invisible(x)
}