R/update_imprecise.R

In ipeglim: Imprecise Inferential Framework on Statistical Reasoning

#' @aliases update update.imprecise
#' @title 
#' Updating Imprecise Prior
#'
#' @description 
#' The function \code{update} applies to the Bayes rule to the imprecise prior 
#' which is specified by \code{"\link{iprior}"} by taking \code{data} in the
#' \code{"\link{model}"}.
#'
#' @param object 
#' an object of class \code{imprecise} produced from \code{"\link{iprior}"}.
#' See \sQuote{Details} for more information.
#'
#' @param silent
#' a logical value; Would like to see the report of progress messages 
#' (including warnings and error messages) generated from numerical methods
#' that are used for a numerical approximation?
#' Defaults to \code{FALSE}.
#' 
#' @param ... 
#' Other named arguments to be passed to \code{\link{cpef}} and 
#' \code{\link{cpef2reg}}; needs to be matched exactly.
#' See \sQuote{Details} for more information.
#'
#' @details 
#' The function \code{update} calls the functions of \code{\link{cpef}} and 
#' \code{\link{cpef2reg}} based on the \code{formula} specified 
#' in the \code{\link{model}}.
#' Named arguements of \code{ztrunc}, \code{method}, and \code{apriori} are 
#' passed to those functions. 
#'
#' This \code{update} is the last stage on the imprecise inferential framework.
#' \code{stage} has the environment name called. 
#' 
#' \code{method} should be specified;
#' Five options are available on the use of \code{\link{cpef}};
#' Three options are available on the use of \code{\link{cpef2reg}}.
#' See the \sQuote{Details} of \code{\link{cpef}} and \code{\link{cpef2reg}}.
#'
#' In general, \code{MH} is safe from numerical failure on parameter estimation 
#' with a small size of a sample.
#' \code{LA} is the most effieint for a large size of a sample (say, 
#' \eqn{n>5e2} for zero-truncated case).
#' 
#' @return A list with the components:
#' \item{m1}{The list containing all information of parameter estimation.}
#' \item{method}{The type of numerical method used for numerical approximation}
#' \item{xi}{The numeric vector for prediction if provided.}
#' 
#' @keywords 
#' Imprecise inferential framework, Poisson regression, Bayes
#'
#' @seealso 
#' \code{\link{iprior}}, \code{\link{model}}, \code{\link{cpef}},
#' \code{\link{cpef2reg}}
#'
#' @examples
#' \dontrun{
#' ## 
#' }
#' @references
#' Lee (2013) ``Imprecise inferential framework'', PhD thesis.
#'
#' @author Chel Hee Lee <gnustats@@gmail.com>
#'
#' @method update imprecise
#' @S3method update imprecise
# update.imprecise <- function(object, apriori= c("lgamma", "normal"), silent=FALSE,...){
update.imprecise <- function(object, silent=FALSE,...){

  # sanity check
  stopifnot(!missing(object))

  if(object$stage != "iprior") stop("Not correct order of imprecise inferential framework. \n'update' should be followed by 'iprior'")
  mc <- match.call() 
  object$stage <- "update" # mc[[1]]

  # naming convention
  init <- object$init
  y <- object$y
  X <- object$X
  xreg <- object$xreg
  xtms <- object$xtms 
  ztrunc <- object$ztrunc
  
  applyBayes <- function(x, ...){
    # Passing the information of an imprecise prior to the selected numerical
    # approximation method
    # 
    # Args: 
    #   x: The component of an imprecise prior
    # 
    # Return:
    #   The object including all numerical results 
    
    # Make sure which extreme point in the convex hull is.
    xtms.i <- x
    if (!silent) {
      message("ID confirmation: ", sQuote(xtms.i))
    }
    
    # Access the i-th actual imprecise information
    x <- xtms[[x]]
    x <- as.vector(x)
    
    if (xreg) {
      fit <- cpef2reg(b=x, X=X, start=init, ...)
    } else {
      fit <- cpef(hparam=x, start=(log(mean(y))+rnorm(1)), ...)
    }
    
    return(fit)
  }
  
  # tracking the correct component of an imprecise prior
  m1 <- lapply(X=names(xtms), FUN=applyBayes, 
               y=y, ztrunc=ztrunc, verbose=!silent, ...)
  names(m1) <- lapply(m1, "[[", "xid")
  object$m1 <- m1
  
  # make sure if the same method is applied to all components 
  object$method <- unique(do.call(c, lapply(X=m1, "[[", "method")))
  
  # show minimal information about what inputs the user provided 
  xtrc.apriori <- unique(lapply(m1, "[[", "apriori"))
  stopifnot(length(xtrc.apriori)==1)
  if (is.null(xtrc.apriori[[1]])) {
    object$apriori <- NULL
  } else {
    object$apriori <- xtrc.apriori[[1]]
  }
  
  xtrc.B <- unique(lapply(m1, "[[", "B"))
  stopifnot(length(xtrc.B)==1)
  if (is.null(xtrc.B[[1]])) {
    object$B <- NULL
  } else {
    object$B <- xtrc.B[[1]]
  }
 
  xtrc.xi <- unique(lapply(m1, "[[", "xi"))
  stopifnot(length(xtrc.xi)==1)
  if (is.null(xtrc.xi[[1]])) {
    object$xi <- NULL
  } else {
    object$xi <- xtrc.xi[[1]]
  }
  
  invisible(object)
}
NULL