Nothing
# 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")
))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.