Raw File
vcov.rma.r
vcov.rma <- function(object, type="fixed", ...) {

   mstyle <- .get.mstyle("crayon" %in% .packages())

   if (!inherits(object, "rma"))
      stop(mstyle$stop("Argument 'object' must be an object of class \"rma\"."))

   na.act <- getOption("na.action")

   if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass")))
      stop(mstyle$stop("Unknown 'na.action' specified under options()."))

   type <- match.arg(type, c("fixed", "obs", "fitted", "resid"))

   #########################################################################

   if (type=="fixed") {

      out <- object$vb

      if (inherits(object, "rma.ls"))
         out <- list(beta = object$vb, alpha = object$vb.alpha)

      return(out)

   }

   #########################################################################

   if (type=="obs") {

      if (inherits(object, c("rma.uni","rma.mv"))) {

         if (na.act == "na.omit")
            return(object$M)

         if (na.act == "na.pass" || na.act == "na.exclude") {
            M <- matrix(NA_real_, nrow=object$k.f, ncol=object$k.f)
            M[object$not.na,object$not.na] <- object$M
            return(M)
         }

         if (na.act == "na.fail" && any(!object$not.na))
            stop(mstyle$stop("Missing values in data."))

      } else {

         stop(mstyle$stop("Extraction of marginal var-cov matrix not available for objects of this class."))

      }

   }

   #########################################################################

   if (type=="fitted") {

      out <- object$X.f %*% object$vb %*% t(object$X.f)

      #rownames(out) <- colnames(out) <- object$slab

      if (na.act == "na.omit")
         out <- out[object$not.na, object$not.na]

      if (na.act == "na.exclude") {
         out[!object$not.na,] <- NA
         out[,!object$not.na] <- NA
      }

      return(out)

   }

   #########################################################################

   if (type=="resid") {

      options(na.action="na.omit")
      H <- hatvalues(object, type="matrix")
      options(na.action = na.act)

      ImH <- diag(object$k) - H

      if (inherits(object, "robust.rma")) {
         ve <- ImH %*% tcrossprod(object$meat,ImH)
      } else {
         ve <- ImH %*% tcrossprod(object$M,ImH)
      }

      if (na.act == "na.omit")
         out <- ve

      if (na.act == "na.exclude" || na.act == "na.pass") {
         out <- matrix(NA_real_, nrow=object$k.f, ncol=object$k.f)
         out[object$not.na, object$not.na] <- ve
      }

      return(out)

   }

   #########################################################################

}
back to top