https://github.com/cran/meta
Raw File
Tip revision: a3a69666ce56e739c56905c0689857bc3225cb25 authored by Guido Schwarzer on 18 May 2012, 00:00:00 UTC
version 2.1-0
Tip revision: a3a6966
metainf.R
metainf <- function(x, pooled, sortvar, level.comb=x$level.comb){
  
  if (!inherits(x, "meta"))
    stop("Argument 'x' must be an object of class \"meta\"")
  
  
  if (missing(pooled)){
    if (length(x$comb.fixed)==0 & length(x$comb.random)==0)
      pooled <- "fixed"
    if (length(x$comb.fixed)>0 & length(x$comb.random)==0)
      if (x$comb.fixed) pooled <- "fixed"
      else pooled <- "NoNe"
    if (length(x$comb.fixed)==0 & length(x$comb.random)>0)
      if (x$comb.random) pooled <- "random"
      else pooled <- "NoNe"
    if (length(x$comb.fixed)>0 & length(x$comb.random)>0){
      if (x$comb.fixed)
        pooled <- "fixed"
      if (!x$comb.fixed & x$comb.random)
        pooled <- "random"
      if (!x$comb.fixed & !x$comb.random)
        pooled <- "NoNe"
    }
  }
  ##
  if (pooled=="NoNe")
    stop("Parameters \"comb.fixed\" and \"comb.random\" in object '",
        deparse(substitute(x)),
         "' are either 'FALSE' or 'NULL'. ",
         "Please use argument \"pooled=fixed\" or \"pooled=random\" ",
         "to select meta-analytical model.")
  
  
  imeth <- charmatch(tolower(pooled), c("fixed", "random"), nomatch = NA)
  ##
  if (is.na(imeth)) 
        stop("'pooled' should be \"fixed\" or \"random\"")
  ##
  pooled <- c("fixed", "random")[imeth]
  
  
  if (length(level.comb)==0){
    warning("level.comb set to 0.95")
    level.comb <- 0.95
  }
  
  
  k.all <- length(x$TE)
  ##
  if (k.all==1){
    warning("Nothing calculated (minimum number of studies: 2)")
    return(invisible(NULL))
  }
  
  sort <- !missing(sortvar)
  
  if (!sort) sortvar <- rep(1, k.all)
  if (sort & length(sortvar) != k.all)
    stop("'x' and 'sortvar' have different length")

  
  n.e <- x$n.e
  n.c <- x$n.c
  n   <- x$n
  ##
  event.e <- x$event.e
  event.c <- x$event.c
  event   <- x$event
  ##
  mean.e <- x$mean.e
  mean.c <- x$mean.c
  ##
  sd.e <- x$sd.e
  sd.c <- x$sd.c
  ##
  cor <- x$cor
  ##
  TE <- x$TE
  seTE <- x$seTE
  ##
  studlab <- x$studlab
  sortvar <- sortvar
  
  
  if (sort){
    ##
    o <- order(sortvar)
    ##
    n.e <- n.e[o]
    n.c <- n.c[o]
    n   <- n[o]
    ##
    event.e <- event.e[o]
    event.c <- event.c[o]
    event   <- event[o]
    ##
    mean.e <- mean.e[o]
    mean.c <- mean.c[o]
    ##
    sd.e <- sd.e[o]
    sd.c <- sd.c[o]
    ##
    cor <- cor[o]
    ##
    TE <- TE[o]
    seTE <- seTE[o]
    ##
    studlab <- studlab[o]
    sortvar <- sortvar[o]
  }

  
  if (pooled == "fixed" | (pooled == "random" & !x$hakn))
    res.i <- matrix(NA, ncol=8, nrow=k.all)
  ##
  else if (pooled == "random" & x$hakn)
    res.i <- matrix(NA, ncol=9, nrow=k.all)
  ##
  for (i in 1:k.all){
    sel <- -i
    ##
    if (inherits(x, "metabin"))
      m <- metabin(event.e[sel], n.e[sel], event.c[sel], n.c[sel],
                   method=x$method, sm=x$sm,
                   incr=x$incr, allincr=x$allincr, addincr=x$addincr,
                   allstudies=x$allstudies, MH.exact=x$MH.exact,
                   RR.cochrane=x$RR.cochrane,
                   level=level.comb, level.comb=level.comb,
                   hakn=x$hakn,
                   method.tau=x$method.tau,
                   tau.preset=x$tau.preset, TE.tau=x$TE.tau,
                   warn=FALSE)
    ##
    if (inherits(x, "metacont"))
      m <- metacont(n.e[sel], mean.e[sel], sd.e[sel],
                    n.c[sel], mean.c[sel], sd.c[sel], sm=x$sm,
                    level=level.comb, level.comb=level.comb,
                    hakn=x$hakn,
                    method.tau=x$method.tau,
                    tau.preset=x$tau.preset, TE.tau=x$TE.tau)
    ##
    if (inherits(x, "metagen"))
      m <- metagen(TE[sel], seTE[sel], sm=x$sm,
                   level=level.comb, level.comb=level.comb,
                   hakn=x$hakn,
                   method.tau=x$method.tau,
                   tau.preset=x$tau.preset, TE.tau=x$TE.tau)
    ##
    if (inherits(x, "metaprop"))
      m <- metaprop(event[sel], n[sel],
                    studlab=studlab[sel],
                    sm=x$sm,
                    level=level.comb, level.comb=level.comb,
                    hakn=x$hakn,
                    method.tau=x$method.tau,
                    tau.preset=x$tau.preset, TE.tau=x$TE.tau,
                    warn=FALSE)
    ##
    if (inherits(x, "metacor"))
      m <- metacor(cor[sel], n[sel],
                   studlab=studlab[sel],
                   sm=x$sm,
                   level=level.comb, level.comb=level.comb,
                   hakn=x$hakn,
                   method.tau=x$method.tau,
                   tau.preset=x$tau.preset, TE.tau=x$TE.tau)
    ##
    s.i <- summary(m, level=level.comb, level.comb=level.comb)
    ##
    if (pooled == "fixed"){
      res.i[i,] <- c(m$TE.fixed, m$seTE.fixed,
                     s.i$fixed$lower, s.i$fixed$upper,
                     m$pval.fixed, s.i$I2$TE,
                     m$tau, sum(m$w.fixed, na.rm=TRUE))
    }
    ##
    else if (pooled == "random" & !x$hakn){
      res.i[i,] <- c(m$TE.random, m$seTE.random,
                     s.i$random$lower, s.i$random$upper,
                     m$pval.random, s.i$I2$TE,
                     m$tau, sum(m$w.random, na.rm=TRUE))
    }
    ##
    else if (pooled == "random" & x$hakn){
      res.i[i,] <- c(m$TE.random, m$seTE.random,
                     s.i$random$lower, s.i$random$upper,
                     m$pval.random, s.i$I2$TE,
                     m$tau, sum(m$w.random, na.rm=TRUE),
                     m$df.hakn)
    }
  }
  ##
  TE.i <- res.i[,1]
  seTE.i <- res.i[,2]
  lower.i <- res.i[,3]
  upper.i <- res.i[,4]
  pval.i <- res.i[,5]
  I2.i <- res.i[,6]
  tau.i <- res.i[,7]
  weight.i <- res.i[,8]
  if (pooled == "random" & x$hakn)
    df.hakn.i <- res.i[,9]
  
  
  sm1 <- summary(x, level=level.comb, level.comb=level.comb)
  ##
  if (pooled == "fixed"){
    TE.s <- sm1$fixed$TE
    seTE.s <- sm1$fixed$seTE
    TE.s.lower <- sm1$fixed$lower
    TE.s.upper <- sm1$fixed$upper
    pval.s <- sm1$fixed$p
    w.s <- sum(x$w.fixed, na.rm=TRUE)
  }
  ##
  else if (pooled == "random"){
    TE.s <- sm1$random$TE
    seTE.s <- sm1$random$seTE
    TE.s.lower <- sm1$random$lower
    TE.s.upper <- sm1$random$upper
    pval.s <- sm1$random$p
    w.s <- sum(x$w.random, na.rm=TRUE)
  }
  
  
  slab <- c(paste("Omitting", studlab), "Pooled estimate")
  
  res <- list(TE=c(TE.i, NA, TE.s),
              seTE=c(seTE.i, NA, seTE.s),
              lower=c(lower.i, NA, TE.s.lower),
              upper=c(upper.i, NA, TE.s.upper),
              studlab=c(rev(rev(slab)[-1]), " ", rev(slab)[1]),
              p.value=c(pval.i, NA, pval.s),
              w=c(weight.i, NA, w.s),
              I2=c(I2.i, NA, sm1$I2$TE),
              tau=c(tau.i, NA, sm1$tau),
              df.hakn=if (pooled=="random" & x$hakn) c(df.hakn.i, NA, x$df.hakn) else NULL,
              sm=x$sm, method=x$method, k=x$k,
              pooled=pooled,
              TE.fixed=NA, seTE.fixed=NA,
              TE.random=NA, seTE.random=NA,
              Q=NA,
              level.comb=level.comb,
              hakn=x$hakn,
              method.tau=x$method.tau,
              tau.preset=x$tau.preset,
              TE.tau=x$TE.tau)
  
  res$version <- packageDescription("meta")$Version
  
  class(res) <- c("metainf", "meta")
  if (inherits(x, "trimfill"))
    class(res) <- c(class(res), "trimfill")
  
  res
}
back to top