metafor: Meta-Analysis Package for R

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

"[.escalc" <- function(x, i, ...) {

   mf <- paste0(deparse1(match.call()), collapse="")
   has.drop <- grepl("drop = T", mf, fixed=TRUE) || grepl("drop = F", mf, fixed=TRUE)

   if (!missing(i) && nargs()-has.drop > 2L) {
      mf <- match.call()
      i <- .getx("i", mf=mf, data=x)
      # TODO: enable this?
      # treat missings in a logical vector as FALSE when selecting rows
      #if (is.logical(i) && length(i) == nrow(x))
      #   i[is.na(i)] <- FALSE
   }

   dat <- NextMethod("[")

   ### find all 'yi' variables that are still part of the dataset

   yi.names <- attr(x, "yi.names")
   yi.names <- yi.names[is.element(yi.names, names(dat))]

   for (l in seq_along(yi.names)) {

      ### if selecting rows, subset ni and slab attributes accordingly and add them back to each yi variable

      if (!missing(i) && nargs()-has.drop > 2L) {
         attr(dat[[yi.names[l]]], "ni")   <- attr(x[[yi.names[l]]], "ni")[i]
         attr(dat[[yi.names[l]]], "slab") <- attr(x[[yi.names[l]]], "slab")[i]
      }

      ### add measure attribute back to each yi variable

      attr(dat[[yi.names[l]]], "measure") <- attr(x[[yi.names[l]]], "measure")

   }

   ### add var.names and out.names attributes back to object (but only if they exist and only keep variables still in the dataset)

   all.names <- c("yi.names", "vi.names", "sei.names", "zi.names", "pval.names", "ci.lb.names", "ci.ub.names")

   for (l in seq_along(all.names)) {
      if (any(is.element(attr(x, all.names[l]), names(dat)))) # check if any of the variables still exist in the dataset
         attr(dat, all.names[l]) <- attr(x, all.names[l])[is.element(attr(x, all.names[l]), names(dat))]
   }

   ### add digits attribute back to object (but not to vectors)

   if (!is.null(attr(x, "digits")) && !is.null(dim(dat)))
      attr(dat, "digits") <- attr(x, "digits")

   return(dat)

}

"$<-.escalc" <- function(x, name, value) {

   dat <- NextMethod("$<-")

   ### for each attribute, only keep elements that are still part of the data frame (and remove empty attributes)
   ### (this is relevant when 'value' is NULL, so when a particular variable is getting removed)

   all.names <- c("yi.names", "vi.names", "sei.names", "zi.names", "pval.names", "ci.lb.names", "ci.ub.names")

   for (l in seq_along(all.names)) {
      if (!is.null(attr(dat, all.names[l]))) {
         attr(dat, all.names[l]) <- attr(dat, all.names[l])[is.element(attr(dat, all.names[l]), names(dat))]
         if (length(attr(dat, all.names[l])) == 0L)
            attr(dat, all.names[l]) <- NULL
      }
   }

   return(dat)

}

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

cbind.escalc <- function (..., deparse.level=1) {

   dat <- data.frame(..., check.names = FALSE)

   allargs <- list(...)

   ### for each element, extract the 'var.names' and 'out.names' attributes and add entire set back to the object

   yi.names    <- NULL
   vi.names    <- NULL
   sei.names   <- NULL
   zi.names    <- NULL
   pval.names  <- NULL
   ci.lb.names <- NULL
   ci.ub.names <- NULL

   for (arg in allargs) {
      yi.names    <- c(attr(arg, "yi.names"),    yi.names)
      vi.names    <- c(attr(arg, "vi.names"),    vi.names)
      sei.names   <- c(attr(arg, "sei.names"),   sei.names)
      zi.names    <- c(attr(arg, "zi.names"),    zi.names)
      pval.names  <- c(attr(arg, "pval.names"),  pval.names)
      ci.lb.names <- c(attr(arg, "ci.lb.names"), ci.lb.names)
      ci.ub.names <- c(attr(arg, "ci.ub.names"), ci.ub.names)
   }

   ### but only keep unique variable names

   attr(dat, "yi.names")    <- unique(yi.names)
   attr(dat, "vi.names")    <- unique(vi.names)
   attr(dat, "sei.names")   <- unique(sei.names)
   attr(dat, "zi.names")    <- unique(zi.names)
   attr(dat, "pval.names")  <- unique(pval.names)
   attr(dat, "ci.lb.names") <- unique(ci.lb.names)
   attr(dat, "ci.ub.names") <- unique(ci.ub.names)

   ### add 'digits' attribute back (use the values from first element)

   attr(dat, "digits") <- attr(arg[1], "digits")

   class(dat) <- c("escalc", "data.frame")
   return(dat)

}

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

rbind.escalc <- function (..., deparse.level=1) {

   dat <- rbind.data.frame(..., deparse.level = deparse.level)

   allargs <- list(...)

   yi.names <- attr(dat, "yi.names")
   yi.names <- yi.names[is.element(yi.names, names(dat))]

   for (i in seq_along(yi.names)) {

      ### get position (column number) of the 'yi' variable (in the first argument)
      #yi.pos <- which(names(allargs[[1]]) == yi.names[i])

      ### get position (column number) of the 'yi' variable
      yi.pos <- sapply(allargs, function(x) which(names(x) == yi.names[i])[1])
      yi.pos <- na.omit(yi.pos)[1]

      ### just in case
      if (length(yi.pos) == 0L)
         next

      ### get 'ni' attribute from all arguments (but only if argument has 'yi' variable)
      ni <- lapply(allargs, function(x) {if (isTRUE(names(x)[yi.pos] == yi.names[i])) attr(x[[yi.pos]], "ni")})

      ### if none of them are missing, then combine and add back to variable
      ### otherwise remove 'ni' attribute, since it won't be of the right length
      if (all(sapply(ni, function(x) !is.null(x)))) {
         attr(dat[[yi.pos]], "ni") <- unlist(ni)
      } else {
         attr(dat[[yi.pos]], "ni") <- NULL
      }

      ### get 'slab' attribute from all arguments (but only if argument has 'yi' variable)
      slab <- lapply(allargs, function(x) {if (isTRUE(names(x)[yi.pos] == yi.names[i])) attr(x[[yi.pos]], "slab")})

      ### if none of them are missing, then combine and add back to variable (and make sure they are unique)
      ### otherwise remove 'slab' attribute, since it won't be of the right length
      if (all(sapply(slab, function(x) !is.null(x)))) {
         attr(dat[[yi.pos]], "slab") <- .make.unique(unlist(slab))
      } else {
         attr(dat[[yi.pos]], "slab") <- NULL
      }

   }

   return(dat)

}

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

#as.data.frame.escalc <- function(x, row.names=NULL, optional=FALSE, ...) {
#
#   ### strip measure, ni, and slab attributes from any yi elements
#
#   yi.names <- attr(x, "yi.names")
#   yi.names <- yi.names[is.element(yi.names, names(x))]
#
#   for (l in seq_along(yi.names)) {
#
#      attr(x[[yi.names[l]]], "measure") <- NULL
#      attr(x[[yi.names[l]]], "ni")      <- NULL
#      attr(x[[yi.names[l]]], "slab")    <- NULL
#
#   }
#
#   ### strip other attributes that may be part of an 'escalc' object
#
#   attr(x, "digits")      <- NULL
#
#   attr(x, "yi.names")    <- NULL
#   attr(x, "vi.names")    <- NULL
#   attr(x, "sei.names")   <- NULL
#   attr(x, "zi.names")    <- NULL
#   attr(x, "pval.names")  <- NULL
#   attr(x, "ci.lb.names") <- NULL
#   attr(x, "ci.ub.names") <- NULL
#
#   class(x) <- "data.frame"
#
#   return(x)
#
#}

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