R/methods-for-batch-distribution.R

In metagen: Inference in Meta Analysis and Meta Regression

# Copyright (C) 2012-2014 Thomas W. D. Möbius (kontakt@thomasmoebius.de)
#
#     This program is free software: you can redistribute it and/or
#     modify it under the terms of the GNU General Public License as
#     published by the Free Software Foundation, either version 3 of the
#     License, or (at your option) any later version.
#
#     This program is distributed in the hope that it will be useful,
#     but WITHOUT ANY WARRANTY; without even the implied warranty of
#     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
#     General Public License for more details.
#
#     You should have received a copy of the GNU General Public License
#     along with this program. If not, see
#     <http://www.gnu.org/licenses/>.

wrapper_experimentY <- function (static, ...) {
    # static = list(n, x, b, sgnf, piv_draws)
    require(metagen)
    vec <- c(...)
    h <- vec[grep("^h[0-9]*", names(vec))]
    d <- vec[grep("^d[0-9]*", names(vec))]
    return(performance(do.call(experimentY, c(list(h=h, d=d), static))
                       , b=static$b, h=h))
}

wrapper_experimentD <- function (static, ...) {
    # static = list(n, x, b, sgnf, piv_draws)
    require(metagen)
    vec <- c(...)
    h <- vec[grep("^h[0-9]*", names(vec))]
    d <- vec[grep("^d[0-9]*", names(vec))]
    s <- vec[grep("^s[0-9]*", names(vec))]
    return(performance(do.call(experimentD, c(list(h=h, d=d, s=s),
                                              static))
                       , b=static$b, h=h))
}

#' Running a computer experiment in batch mode
#'
#' Sets up a computer experiment evaluating the performance of
#' different inference methods in the random effects meta regression
#' model.
#'
#' @param name Reference name for the experiment.
#' @param seed Random seed for the experiment.
#' @param n number of simulations to at each parameter configuration.
#' @param resolution list of number of parameter configurations in
#' each design, e.g.
#'     resolution=list(h=5L, d=3L)
#' @param bounds list of parameter bounds used for experimental
#' design, e.g.
#'     bounds=list(h=c(0,1), d=c(0.001, 2), s=c(200L, 2000L))
#' where
#'     - h : bounds of the heterogeneity.
#'     - d : bounds of the heteroscedasticity.
#'     - a : bounds of the balancing factor of group assignments.
#'     - s : bounds of the study sizes.
#'     - r : fixed risk in the control.
#' @param x         design matrix.
#' @param b         regression coefficients.
#' @param sgnf      levels of significance.
#' @param piv_draws number of pivotal draws.
#' @param ...       further arguments to makeExperimentRegistry,
#' e.g.
#'     file.dir=tempfile().
#' @return The registry.
#' @export
setupExperiment <- function(  name
                            , seed
                            , n
                            , resolution
                            , bounds
                            , x
                            , b
                            , sgnf
                            , piv_draws
                            , ...
                            ) {
    checkArg(name, "character", len=1)
    checkArg(seed, "integer", len=1, na.ok=FALSE)
    checkArg(n, "integer", len=1, na.ok=FALSE)
    checkArg(resolution, "integer", len=1, na.ok=FALSE)
    checkArg(b, "numeric", len=dim(x)[2])
    checkArg(sgnf, "numeric", min.len=2, lower=.0001, upper=.4999)
    checkArg(piv_draws, "integer", len=1, lower=2)

    reg <- makeExperimentRegistry(name, seed=seed, ...)

    addProblem(reg, "performance_evaluation"
               , static=list(n=n, x=x, b=b, sgnf=sgnf,
                             piv_draws=piv_draws))

    addAlgorithm(reg, "canonical_model", wrapper_experimentY)
    addAlgorithm(reg, "mean_response_extension", wrapper_experimentD)

    dY_ <- designY(  n=resolution
                   , h_bounds=bounds$h, d_bounds=bounds$d
                   , x=x)
    dD_ <- designD(  n=resolution
                   , h_bounds=bounds$h, d_bounds=bounds$d
                   , s_bounds=bounds$s
                   , x=x)

    dY <- makeDesign("canonical_model", dY_)
    dD <- makeDesign("mean_response_extension", dD_)
    addExperiments(reg, "performance_evaluation", dY)
    addExperiments(reg, "performance_evaluation", dD)
    return(reg)
}

#' Running a computer experiment -- Collect specific results
#'
#' Collects specific results of all finished experiments
#' in the given registry for a given pattern.
#'
#' @param reg A valid registry generated by 'makeExperimentRegistry'.
#' @param pattern string containing the algorithm pattern for which the
#' collection shall be performed.
#' @return List of data frames containing the performance measures of
#' all point and interval estimates for the heterogeneity and the
#' regression coefficients.
#' @export
collectExperiments <- function (reg, pattern) {
    fun <- function (aggr, job, res) {
          curr <- Map(function(tmp) cbind(tmp, h=job$algo.pars$h), res)
          return(Map(rbind, aggr, curr))
    }
    reduceResults(  reg=reg
                  , ids=findExperiments(  reg=reg
                                        , ids=findDone(reg)
                                        , algo.pattern=pattern)
                  , fun=fun, init=metagenEmpty())
}

#' Running a computer experiment -- Collect all the results
#'
#' Collects all the results of all finished experiments
#' in the given registry for all predefined algorithms.
#'
#' @param reg A valid registry generated by 'makeExperimentRegistry'.
#' @return List of data frames containing the performance measures of
#' all point and interval estimates for the heterogeneity and the
#' regression coefficients.
#' @export
collectAllExperiments <- function (reg) {
    return(list( resY=collectExperiments(reg, "canonical_model")
               , resD=collectExperiments(reg, "mean_response_extension")
               ))
}