├── gemtc ├── R │ ├── forest.R │ ├── stopIfNotConsistent.R │ ├── ll.call.R │ ├── template.R │ ├── mtc.model.use.R │ ├── ll-helper.counts.R │ ├── likelihoods.R │ ├── ll.normal.identity.R │ ├── mtc.data.studyrow.R │ ├── solveLP.R │ ├── arrayize.R │ ├── mtc.hy.prior.R │ ├── rank.probability.R │ ├── ll.binom.log.R │ ├── ll.binom.logit.R │ ├── mtc.model.consistency.R │ ├── ll.binom.cloglog.R │ ├── mtc.network.xml.R │ ├── priors.R │ ├── regression.R │ ├── ll.poisson.log.R │ ├── plotCovariateEffect.R │ ├── relative.effect.table.R │ ├── mtc.run.R │ ├── code.R │ ├── mtc.result.R │ └── data.R ├── src │ ├── Makevars │ ├── gemtc-win.def │ ├── gemtc.h │ ├── init.c │ └── rank.c ├── tests │ ├── test.R │ ├── data │ │ ├── studyrow │ │ │ ├── tsd2-8.data2.txt │ │ │ ├── tsd2-8.data1.txt │ │ │ ├── tsd2-8.out1.txt │ │ │ ├── tsd2-8.out2.txt │ │ │ ├── tsd2-5.data.txt │ │ │ ├── tsd2-7.data.txt │ │ │ ├── tsd2-5.out.txt │ │ │ ├── tsd2-2.data.txt │ │ │ ├── tsd2-1.data.txt │ │ │ ├── tsd2-7.out.txt │ │ │ ├── tsd2-2.out.txt │ │ │ ├── tsd2-3.data.txt │ │ │ ├── tsd2-1.out.txt │ │ │ └── tsd2-3.out.txt │ │ ├── rr-pairwise.csv │ │ ├── riskratio.data.txt │ │ ├── riskratio.summaries.txt │ │ ├── smoking-ume.data.txt │ │ ├── dietfat.fe.summaries.txt │ │ ├── welton-diastolic.summaries.txt │ │ ├── welton-systolic.summaries.txt │ │ ├── welton-cholesterol.summaries.txt │ │ ├── dietfat.re.summaries.txt │ │ ├── diabetes-surv.data.txt │ │ ├── luades-smoking.summaries.txt │ │ ├── welton-systolic.gemtc │ │ ├── welton-diastolic.gemtc │ │ ├── smoking-ume.summaries.txt │ │ ├── ns-complex.csv │ │ ├── parkinson.summaries.txt │ │ ├── parkinson-diff.summaries.txt │ │ ├── parkinson-shared.summaries.txt │ │ ├── diabetes-surv.fe.summaries.txt │ │ ├── diabetes-surv.summaries.txt │ │ └── welton-cholesterol.gemtc │ └── testthat │ │ ├── test-validate-parkinson.R │ │ ├── test-validate-cipriani-efficacy.R │ │ ├── test-validate-dietfat-fe.R │ │ ├── test-validate-parkinson-diff.R │ │ ├── test-validate-dietfat-re.R │ │ ├── test-validate-parkinson-shared.R │ │ ├── test-validate-luades-smoking.R │ │ ├── test-validate-luades-thrombolytic.R │ │ ├── test-unit-sucra.R │ │ ├── test-validate-diabetes-surv.R │ │ ├── test-validate-welton-systolic.R │ │ ├── test-validate-welton-diastolic.R │ │ ├── test-validate-diabetes-surv-fe.R │ │ ├── test-validate-smoking-ume.R │ │ ├── test-validate-welton-cholesterol.R │ │ ├── test-unit-mtc.model.graph.R │ │ ├── test-unit-rank.quantiles.R │ │ ├── test-unit-mtc.model_duparm.R │ │ ├── test-unit-read.mtc.network.R │ │ ├── test-validate-riskratio.R │ │ ├── test-unit-mtc.model.use.R │ │ ├── test-unit-mtc.study.treatment.matrix.R │ │ ├── test-unit-arrayize.R │ │ ├── test-unit-mtc.nr.comparisons.R │ │ ├── test-regress-anohe.R │ │ ├── test-unit-ll.R │ │ ├── test-unit-mtc.model.nodesplit.R │ │ ├── test-unit-template.R │ │ ├── test-unit-mtc.model.consistency.R │ │ ├── test-unit-decompose.R │ │ ├── test-unit-inits.to.monitors.R │ │ ├── test-unit-relative.effect.table.R │ │ ├── test-unit-regression.R │ │ ├── test-unit-mtc.hy.prior.R │ │ ├── test-unit-mtc.model_columns.R │ │ ├── test-unit-has.indirect.evidence.R │ │ ├── test-unit-studyrow.R │ │ ├── test-unit-ll.binom.log.R │ │ ├── test-unit-ll.poisson.log.R │ │ └── test-unit-allpairs.R ├── data │ ├── blocker.rdata │ ├── dietfat.rdata │ ├── smoking.rdata │ ├── depression.rdata │ ├── parkinson.rdata │ ├── certolizumab.rdata │ ├── hfPrevention.rdata │ ├── thrombolytic.rdata │ ├── parkinson-diff.rdata │ ├── atrialFibrillation.rdata │ └── parkinson-shared.rdata ├── man │ ├── figures │ │ ├── parkinson.pdf │ │ └── parkinson.png │ ├── depression.Rd │ ├── smoking.Rd │ ├── blocker.Rd │ ├── dietfat.Rd │ ├── thrombolytic.Rd │ ├── parkinson.Rd │ ├── hfPrevention.Rd │ ├── read.mtc.network.Rd │ ├── certolizumab.Rd │ ├── mtc.deviance.Rd │ ├── plotCovariateEffect.Rd │ ├── atrialFibrillation.Rd │ ├── relative.effect.table.Rd │ ├── relative.effect.Rd │ ├── ll.call.Rd │ ├── mtc.anohe.Rd │ ├── mtc.hy.prior.Rd │ ├── mtc.data.studyrow.Rd │ ├── rank.probability.Rd │ └── mtc.nodesplit.Rd ├── inst │ ├── extdata │ │ ├── parkinson.ns.rds │ │ ├── luades-smoking.samples.gz │ │ └── parkinson.gemtc │ ├── gemtc.armeffect.likelihood.txt │ ├── gemtc.likelihood.poisson.txt │ ├── gemtc.fixedeffect.txt │ ├── gemtc.likelihood.normal.txt │ ├── gemtc.likelihood.normal.power.txt │ ├── gemtc.likelihood.poisson.power.txt │ ├── gemtc.likelihood.binom.txt │ ├── gemtc.releffect.likelihood.r2.txt │ ├── gemtc.releffect.likelihood.power.r2.txt │ ├── gemtc.likelihood.binom.power.txt │ ├── gemtc.model.use.template.txt │ ├── gemtc.randomeffects.txt │ ├── gemtc.model.template.txt │ ├── gemtc.releffect.likelihood.rm.txt │ └── gemtc.releffect.likelihood.power.rm.txt ├── DESCRIPTION └── NAMESPACE ├── .gitignore ├── .travis.yml ├── run-tests.sh ├── run-tests.R ├── afstroke-treatments.csv ├── classes-example.R ├── Makefile ├── afstroke-data.csv └── README.md /gemtc/R/forest.R: -------------------------------------------------------------------------------- 1 | forest <- function(x, ...) 2 | UseMethod("forest") 3 | -------------------------------------------------------------------------------- /gemtc/src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_CFLAGS=$(C_VISIBILITY) 2 | OBJECTS=init.o rank.o 3 | -------------------------------------------------------------------------------- /gemtc/src/gemtc-win.def: -------------------------------------------------------------------------------- 1 | LIBRARY gemtc.dll 2 | EXPORTS 3 | R_init_gemtc 4 | -------------------------------------------------------------------------------- /gemtc/tests/test.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | test_check('gemtc', filter="unit") 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | tmp.Rlib.loc 2 | gemtc.Rcheck 3 | *.swp 4 | gemtc_*.tar.gz 5 | *.so 6 | *.o 7 | -------------------------------------------------------------------------------- /gemtc/data/blocker.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/blocker.rdata -------------------------------------------------------------------------------- /gemtc/data/dietfat.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/dietfat.rdata -------------------------------------------------------------------------------- /gemtc/data/smoking.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/smoking.rdata -------------------------------------------------------------------------------- /gemtc/data/depression.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/depression.rdata -------------------------------------------------------------------------------- /gemtc/data/parkinson.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/parkinson.rdata -------------------------------------------------------------------------------- /gemtc/data/certolizumab.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/certolizumab.rdata -------------------------------------------------------------------------------- /gemtc/data/hfPrevention.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/hfPrevention.rdata -------------------------------------------------------------------------------- /gemtc/data/thrombolytic.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/thrombolytic.rdata -------------------------------------------------------------------------------- /gemtc/src/gemtc.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | SEXP gemtc_rank_count(SEXP _t); 5 | -------------------------------------------------------------------------------- /gemtc/data/parkinson-diff.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/parkinson-diff.rdata -------------------------------------------------------------------------------- /gemtc/man/figures/parkinson.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/man/figures/parkinson.pdf -------------------------------------------------------------------------------- /gemtc/man/figures/parkinson.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/man/figures/parkinson.png -------------------------------------------------------------------------------- /gemtc/data/atrialFibrillation.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/atrialFibrillation.rdata -------------------------------------------------------------------------------- /gemtc/data/parkinson-shared.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/data/parkinson-shared.rdata -------------------------------------------------------------------------------- /gemtc/inst/extdata/parkinson.ns.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/inst/extdata/parkinson.ns.rds -------------------------------------------------------------------------------- /gemtc/inst/gemtc.armeffect.likelihood.txt: -------------------------------------------------------------------------------- 1 | for (i in studies.a) { 2 | for (k in 1:na[i]) { 3 | $likelihood$ 4 | } 5 | } 6 | -------------------------------------------------------------------------------- /gemtc/inst/extdata/luades-smoking.samples.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gertvv/gemtc/HEAD/gemtc/inst/extdata/luades-smoking.samples.gz -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | before_install: 3 | - cd gemtc 4 | addons: 5 | apt: 6 | packages: 7 | - libglpk-dev 8 | - jags 9 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.likelihood.poisson.txt: -------------------------------------------------------------------------------- 1 | r[i, k] ~ dpois(theta[i, k]) 2 | 3 | dev[i, k] <- 2 * ((theta[i, k] - r[i, k]) + r[i, k] * log(r[i, k]/theta[i, k])) 4 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.fixedeffect.txt: -------------------------------------------------------------------------------- 1 | # Fixed effect model 2 | for (i in studies) { 3 | delta[i, 1] <- 0 4 | for (k in 2:na[i]) { 5 | delta[i, k] <- d[t[i, 1], t[i, k]] 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.likelihood.normal.txt: -------------------------------------------------------------------------------- 1 | m[i, k] ~ dnorm(theta[i, k], prec[i, k]) 2 | prec[i, k] <- 1 / (e[i, k] * e[i, k]) 3 | 4 | dev[i, k] <- pow(m[i, k] - theta[i, k], 2) * prec[i, k] 5 | -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | DIR=`mktemp -d -t gemtc.XXXXXX` 4 | $1 CMD INSTALL -l $DIR --install-tests $2 5 | 6 | $1 --vanilla --slave --file=run-tests.R --args $DIR $3 $4 7 | rm -rf $DIR 8 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.likelihood.normal.power.txt: -------------------------------------------------------------------------------- 1 | m[i, k] ~ dnorm(theta[i, k], prec[i, k]) 2 | prec[i, k] <- alpha[i] / (e[i, k] * e[i, k]) 3 | 4 | dev[i, k] <- pow(m[i, k] - theta[i, k], 2) * prec[i, k] 5 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-8.data2.txt: -------------------------------------------------------------------------------- 1 | t[,1] t[,2] y[,2] se[,2] na[] # study 2 | 3 4 -0.35 0.441941738 2 # 4 3 | 3 4 0.55 0.555114559 2 # 5 4 | 4 5 -0.3 0.274276316 2 # 6 5 | 4 5 -0.3 0.320087245 2 # 7 6 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.likelihood.poisson.power.txt: -------------------------------------------------------------------------------- 1 | zero[i, k] ~ dpois(phi[i, k]) 2 | phi[i, k] <- 1E6 - alpha[i] * (r[i, k] * log(theta[i, k]) - theta[i, k]) 3 | 4 | dev[i, k] <- alpha[i] * 2 * ((theta[i, k] - r[i, k]) + r[i, k] * log(r[i, k]/theta[i, k])) 5 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.likelihood.binom.txt: -------------------------------------------------------------------------------- 1 | r[i, k] ~ dbin(p[i, k], n[i, k]) 2 | 3 | rhat[i, k] <- p[i, k] * n[i, k] 4 | dev[i, k] <- 2 * 5 | (r[i, k] * (log(r[i, k]) - log(rhat[i, k])) + 6 | (n[i, k]-r[i, k]) * (log(n[i, k] - r[i, k]) - log(n[i, k] - rhat[i, k]))) 7 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-8.data1.txt: -------------------------------------------------------------------------------- 1 | t.a[,1] t.a[,2] t.a[,3] y.a[,1] y.a[,2] y.a[,3] se.a[,1] se.a[,2] se.a[,3] na.a[] # study 2 | 1 3 NA -1.22 -1.53 NA 0.504 0.439 NA 2 # 1 3 | 1 2 NA -0.7 -2.4 NA 0.282 0.258 NA 2 # 2 4 | 1 2 4 -0.3 -2.6 -1.2 0.505 0.510 0.478 3 # 3 5 | -------------------------------------------------------------------------------- /gemtc/tests/data/rr-pairwise.csv: -------------------------------------------------------------------------------- 1 | "","study","treatment","sampleSize","responders" 2 | "9","Rudolph and Feiger, 1999",12,100,57 3 | "11","Rudolph and Feiger, 1999",10,98,41 4 | "18","Silverstone and Ravindran, 1999",12,128,84 5 | "20","Silverstone and Ravindran, 1999",10,119,50 6 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-parkinson.R: -------------------------------------------------------------------------------- 1 | context("[validate] NICE TSD2 program 5a") 2 | 3 | test_that("The summaries match", { 4 | result <- replicate.example("parkinson", parkinson, likelihood="normal", link="identity") 5 | compare.summaries(result$s1, result$s2) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-cipriani-efficacy.R: -------------------------------------------------------------------------------- 1 | context("[validate] Efficacy data from Cipriani et al. Lancet 2009;373:746-758") 2 | 3 | test_that("The summaries match", { 4 | result <- replicate.example("cipriani-efficacy", depression) 5 | compare.summaries(result$s1, result$s2) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-dietfat-fe.R: -------------------------------------------------------------------------------- 1 | context("[validate] NICE TSD2 program 2b") 2 | 3 | test_that("The summaries match", { 4 | result <- replicate.example("dietfat.fe", dietfat, likelihood="poisson", link="log", linearModel="fixed") 5 | compare.summaries(result$s1, result$s2) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-parkinson-diff.R: -------------------------------------------------------------------------------- 1 | context("[validate] NICE TSD2 program 7a") 2 | 3 | test_that("The summaries match", { 4 | result <- replicate.example("parkinson-diff", parkinson_diff, likelihood="normal", link="identity") 5 | compare.summaries(result$s1, result$s2) 6 | }) 7 | -------------------------------------------------------------------------------- /run-tests.R: -------------------------------------------------------------------------------- 1 | args <- commandArgs(trailingOnly=TRUE) 2 | 3 | library(gemtc, lib.loc=args[1]) 4 | library(testthat) 5 | setwd(paste0(args[1], '/gemtc/tests')) 6 | if (length(args) > 2 && args[3] == "powerAdjust") { 7 | powerAdjustMode <- TRUE 8 | } 9 | test_check('gemtc', filter=args[2]) 10 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-dietfat-re.R: -------------------------------------------------------------------------------- 1 | context("[validate] NICE TSD2 program 2a") 2 | 3 | test_that("The summaries match", { 4 | result <- replicate.example("dietfat.re", dietfat, likelihood="poisson", link="log", linearModel="random") 5 | compare.summaries(result$s1, result$s2) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-parkinson-shared.R: -------------------------------------------------------------------------------- 1 | context("[validate] NICE TSD2 program 8a") 2 | 3 | test_that("The summaries match", { 4 | result <- replicate.example("parkinson-shared", parkinson_shared, likelihood="normal", link="identity") 5 | compare.summaries(result$s1, result$s2) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.releffect.likelihood.r2.txt: -------------------------------------------------------------------------------- 1 | for(i in studies.r2) { 2 | for (k in 2:na[i]) { 3 | mest[i, k] <- $relLinearModel$ 4 | } 5 | m[i, 2] ~ dnorm(mest[i, 2], prec[i, 2]) 6 | prec[i, 2] <- 1 / (e[i, 2] * e[i, 2]) 7 | 8 | dev[i, 1] <- pow(m[i, 2] - mest[i, 2], 2) * prec[i, 2] 9 | } 10 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.releffect.likelihood.power.r2.txt: -------------------------------------------------------------------------------- 1 | for(i in studies.r2) { 2 | for (k in 2:na[i]) { 3 | mest[i, k] <- $relLinearModel$ 4 | } 5 | m[i, 2] ~ dnorm(mest[i, 2], prec[i, 2]) 6 | prec[i, 2] <- alpha[i] / (e[i, 2] * e[i, 2]) 7 | 8 | dev[i, 1] <- pow(m[i, 2] - mest[i, 2], 2) * prec[i, 2] 9 | } 10 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-luades-smoking.R: -------------------------------------------------------------------------------- 1 | context("[validate] Smoking cessation data from Lu & Ades, J Am Stat Assoc 2006;101(474):447-459, Table 1") 2 | 3 | test_that("The summaries match", { 4 | result <- replicate.example("luades-smoking", smoking) 5 | compare.summaries(result$s1, result$s2) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-luades-thrombolytic.R: -------------------------------------------------------------------------------- 1 | context("[validate] Thrombolytic drugs data from Lu & Ades, J Am Stat Assoc 2006;101(474):447-459, Table 3") 2 | 3 | test_that("The summaries match", { 4 | result <- replicate.example("luades-thrombolytic", thrombolytic) 5 | compare.summaries(result$s1, result$s2) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-sucra.R: -------------------------------------------------------------------------------- 1 | context("sucra") 2 | 3 | test_that("SUCRA is implemented correctly", { 4 | ranks <- matrix(c(1/4, 1/4, 1/4, 1/4, 1/2, 1/4, 1/4, 0, 1/4, 1/2, 1/4, 0, 0, 0, 1/4, 3/4), nrow=4, byrow=TRUE, dimnames=list(c("A", "B", "C", "D"), NULL)) 5 | expect_equal(sucra(ranks), c(A=1/2, B=3/4, C=2/3, D=1/12)) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-8.out1.txt: -------------------------------------------------------------------------------- 1 | structure(list(study = c("1", "1", "2", "2", "3", "3", "3"), 2 | treatment = c("1", "3", "1", "2", "1", "2", "4"), mean = c(-1.22, 3 | -1.53, -0.7, -2.4, -0.3, -2.6, -1.2), std.err = c(0.504, 4 | 0.439, 0.282, 0.258, 0.505, 0.51, 0.478)), row.names = c(NA, 5 | -7L), class = "data.frame") 6 | -------------------------------------------------------------------------------- /gemtc/tests/data/riskratio.data.txt: -------------------------------------------------------------------------------- 1 | study treatment responders sampleSize 2 | MRC-1 A 67 624 3 | MRC-1 B 49 615 4 | CDP A 64 771 5 | CDP B 44 758 6 | MRC-2 A 126 850 7 | MRC-2 B 102 832 8 | GASP A 38 309 9 | GASP B 32 317 10 | PARIS A 52 406 11 | PARIS B 85 810 12 | AMIS A 219 2257 13 | AMIS B 246 2267 14 | ISIS-2 A 1720 8600 15 | ISIS-2 B 1570 8587 16 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-8.out2.txt: -------------------------------------------------------------------------------- 1 | structure(list(study = c("4", "4", "5", "5", "6", "6", "7", "7" 2 | ), treatment = c("3", "4", "3", "4", "4", "5", "4", "5"), diff = c(NA, 3 | -0.35, NA, 0.55, NA, -0.3, NA, -0.3), std.err = c(NA, 0.441941738, 4 | NA, 0.555114559, NA, 0.274276316, NA, 0.320087245)), row.names = c(NA, 5 | -8L), class = "data.frame") 6 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.likelihood.binom.power.txt: -------------------------------------------------------------------------------- 1 | zero[i, k] ~ dpois(phi[i, k]) 2 | phi[i, k] <- 1E6 - alpha[i] * (r[i, k] * log(p[i, k]) + (n[i, k] - r[i, k]) * log(1 - p[i, k])) 3 | 4 | rhat[i, k] <- p[i, k] * n[i, k] 5 | dev[i, k] <- alpha[i] * 2 * 6 | (r[i, k] * (log(r[i, k]) - log(rhat[i, k])) + 7 | (n[i, k]-r[i, k]) * (log(n[i, k] - r[i, k]) - log(n[i, k] - rhat[i, k]))) 8 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-diabetes-surv.R: -------------------------------------------------------------------------------- 1 | context("[validate] NICE TSD2 program 3a") 2 | 3 | test_that("The summaries match", { 4 | network <- mtc.network(data.ab=read.table('../data/diabetes-surv.data.txt', header=TRUE)) 5 | result <- replicate.example("diabetes-surv", network, likelihood="binom", link="cloglog") 6 | compare.summaries(result$s1, result$s2) 7 | }) 8 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-welton-systolic.R: -------------------------------------------------------------------------------- 1 | context("[validate] Welton et al., Am J Epidemiol 2009;169:1158-1165 Systolic BP") 2 | 3 | test_that("The summaries match", { 4 | network <- read.mtc.network('../data/welton-systolic.gemtc') 5 | result <- replicate.example("welton-systolic", network, likelihood="normal", link="identity") 6 | compare.summaries(result$s1, result$s2) 7 | }) 8 | -------------------------------------------------------------------------------- /gemtc/R/stopIfNotConsistent.R: -------------------------------------------------------------------------------- 1 | #' Stop if the results were not derived from an internally consistent model type 2 | stopIfNotConsistent <- function(result, method) { 3 | allowedTypes <- c('consistency', 'regression') 4 | if (!(tolower(result[['model']][['type']]) %in% allowedTypes)) stop(paste("Can only apply", method, "to models of the following types:", paste(allowedTypes, collapse=", "))) 5 | } 6 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-5.data.txt: -------------------------------------------------------------------------------- 1 | t[,1] t[,2] t[,3] y[,1] y[,2] y[,3] se[,1] se[,2] se[,3] na[] 2 | 1 3 NA -1.22 -1.53 NA 0.504 0.439 NA 2 3 | 1 2 NA -0.7 -2.4 NA 0.282 0.258 NA 2 4 | 1 2 4 -0.3 -2.6 -1.2 0.505 0.510 0.478 3 5 | 3 4 NA -0.24 -0.59 NA 0.265 0.354 NA 2 6 | 3 4 NA -0.73 -0.18 NA 0.335 0.442 NA 2 7 | 4 5 NA -2.2 -2.5 NA 0.197 0.190 NA 2 8 | 4 5 NA -1.8 -2.1 NA 0.200 0.250 NA 2 9 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-welton-diastolic.R: -------------------------------------------------------------------------------- 1 | context("[validate] Welton et al., Am J Epidemiol 2009;169:1158-1165 Diastolic BP") 2 | 3 | test_that("The summaries match", { 4 | network <- read.mtc.network('../data/welton-diastolic.gemtc') 5 | result <- replicate.example("welton-diastolic", network, likelihood="normal", link="identity") 6 | compare.summaries(result$s1, result$s2) 7 | }) 8 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-diabetes-surv-fe.R: -------------------------------------------------------------------------------- 1 | context("[validate] NICE TSD2 program 3b") 2 | 3 | test_that("The summaries match", { 4 | network <- mtc.network(data.ab=read.table('../data/diabetes-surv.data.txt', header=TRUE)) 5 | result <- replicate.example("diabetes-surv.fe", network, likelihood="binom", link="cloglog", linearModel="fixed") 6 | compare.summaries(result$s1, result$s2) 7 | }) 8 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-smoking-ume.R: -------------------------------------------------------------------------------- 1 | context("[validate] Modified from NICE TSD4 smoking example") 2 | 3 | test_that("The summaries match", { 4 | network <- mtc.network(data.ab=read.table('../data/smoking-ume.data.txt', header=TRUE)) 5 | result <- replicate.example("smoking-ume", network, likelihood="binom", link="logit", type="ume") 6 | compare.summaries(result$s1, result$s2) 7 | }) 8 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-welton-cholesterol.R: -------------------------------------------------------------------------------- 1 | context("[validate] Welton et al., Am J Epidemiol 2009;169:1158-1165 Cholesterol") 2 | 3 | test_that("The summaries match", { 4 | network <- read.mtc.network('../data/welton-cholesterol.gemtc') 5 | result <- replicate.example("welton-cholesterol", network, likelihood="normal", link="identity") 6 | compare.summaries(result$s1, result$s2) 7 | }) 8 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.model.graph.R: -------------------------------------------------------------------------------- 1 | context("mtc.model.graph") 2 | 3 | test_that("Vertices agree between mtc.comparisons and the model tree", { 4 | network <- thrombolytic 5 | model <- mtc.model(network) 6 | graph <- mtc.network.graph(network) 7 | expect_that(V(model$tree)$name, equals(V(graph)$name)) 8 | expect_that(V(mtc.model.graph(model))$name, equals(V(graph)$name)) 9 | }) 10 | -------------------------------------------------------------------------------- /gemtc/src/init.c: -------------------------------------------------------------------------------- 1 | #include "gemtc.h" 2 | #include 3 | 4 | static const R_CallMethodDef callMethods[] = { 5 | { "gemtc_rank_count", (DL_FUNC) &gemtc_rank_count, 1 }, 6 | { NULL, NULL, 0 } 7 | }; 8 | 9 | void attribute_visible R_init_gemtc(DllInfo *dll) { 10 | R_registerRoutines(dll, NULL, callMethods, NULL, NULL); 11 | R_useDynamicSymbols(dll, FALSE); 12 | R_forceSymbols(dll, TRUE); 13 | } 14 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-7.data.txt: -------------------------------------------------------------------------------- 1 | t[,1] t[,2] t[,3] y[,2] y[,3] se[,2] se[,3] na[] V[] 2 | 1 3 NA -0.31 NA 0.668089651 NA 2 0.253518519 3 | 1 2 NA -1.7 NA 0.382640605 NA 2 0.079593023 4 | 3 4 NA -0.35 NA 0.441941738 NA 2 0.0703125 5 | 3 4 NA 0.55 NA 0.555114559 NA 2 0.1125 6 | 4 5 NA -0.3 NA 0.274276316 NA 2 0.038949635 7 | 4 5 NA -0.3 NA 0.320087245 NA 2 0.039937662 8 | 1 2 4 -2.3 -0.9 0.71774604 0.694988091 3 0.254736842 9 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-rank.quantiles.R: -------------------------------------------------------------------------------- 1 | context("rank.quantiles") 2 | 3 | test_that("rank.quantiles is implemented correctly", { 4 | ranks <- matrix(c(1/4, 1/4, 1/4, 1/4, 1/2, 1/4, 1/4, 0, 1/4, 1/2, 1/4, 0, 0, 0, 1/4, 3/4), nrow=4, byrow=TRUE, dimnames=list(c("A", "B", "C", "D"), NULL)) 5 | expect_equal(rank.quantiles(ranks), matrix(c(1,2,4,1,1,3,1,2,3,3,4,4), nrow=4, byrow=TRUE, dimnames=list(c("A", "B", "C", "D"), c("2.5%", "50%", "97.5%")))) 6 | }) 7 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.model_duparm.R: -------------------------------------------------------------------------------- 1 | context("mtc.model with duplicated arms") 2 | 3 | test_that("mtc.model refuses duplicated arms", { 4 | network <- mtc.network(read.table(textConnection(" 5 | study treatment mean std.dev sampleSize 6 | s01 A 2.0 0.5 20 7 | s01 B 1.8 0.5 20 8 | s01 B 1.5 0.5 20"), header=T)) 9 | expect_warning(expect_error(mtc.model(network))) 10 | }) 11 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-5.out.txt: -------------------------------------------------------------------------------- 1 | structure(list(study = c("1", "1", "2", "2", "3", "3", "3", "4", 2 | "4", "5", "5", "6", "6", "7", "7"), treatment = c("1", "3", "1", 3 | "2", "1", "2", "4", "3", "4", "3", "4", "4", "5", "4", "5"), 4 | mean = c(-1.22, -1.53, -0.7, -2.4, -0.3, -2.6, -1.2, -0.24, 5 | -0.59, -0.73, -0.18, -2.2, -2.5, -1.8, -2.1), std.err = c(0.504, 6 | 0.439, 0.282, 0.258, 0.505, 0.51, 0.478, 0.265, 0.354, 0.335, 7 | 0.442, 0.197, 0.19, 0.2, 0.25)), row.names = c(NA, -15L), class = "data.frame") 8 | -------------------------------------------------------------------------------- /afstroke-treatments.csv: -------------------------------------------------------------------------------- 1 | id,description 2 | 1,Placebo/Standard care 3 | 2,Low adjusted dose anti-coagulant 4 | 3,Standard adjusted dose anti-coagulant 5 | 4,Fixed dose warfarin 6 | 5,Low dose aspirin 7 | 6,Medium dose aspirin 8 | 7,High dose aspirin 9 | 8,Alternate day aspirin 10 | 9,Ximelagatran 11 | 10,Triflusal 12 | 11,Indobufen 13 | 12,Dipyridamole 14 | 13,Fixed dose warfarin + low dose aspirin 15 | 14,Fixed dose warfarin + medium dose aspirin 16 | 15,Acenocoumarol 17 | 16,Low dose aspirin + copidogrel 18 | 17,Low dose aspirin + dipyridamole 19 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.model.use.template.txt: -------------------------------------------------------------------------------- 1 | model { 2 | # Likelihood for arm-based data 3 | $armeffect$ 4 | # Likelihood for contrast-based data (univariate for 2-arm trials) 5 | $releffect.r2$ 6 | # Likelihood for contrast-based data (multivariate for multi-arm trials) 7 | $releffect.rm$ 8 | 9 | prior.prec <- pow(15 * om.scale, -2) 10 | 11 | # Study baseline priors 12 | $studyBaselinePriors$ 13 | 14 | for (i in studies) { 15 | delta[i, 1] <- 0 16 | for (k in 2:na[i]) { 17 | delta[i, k] ~ dnorm(0, prior.prec) 18 | } 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.randomeffects.txt: -------------------------------------------------------------------------------- 1 | # Random effects model 2 | for (i in studies) { 3 | # Study-level relative effects 4 | w[i, 1] <- 0 5 | delta[i, 1] <- 0 6 | for (k in 2:na[i]) { # parameterize multi-arm trials using a trick to avoid dmnorm 7 | delta[i, k] ~ dnorm(md[i, k], taud[i, k]) 8 | md[i, k] <- d[t[i, 1], t[i, k]] + sw[i, k] 9 | taud[i, k] <- tau.d * 2 * (k - 1) / k 10 | w[i, k] <- delta[i, k] - (d[t[i, 1], t[i, k]]) 11 | sw[i, k] <- sum(w[i, 1:(k-1)]) / (k - 1) 12 | } 13 | } 14 | 15 | # Random effects variance prior 16 | $hy.prior$ 17 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.model.template.txt: -------------------------------------------------------------------------------- 1 | model { 2 | # Likelihood for arm-based data 3 | $armeffect$ 4 | # Likelihood for contrast-based data (univariate for 2-arm trials) 5 | $releffect.r2$ 6 | # Likelihood for contrast-based data (multivariate for multi-arm trials) 7 | $releffect.rm$ 8 | 9 | $heterogeneityModel$ 10 | 11 | # Relative effect matrix 12 | $relativeEffectMatrix$ 13 | 14 | prior.prec <- pow(15 * om.scale, -2) 15 | 16 | # Study baseline priors 17 | $studyBaselinePriors$ 18 | 19 | # Effect parameter priors 20 | $relativeEffectPriors$ 21 | $regressionPriors$ 22 | } 23 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-read.mtc.network.R: -------------------------------------------------------------------------------- 1 | context("Read GeMTC XML files") 2 | 3 | # Test a dichotomous data file 4 | test_that("read.mtc.network('luades-smoking.gemtc') has expected result", { 5 | file <- system.file("extdata/luades-smoking.gemtc", package="gemtc") 6 | expect_that(read.mtc.network(file), equals(smoking)) 7 | }) 8 | 9 | # Test a continuous data file 10 | test_that("read.mtc.network('parkinson.gemtc') has expected result", { 11 | file <- system.file("extdata/parkinson.gemtc", package="gemtc") 12 | expect_that(read.mtc.network(file), equals(parkinson)) 13 | }) 14 | -------------------------------------------------------------------------------- /gemtc/R/ll.call.R: -------------------------------------------------------------------------------- 1 | ll.call <- function(fnName, model, ...) { 2 | fn <- paste(fnName, model[['likelihood']], model[['link']], sep=".") 3 | do.call(fn, list(...)) 4 | } 5 | 6 | ll.defined <- function(model) { 7 | fns <- c('mtc.arm.mle', 'mtc.rel.mle', 'mtc.code.likelihood', 8 | 'fitted.values.parameter', 'deviance', 9 | 'scale.log', 'scale.name', 'inits.info', 10 | 'required.columns.ab', 'validate.data', 11 | 'study.baseline.priors') 12 | fns <- paste(fns, model[['likelihood']], model[['link']], sep=".") 13 | all(sapply(fns, function(fn) { exists(fn, mode='function') })) 14 | } 15 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.releffect.likelihood.rm.txt: -------------------------------------------------------------------------------- 1 | for(i in studies.rm) { 2 | for (k in 2:na[i]) { 3 | mest[i, k] <- $relLinearModel$ 4 | } 5 | for (k in 1:(na[i]-1)) { 6 | for (j in 1:(na[i]-1)) { 7 | Sigma[i,j,k] <- ifelse(equals(j, k), pow(e[i,k+1], 2), pow(e[i,1], 2)) 8 | } 9 | } 10 | Omega[i,1:(na[i]-1),1:(na[i]-1)] <- inverse(Sigma[i,1:(na[i]-1),1:(na[i]-1)]) 11 | m[i,2:na[i]] ~ dmnorm(mest[i,2:na[i]], Omega[i,1:(na[i]-1),1:(na[i]-1)]) 12 | 13 | mdiff[i, 2:na[i]] <- m[i, 2:na[i]] - mest[i, 2:na[i]] 14 | dev[i, 1] <- t(mdiff[i, 2:na[i]]) %*% Omega[i, 1:(na[i]-1),1:(na[i]-1)] %*% mdiff[i, 2:na[i]] 15 | } 16 | -------------------------------------------------------------------------------- /gemtc/inst/gemtc.releffect.likelihood.power.rm.txt: -------------------------------------------------------------------------------- 1 | for(i in studies.rm) { 2 | for (k in 2:na[i]) { 3 | mest[i, k] <- $relLinearModel$ 4 | } 5 | for (k in 1:(na[i]-1)) { 6 | for (j in 1:(na[i]-1)) { 7 | Sigma[i,j,k] <- ifelse(equals(j, k), pow(e[i,k+1], 2), pow(e[i,1], 2)) * 1 / alpha[i] 8 | } 9 | } 10 | Omega[i,1:(na[i]-1),1:(na[i]-1)] <- inverse(Sigma[i,1:(na[i]-1),1:(na[i]-1)]) 11 | m[i,2:na[i]] ~ dmnorm(mest[i,2:na[i]], Omega[i,1:(na[i]-1),1:(na[i]-1)]) 12 | 13 | mdiff[i, 2:na[i]] <- m[i, 2:na[i]] - mest[i, 2:na[i]] 14 | dev[i, 1] <- t(mdiff[i, 2:na[i]]) %*% Omega[i, 1:(na[i]-1),1:(na[i]-1)] %*% mdiff[i, 2:na[i]] 15 | } 16 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-2.data.txt: -------------------------------------------------------------------------------- 1 | t[,1] t[,2] t[,3] E[,1] E[,2] E[,3] r[,1] r[,2] r[,3] na[] # ID 2 | 1 2 NA 1917 1925 NA 113 111 NA 2 # 2 DART 3 | 1 2 2 43.6 41.3 38 1 5 3 3 # 10 London Corn /Olive 4 | 1 2 NA 393.5 373.9 NA 24 20 NA 2 # 11 London Low Fat 5 | 1 2 NA 4715 4823 NA 248 269 NA 2 # 14 Minnesota Coronary 6 | 1 2 NA 715 751 NA 31 28 NA 2 # 15 MRC Soya 7 | 1 2 NA 885 895 NA 65 48 NA 2 # 18 Oslo Diet-Heart 8 | 1 2 NA 87.8 91 NA 3 1 NA 2 # 22 STARS 9 | 1 2 NA 1011 939 NA 28 39 NA 2 # 23 Sydney Diet-Heart 10 | 1 2 NA 1544 1588 NA 177 174 NA 2 # 26 Veterans Administration 11 | 1 2 NA 125 123 NA 2 1 NA 2 # 27 Veterans Diet & Skin CA 12 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-validate-riskratio.R: -------------------------------------------------------------------------------- 1 | context("[validate] Risk ratio example") 2 | 3 | # Example from http://www.statsdirect.com/help/default.htm#meta_analysis/relative_risk.htms 4 | # Original source https://doi.org/10.1016/0895-4356(91)90261-7 5 | 6 | # Results of the Bayesian FE model closely match the frequentist RR of 0.913608 (0.8657, 0.964168) 7 | 8 | test_that("The summaries match", { 9 | network <- mtc.network(data.ab=read.table("../data/riskratio.data.txt", header=TRUE)) 10 | result <- replicate.example("riskratio", network, likelihood="binom", link="log", linearModel="fixed") 11 | compare.summaries(result$s1, result$s2) 12 | }) 13 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.model.use.R: -------------------------------------------------------------------------------- 1 | context("mtc.model.use") 2 | 3 | test_that("the model generates correctly", { 4 | data.ab <- read.table(textConnection(' 5 | study treatment mean std.err 6 | 1 A 10.5 0.18 7 | 1 B 15.3 0.17 8 | 2 B 15.7 0.12 9 | 2 C 18.3 0.15 10 | 3 B 13.1 0.19 11 | 3 C 14.2 0.20'), header=T) 12 | network <- mtc.network(data.ab) 13 | model <- mtc.model(network, type='use') 14 | 15 | expect_equal(3, length(model$inits[[1]]$mu)) 16 | expect_equal(3, length(model$inits[[2]]$mu)) 17 | expect_equal(3, length(model$inits[[3]]$mu)) 18 | expect_equal(3, length(model$inits[[4]]$mu)) 19 | }) 20 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-1.data.txt: -------------------------------------------------------------------------------- 1 | r[,1] n[,1] r[,2] n[,2] t[,1] t[,2] na[] # Study ID 2 | 3 39 3 38 1 2 2 # 1 3 | 14 116 7 114 1 2 2 # 2 4 | 11 93 5 69 1 2 2 # 3 5 | 127 1520 102 1533 1 2 2 # 4 6 | 27 365 28 355 1 2 2 # 5 7 | 6 52 4 59 1 2 2 # 6 8 | 152 939 98 945 1 2 2 # 7 9 | 48 471 60 632 1 2 2 # 8 10 | 37 282 25 278 1 2 2 # 9 11 | 188 1921 138 1916 1 2 2 # 10 12 | 52 583 64 873 1 2 2 # 11 13 | 47 266 45 263 1 2 2 # 12 14 | 16 293 9 291 1 2 2 # 13 15 | 45 883 57 858 1 2 2 # 14 16 | 31 147 25 154 1 2 2 # 15 17 | 38 213 33 207 1 2 2 # 16 18 | 12 122 28 251 1 2 2 # 17 19 | 6 154 8 151 1 2 2 # 18 20 | 3 134 6 174 1 2 2 # 19 21 | 40 218 32 209 1 2 2 # 20 22 | 43 364 27 391 1 2 2 # 21 23 | 39 674 22 680 1 2 2 # 22 24 | -------------------------------------------------------------------------------- /gemtc/R/template.R: -------------------------------------------------------------------------------- 1 | template.block.sub <- function(template, var, val) { 2 | while (length(grep(paste0('$', var, '$'), template, fixed=TRUE)) > 0) { 3 | matches <- regexec(paste("([ \t]*)[^\\$\n]*\\$", var, "\\$",sep=""), template)[[1]] 4 | start <- matches[2] 5 | len <- attr(matches, "match.length")[2] 6 | indent <- substr(template, start, start + len - 1) 7 | val <- paste(strsplit(val, "\n")[[1]], collapse=paste("\n", indent, sep="")) 8 | template <- sub(paste0('$', var, '$'), val, template, fixed=TRUE) 9 | } 10 | template 11 | } 12 | 13 | read.template <- function(file.name) { 14 | fileName <- system.file(file.name, package='gemtc') 15 | readChar(fileName, file.info(fileName)[['size']]) 16 | } 17 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-7.out.txt: -------------------------------------------------------------------------------- 1 | structure(list(study = c("1", "1", "2", "2", "3", "3", "4", "4", 2 | "5", "5", "6", "6", "7", "7", "7"), var = c(0.253518519, 0.253518519, 3 | 0.079593023, 0.079593023, 0.0703125, 0.0703125, 0.1125, 0.1125, 4 | 0.038949635, 0.038949635, 0.039937662, 0.039937662, 0.254736842, 5 | 0.254736842, 0.254736842), treatment = c("1", "3", "1", "2", 6 | "3", "4", "3", "4", "4", "5", "4", "5", "1", "2", "4"), diff = c(NA, 7 | -0.31, NA, -1.7, NA, -0.35, NA, 0.55, NA, -0.3, NA, -0.3, NA, 8 | -2.3, -0.9), std.err = c(NA, 0.668089651, NA, 0.382640605, NA, 9 | 0.441941738, NA, 0.555114559, NA, 0.274276316, NA, 0.320087245, 10 | NA, 0.71774604, 0.694988091)), row.names = c(NA, -15L), class = "data.frame") 11 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.study.treatment.matrix.R: -------------------------------------------------------------------------------- 1 | context("mtc.study.treatment.matrix") 2 | 3 | test_that('mtc.study.treatment.matrix with 1 study', { 4 | data <- data.frame(cbind(c('s02', 's02'), c('A', 'B'))) 5 | colnames(data) <- c('study', 'treatment') 6 | network <- mtc.network(data) 7 | m <- mtc.study.treatment.matrix(network) 8 | expect_equal(1, nrow(m)) 9 | }) 10 | 11 | test_that('mtc.study.treatment.matrix with 2 studies', { 12 | data <- data.frame(cbind(c('s02', 's02'), c('A', 'B'))) 13 | data <- rbind(data, data.frame(cbind(c('s01', 's01'), c('A', 'B')))) 14 | 15 | colnames(data) <- c('study', 'treatment') 16 | network <- mtc.network(data) 17 | m <- mtc.study.treatment.matrix(network) 18 | expect_equal(2, nrow(m)) 19 | }) 20 | 21 | 22 | -------------------------------------------------------------------------------- /gemtc/tests/data/riskratio.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(17353.7151177326, .Names = "d.A.B"), 2 | summary = structure(list(statistics = structure(c(-0.0905785901265748, 3 | 0.0275019781587034, 9.72341762603175e-05, 0.000208889376331796 4 | ), .Names = c("Mean", "SD", "Naive SE", "Time-series SE")), 5 | quantiles = structure(c(-0.144369725686598, -0.109146058702042, 6 | -0.0906741416473852, -0.0720521541534026, -0.0366082503487515 7 | ), .Names = c("2.5%", "25%", "50%", "75%", "97.5%")), 8 | start = 5001, end = 25000, thin = 1, nchain = 4L), .Names = c("statistics", 9 | "quantiles", "start", "end", "thin", "nchain"), class = "summary.mcmc"), 10 | cov = structure(numeric(0), .Dim = c(0L, 0L))), .Names = c("effectiveSize", 11 | "summary", "cov")) 12 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-arrayize.R: -------------------------------------------------------------------------------- 1 | context("arrayize") 2 | 3 | test_that("it preserves scalar values", { 4 | expect_equal(arrayize(c("a"=3)), list("a"=3)) 5 | expect_equal(arrayize(c("a"=3, "b"=2)), list("a"=3, "b"=2)) 6 | }) 7 | 8 | test_that("it parses vectors", { 9 | expect_equal(arrayize(c("a[1]"=3)), list("a"=3)) 10 | expect_equal(arrayize(c("a[1]"=3, "a[2]"=4)), list("a"=c(3,4))) 11 | expect_equal(arrayize(c("a[2]"=4)), list("a"=c(NA,4))) 12 | }) 13 | 14 | test_that("it parses matrices", { 15 | expect_equal(arrayize(c("m[1,2]"=8,"m[2,1]"=4)), list("m"=rbind(c(NA,8),c(4,NA)))) 16 | }) 17 | 18 | test_that("it handles multiple variables", { 19 | result <- arrayize(c("m[1,2]"=8,"a"=1,"beta[2]"=3,"m[2,1]"=4)) 20 | expect_equal(result, list("a"=1, "beta"=c(NA,3), "m"=rbind(c(NA,8),c(4,NA)))) 21 | }) 22 | -------------------------------------------------------------------------------- /gemtc/man/depression.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{depression} 3 | \alias{depression} 4 | \title{Treatment response in major depression} 5 | \description{A dataset of 111 trials investigating 12 treatments for major depression on treatment response. Treatment response was defined as a reduction of at least 50\% from the baseline score on the HAM-D or MADRS at week 8 (or, if not available, another time between week 6 and 12).} 6 | \format{A network meta-analysis dataset containing 224 rows of arm-based data (responders and sample size).} 7 | \source{ 8 | Cipriani et al. (2009), 9 | \emph{Comparative efficacy and acceptability of 12 new-generation antidepressants: a multiple-treatments meta-analysis}, 10 | Lancet 373(9665):746-758. 11 | [\href{https://doi.org/10.1016/S0140-6736(09)60046-5}{doi:10.1016/S0140-6736(09)60046-5}] 12 | } 13 | -------------------------------------------------------------------------------- /gemtc/R/mtc.model.use.R: -------------------------------------------------------------------------------- 1 | # Unrelated study effects model 2 | mtc.model.use <- function(model) { 3 | model[['linearModel']] <- 'random' 4 | 5 | model[['data']] <- mtc.model.data(model) 6 | model[['data']][['nt']] <- NULL 7 | model[['data']][['t']] <- NULL 8 | model[['inits']] <- lapply(mtc.init(model), function(inits) { 9 | inits[-which(names(inits) == "sd.d")] 10 | }) 11 | 12 | model[['code']] <- mtc.model.code(model, c(), '', template='gemtc.model.use.template.txt') 13 | 14 | monitors <- inits.to.monitors(model[['inits']][[1]]) 15 | model[['monitors']] <- list( 16 | available=monitors, 17 | enabled=monitors[grep('^delta\\[', monitors)] 18 | ) 19 | 20 | class(model) <- "mtc.model" 21 | 22 | model 23 | } 24 | 25 | mtc.model.name.use <- function(model) { 26 | "unrelated study effects" 27 | } 28 | -------------------------------------------------------------------------------- /classes-example.R: -------------------------------------------------------------------------------- 1 | regressorData <- function(data, var) { 2 | studies <- unique(data[['study']]) 3 | covar <- unname(sapply(studies, function(study) { 4 | sel <- data[['study']] == study 5 | data[[var]][sel][1] 6 | })) 7 | rval <- data.frame(study=studies) 8 | rval[[var]] <- covar 9 | rval 10 | } 11 | 12 | data.ab <- read.csv('afstroke-data.csv') 13 | treatments <- read.csv('afstroke-treatments.csv') 14 | classes <- list("control"=c(1), 15 | "anti-coagulant"=c(2,3,4,9), 16 | "anti-platelet"=c(5,6,7,8,10,11,12,16,17), 17 | "mixed"=c(13,14,15)) 18 | 19 | network <- mtc.network(data.ab=data.ab, treatments=treatments, studies=regressorData(data.ab, 'stroke')) 20 | 21 | model <- mtc.model(network, type="regression", regressor=list('coefficient'='shared', 'variable'='stroke', 'classes'=classes)) 22 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.nr.comparisons.R: -------------------------------------------------------------------------------- 1 | context("mtc.nr.comparisons") 2 | 3 | test_that('mtc.nr.comparisons with a single study', { 4 | data <- data.frame(cbind(c('s02', 's02'), c('A', 'B'))) 5 | colnames(data) <- c('study', 'treatment') 6 | network <- mtc.network(data) 7 | comparisons <- mtc.nr.comparisons(network) 8 | expect_identical(as.matrix(data.frame(t1='A', t2='B', nr=1)), as.matrix(comparisons)) 9 | }) 10 | 11 | test_that('mtc.nr.comparisons with 2 studies', { 12 | data <- data.frame(cbind(c('s02', 's02'), c('A', 'B'))) 13 | data <- rbind(data, data.frame(cbind(c('s01', 's01'), c('A', 'B')))) 14 | colnames(data) <- c('study', 'treatment') 15 | network <- mtc.network(data) 16 | comparisons <- mtc.nr.comparisons(network) 17 | expect_identical(as.matrix(data.frame(t1='A', t2='B', nr=2)), as.matrix(comparisons)) 18 | }) 19 | 20 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-regress-anohe.R: -------------------------------------------------------------------------------- 1 | context("Regressions previously observed for ANOHE") 2 | 3 | test_that("anohe-breaking.gemtc does not break summary.mtc.anohe", { 4 | network <- read.mtc.network("../data/anohe-breaking.gemtc") 5 | capture.output(anohe <- mtc.anohe(network, n.adapt=200, n.iter=500)) 6 | x <- summary(anohe) 7 | expect_true('studyEffects' %in% names(x)) 8 | }) 9 | 10 | test_that("Mixing up the order of treatments does not break summary.mtc.anohe", { 11 | network <- thrombolytic 12 | treatments <- network$treatments 13 | treatments$id <- factor(rev(as.character(treatments$id)), levels=rev(as.character(treatments$id))) 14 | network <- mtc.network(data=network$data.ab, treatments=treatments) 15 | capture.output(anohe <- mtc.anohe(network, n.adapt=200, n.iter=500)) 16 | x <- summary(anohe) 17 | expect_true('studyEffects' %in% names(x)) 18 | }) 19 | -------------------------------------------------------------------------------- /gemtc/man/smoking.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{smoking} 3 | \alias{smoking} 4 | \title{Psychological treatments to aid smoking cessation} 5 | \description{A dataset of 24 trials investigating four psychological treatments and no treatment for smoking cessation. The outcome is the number of people who stopped smoking.} 6 | \format{A network meta-analysis dataset containing 50 rows of arm-based data (responders and sample size).} 7 | \source{ 8 | Lu and Ades (2006), 9 | \emph{Assessing Evidence Inconsistency in Mixed Treatment Comparisons}, 10 | Journal of the American Statistical Society, 101(474):447-459. 11 | [\href{https://doi.org/10.1198/016214505000001302}{doi:10.1198/016214505000001302}] 12 | 13 | Hasselblad (1998), 14 | \emph{Meta-analysis of multitreatment studies}, 15 | Medical Decision Making 18(1):37-43. 16 | [\href{https://doi.org/10.1177/0272989X9801800110}{doi:10.1177/0272989X9801800110}] 17 | } 18 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-ll.R: -------------------------------------------------------------------------------- 1 | context("likelihood/link"); 2 | 3 | # This file contains a single test for each implemented likelihood. 4 | # Since ll.defined() checks whether all required methods are implemented, 5 | # this is a simple guard against forgetting to add or correctly name new 6 | # methods. 7 | 8 | test_that("normal.identity is defined", { 9 | expect_true(ll.defined(list(likelihood='normal', link='identity'))) 10 | }) 11 | 12 | test_that("binom.logit is defined", { 13 | expect_true(ll.defined(list(likelihood='binom', link='logit'))) 14 | }) 15 | 16 | test_that("binom.log is defined", { 17 | expect_true(ll.defined(list(likelihood='binom', link='log'))) 18 | }) 19 | 20 | test_that("binom.cloglog is defined", { 21 | expect_true(ll.defined(list(likelihood='binom', link='cloglog'))) 22 | }) 23 | 24 | test_that("poisson.log is defined", { 25 | expect_true(ll.defined(list(likelihood='poisson', link='log'))) 26 | }) 27 | -------------------------------------------------------------------------------- /gemtc/man/blocker.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{blocker} 3 | \alias{blocker} 4 | \title{Beta blockers to prevent mortality after myocardial infarction} 5 | \description{A dataset of 22 trials investigating beta blockers versus control to prevent mortality after myocardial infarction. Number of events and sample size.} 6 | \format{A meta-analysis dataset containing 44 rows of arm-based data (responders and sample size).} 7 | \source{ 8 | S. Dias, A.J. Sutton, A.E. Ades, and N.J. Welton (2013a), 9 | \emph{A Generalized Linear Modeling Framework for Pairwise and Network Meta-analysis of Randomized Controlled Trials}, 10 | Medical Decision Making 33(5):607-617. 11 | [\href{https://doi.org/10.1177/0272989X12458724}{doi:10.1177/0272989X12458724}] 12 | 13 | J.B. Carlin (1992), 14 | \emph{Meta-analysis for 2 × 2 tables: a Bayesian approach}, 15 | Statistics in Medicine 11(2):141-158. 16 | [\href{https://doi.org/10.1002/sim.4780110202}{doi:10.1002/sim.4780110202}] 17 | } 18 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.model.nodesplit.R: -------------------------------------------------------------------------------- 1 | context("mtc.model.nodesplit") 2 | 3 | test_that("func.param.matrix was implemented correctly", { 4 | model <- list( 5 | 'type'='nodesplit', 6 | 'tree.indirect'=igraph::make_graph(c('D', 'A', 'D', 'B', 'D', 'C', 'D', 'E')), 7 | 'split'=list(t1='A', t2='C')) 8 | 9 | expect_equal(matrix(c(0,0,0,0,1), nrow=5, dimnames=list(NULL, 'd.A.C')), 10 | mtc.model.call('func.param.matrix', model, t1='A', t2='C')) 11 | expect_equal(matrix(c(0,0,0,0,-1), nrow=5, dimnames=list(NULL, 'd.C.A')), 12 | mtc.model.call('func.param.matrix', model, t1='C', t2='A')) 13 | expect_equal(matrix(c(0,0,0,0,0), nrow=5, dimnames=list(NULL, 'd.A.A')), 14 | mtc.model.call('func.param.matrix', model, t1='A', t2='A')) 15 | expect_equal(matrix(c(-1,1,0,0,0), nrow=5, dimnames=list(NULL, 'd.A.B')), 16 | mtc.model.call('func.param.matrix', model, t1='A', t2='B')) 17 | }) 18 | -------------------------------------------------------------------------------- /gemtc/man/dietfat.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{dietfat} 3 | \alias{dietfat} 4 | \title{Effects of low-fat diets on mortality} 5 | \description{A dataset of 10 trials investigating low-fat diet versus control diet for mortality. Number of events and exposure in person-years.} 6 | \format{A meta-analysis dataset containing 20 rows of arm-based data (responders, exposure, and sample size).} 7 | \source{ 8 | S. Dias, A.J. Sutton, A.E. Ades, and N.J. Welton (2013a), 9 | \emph{A Generalized Linear Modeling Framework for Pairwise and Network Meta-analysis of Randomized Controlled Trials}, 10 | Medical Decision Making 33(5):607-617. 11 | [\href{https://doi.org/10.1177/0272989X12458724}{doi:10.1177/0272989X12458724}] 12 | 13 | Hooper et al. (2000), 14 | \emph{Reduced or modified dietary fat for preventing cardiovascular disease}, 15 | Cochrane Database of Systematic Reviews 2:CD002137. 16 | [\href{https://doi.org/10.1002/14651858.CD002137}{doi:10.1002/14651858.CD002137}] 17 | } 18 | -------------------------------------------------------------------------------- /gemtc/R/ll-helper.counts.R: -------------------------------------------------------------------------------- 1 | required.columns.counts <- function() { 2 | c('r'='responders', 'n'='sampleSize') 3 | } 4 | 5 | validate.data.counts <- function(data.ab) { 6 | stopifnot(all(data.ab[['sampleSize']] >= data.ab[['responders']])) 7 | stopifnot(all(data.ab[['sampleSize']] > 0)) 8 | stopifnot(all(data.ab[['responders']] >= 0)) 9 | } 10 | 11 | correction.counts <- function(data, correction.force, correction.type, correction.magnitude) { 12 | correction.need <- 13 | data[1,'responders'] == 0 || data[1,'responders'] == data[1,'sampleSize'] || 14 | data[2,'responders'] == 0 || data[2,'responders'] == data[2,'sampleSize'] 15 | 16 | groupRatio <- if (correction.type == "reciprocal") { 17 | data[1,'sampleSize'] / data[2,'sampleSize'] 18 | } else { 19 | 1 20 | } 21 | 22 | if (correction.force || correction.need) { 23 | correction.magnitude * c(groupRatio/(groupRatio+1), 1/(groupRatio+1)) 24 | } else { 25 | c(0, 0) 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /gemtc/man/thrombolytic.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{thrombolytic} 3 | \alias{thrombolytic} 4 | \title{Thrombolytic treatment after acute myocardial infarction} 5 | \description{A dataset of 28 trials investigating eight thrombolytic treatments administered after a myocardial infarction. The outcome is mortality after 30-35 days.} 6 | \format{A network meta-analysis dataset containing 58 rows of arm-based data (responders and sample size).} 7 | \source{ 8 | Lu and Ades (2006), 9 | \emph{Assessing Evidence Inconsistency in Mixed Treatment Comparisons}, 10 | Journal of the American Statistical Society, 101(474):447-459. 11 | [\href{https://doi.org/10.1198/016214505000001302}{10.1198/016214505000001302}] 12 | 13 | Boland et al. (2003), 14 | \emph{Early thrombolysis for the treatment of acute myocardial infarction: a systematic review and economic evaluation}, 15 | Health Technology Assessment 7(15):1-136. 16 | [\href{https://doi.org/10.3310/hta7150}{doi:10.3310/hta7150}] 17 | } 18 | -------------------------------------------------------------------------------- /gemtc/man/parkinson.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{parkinson} 3 | \alias{parkinson} 4 | \alias{parkinson_diff} 5 | \alias{parkinson_shared} 6 | \title{Mean off-time reduction in Parkinson's disease} 7 | \description{A dataset of seven trials investigating four treatments and placebo for Parkinson's disease. The outcome is mean off-time reduction.} 8 | \format{ \itemize{ 9 | \item{parkinson: }{A network meta-analysis dataset containing fifteen rows of arm-based data (mean, standard deviation, and sample size).} 10 | \item{parkinson_diff: }{A network meta-analysis dataset containing fifteen rows of contrast-based data.} 11 | \item{parkinson_shared: }{A network meta-analysis dataset containing mixed arm-based and contrast-based data.} 12 | } } 13 | \source{ 14 | Franchini et al. (2012), 15 | \emph{Accounting for correlation in network meta-analysis with multi-arm trials}, 16 | Research Synthesis Methods, 3(2):142-160. 17 | [\href{https://doi.org/10.1002/jrsm.1049}{doi:10.1002/jrsm.1049}] 18 | } 19 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-2.out.txt: -------------------------------------------------------------------------------- 1 | structure(list(study = c("DART", "DART", "London Corn/Olive", 2 | "London Corn/Olive", "London Corn/Olive", "London Low Fat", "London Low Fat", 3 | "Minnesota Coronary", "Minnesota Coronary", "MRC Soya", "MRC Soya", 4 | "Oslo Diet-Heart", "Oslo Diet-Heart", "STARS", "STARS", "Sydney Diet-Heart", 5 | "Sydney Diet-Heart", "Veterans Administration", "Veterans Administration", 6 | "Veterans Diet & Skin CA", "Veterans Diet & Skin CA"), treatment = c("control", 7 | "diet", "control", "diet", "diet", "control", "diet", "control", 8 | "diet", "control", "diet", "control", "diet", "control", "diet", 9 | "control", "diet", "control", "diet", "control", "diet"), responders = c(113L, 10 | 111L, 1L, 5L, 3L, 24L, 20L, 248L, 269L, 31L, 28L, 65L, 48L, 3L, 11 | 1L, 28L, 39L, 177L, 174L, 2L, 1L), exposure = c(1917, 1925, 43.6, 12 | 41.3, 38, 393.5, 373.9, 4715, 4823, 715, 751, 885, 895, 87.8, 13 | 91, 1011, 939, 1544, 1588, 125, 123)), row.names = c(NA, -21L 14 | ), class = "data.frame") 15 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-template.R: -------------------------------------------------------------------------------- 1 | context("template") 2 | 3 | test_that("template.block.sub for a single line keeps indent", { 4 | template <- "model {\n\t$model$\n}\n" 5 | expect_that(template.block.sub(template, 'model', 'foo'), equals("model {\n\tfoo\n}\n")) 6 | }) 7 | 8 | test_that("template.block.sub for multi-line keeps indent", { 9 | template <- "model {\n\t$model$\n}\n" 10 | expect_that(template.block.sub(template, 'model', 'foo\nbar'), equals("model {\n\tfoo\n\tbar\n}\n")) 11 | }) 12 | 13 | test_that("template.block.sub keeps other stuff on the same line", { 14 | template <- "model {\n\tbaz($model$)\n}\n" 15 | expect_that(template.block.sub(template, 'model', 'foo\nbar'), equals("model {\n\tbaz(foo\n\tbar)\n}\n")) 16 | }) 17 | 18 | test_that("template.block.sub keeps other stuff with white space on the same line", { 19 | template <- "model {\n\tbaz baz($model$)\n}\n" 20 | expect_that(template.block.sub(template, 'model', 'foo\nbar'), equals("model {\n\tbaz baz(foo\n\tbar)\n}\n")) 21 | }) 22 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.model.consistency.R: -------------------------------------------------------------------------------- 1 | context("mtc.model.consistency") 2 | 3 | test_that("func.param.matrix was implemented correctly", { 4 | model <- list( 5 | 'type'='consistency', 6 | 'tree'=igraph::make_graph(c('A','B','A','C','B','D'))) 7 | 8 | expect_equal(matrix(0, nrow=3, dimnames=list(NULL, 'd.A.A')), 9 | mtc.model.call('func.param.matrix', model, t1='A', t2='A')) 10 | expect_equal(matrix(c(1,0,0), nrow=3, dimnames=list(NULL, 'd.A.B')), 11 | mtc.model.call('func.param.matrix', model, t1='A', t2='B')) 12 | expect_equal(matrix(c(1,0,0,0,1,0), nrow=3, dimnames=list(NULL, c('d.A.B', 'd.A.C'))), 13 | mtc.model.call('func.param.matrix', model, t1='A', t2=c('B', 'C'))) 14 | expect_equal(matrix(c(-1,0,0), nrow=3, dimnames=list(NULL, c('d.B.A'))), 15 | mtc.model.call('func.param.matrix', model, t1='B', t2='A')) 16 | expect_equal(matrix(c(1,0,1), nrow=3, dimnames=list(NULL, c('d.A.D'))), 17 | mtc.model.call('func.param.matrix', model, t1='A', t2='D')) 18 | }) 19 | -------------------------------------------------------------------------------- /gemtc/tests/data/smoking-ume.data.txt: -------------------------------------------------------------------------------- 1 | "study" "treatment" "responders" "sampleSize" 2 | "1" "1" "A" 9 140 3 | "2" "1" "C" 23 140 4 | "3" "2" "B" 11 78 5 | "4" "2" "C" 12 85 6 | "5" "3" "A" 75 731 7 | "6" "3" "C" 363 714 8 | "7" "4" "A" 2 106 9 | "8" "4" "C" 9 205 10 | "9" "5" "A" 58 549 11 | "10" "5" "C" 237 1561 12 | "11" "6" "A" 0 33 13 | "12" "6" "C" 9 48 14 | "13" "7" "A" 3 100 15 | "14" "7" "C" 31 98 16 | "15" "8" "A" 1 31 17 | "16" "8" "C" 26 95 18 | "17" "9" "A" 6 39 19 | "18" "9" "C" 17 77 20 | "19" "10" "A" 79 702 21 | "20" "10" "B" 77 694 22 | "21" "11" "A" 18 671 23 | "22" "11" "B" 21 535 24 | "23" "12" "A" 64 642 25 | "24" "12" "C" 107 761 26 | "25" "13" "A" 5 62 27 | "26" "13" "C" 8 90 28 | "27" "14" "A" 20 234 29 | "28" "14" "C" 34 237 30 | "29" "16" "A" 8 116 31 | "30" "16" "B" 19 149 32 | "31" "17" "A" 95 1107 33 | "32" "17" "C" 143 1031 34 | "33" "18" "A" 15 187 35 | "34" "18" "C" 36 504 36 | "35" "19" "A" 78 584 37 | "36" "19" "C" 73 675 38 | "37" "20" "A" 69 1177 39 | "38" "20" "C" 54 888 40 | "39" "21" "B" 20 49 41 | "40" "21" "C" 16 43 42 | "41" "22" "B" 7 66 43 | "42" "22" "D" 32 127 44 | "43" "23" "C" 12 76 45 | "44" "23" "D" 20 74 46 | "45" "24" "C" 9 55 47 | "46" "24" "D" 3 26 48 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-3.data.txt: -------------------------------------------------------------------------------- 1 | time[] t[,1] r[,1] n[,1] t[,2] r[,2] n[,2] t[,3] r[,3] n[,3] na[] # 2 | 5.8 1 43 1081 2 34 2213 3 37 1102 3 # MRC-E 38 3 | 4.7 1 29 416 2 20 424 NA NA NA 2 # EWPH 32 4 | 3 1 140 1631 2 118 1578 NA NA NA 2 # SHEP 42 5 | 3.8 1 75 3272 3 86 3297 NA NA NA 2 # HAPPHY 33 6 | 4 1 302 6766 4 154 3954 5 119 4096 3 # ALLHAT 26 7 | 3 1 176 2511 4 136 2508 NA NA NA 2 # INSIGHT 35 8 | 4.1 1 200 2826 5 138 2800 NA NA NA 2 # ANBP-2 18 9 | 1 1 8 196 6 1 196 NA NA NA 2 # ALPINE 27 10 | 3.3 2 154 4870 4 177 4841 NA NA NA 2 # FEVER 20 11 | 3 2 489 2646 5 449 2623 NA NA NA 2 # DREAM 31 12 | 4.5 2 155 2883 5 102 2837 NA NA NA 2 # HOPE 34 13 | 4.8 2 399 3472 5 335 3432 NA NA NA 2 # PEACE 40 14 | 3.1 2 202 2721 6 163 2715 NA NA NA 2 # CHARM 30 15 | 3.7 2 115 2175 6 93 2167 NA NA NA 2 # SCOPE 41 16 | 3.8 3 70 405 4 32 202 5 45 410 3 # AASK 25 17 | 4 3 97 1960 4 95 1965 5 93 1970 3 # STOP-2 43 18 | 5.5 3 799 7040 4 567 7072 NA NA NA 2 # ASCOT 28 19 | 4.5 3 251 5059 4 216 5095 NA NA NA 2 # NORDIL 39 20 | 4 3 665 8078 4 569 8098 NA NA NA 2 # INVEST 36 21 | 6.1 3 380 5230 5 337 5183 NA NA NA 2 # CAPPP 29 22 | 4.8 3 320 3979 6 242 4020 NA NA NA 2 # LIFE 37 23 | 4.2 4 845 5074 6 690 5087 NA NA NA 2 # VALUE 44 24 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-decompose.R: -------------------------------------------------------------------------------- 1 | context("Multi-arm trial decomposition") 2 | 3 | test_that("Fixed effects MA recovers variances", { 4 | # All pair-wise relative effects and their variances 5 | mu <- matrix(c(0.000000, -1.090708, -0.131780, 1.0907081, 0.0000000, 0.9589281, 0.1317800, -0.9589281, 0.0000000), nrow=3) 6 | V <- matrix(c(0.0000000, 0.1627065, 0.2316605, 0.1627065, 0.0000000, 0.1604229, 0.2316605, 0.1604229, 0.0000000), nrow=3) 7 | # Decomposed variances 8 | v <- decompose.variance(V) 9 | 10 | expect_that(diag(v), equals(rep(0, 3))) 11 | expect_that(t(v), equals(v)) 12 | 13 | fe.3arm <- function(t1, t2, t3) { 14 | mu.dir <- mu[t1, t2] 15 | mu.ind <- mu[t1, t3] + mu[t3, t2] 16 | V.dir <- v[t1, t2] 17 | V.ind <- v[t1, t3] + v[t3, t2] 18 | V.pool <- 1 / (1/V.dir + 1/V.ind) 19 | mu.pool <- (1/V.dir * mu.dir + 1/V.ind * mu.ind) * V.pool 20 | list(mu=mu.pool, V=V.pool) 21 | } 22 | 23 | d12 <- fe.3arm(1, 2, 3) 24 | d13 <- fe.3arm(1, 3, 2) 25 | d23 <- fe.3arm(2, 3, 1) 26 | expect_that(c(d12$mu, d13$mu, d23$mu), equals(c(mu[1,2], mu[1,3], mu[2,3]), tolerance=1E-7)) 27 | expect_that(c(d12$V, d13$V, d23$V), equals(c(V[1,2], V[1,3], V[2,3]), tolerance=1E-7)) 28 | }); 29 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | read_version = $(shell grep 'Version:' $1/DESCRIPTION | sed 's/Version: //') 2 | 3 | R := R 4 | PKG_NAME := gemtc 5 | PKG_VERSION := $(call read_version,$(PKG_NAME)) 6 | PACKAGE := $(PKG_NAME)_$(PKG_VERSION).tar.gz 7 | 8 | all: $(PACKAGE) 9 | 10 | $(PACKAGE): collate 11 | rm -f $(PKG_NAME)/src/*.o $(PKG_NAME)/src/*.so 12 | $(R) CMD build $(PKG_NAME) 13 | 14 | .PHONY: $(PACKAGE) install check collate 15 | 16 | check: $(PACKAGE) 17 | $(R) CMD check $(PACKAGE) 18 | 19 | check-cran: $(PACKAGE) 20 | $(R) CMD check --as-cran $(PACKAGE) 21 | 22 | # Note: the tryCatch is a workaround for https://github.com/klutometis/roxygen/issues/358 23 | collate: 24 | cd $(PKG_NAME) && $(R) --vanilla --slave -e "library(roxygen2); tryCatch(roxygenize(roclets='collate'), error=function(e) {});" 25 | 26 | install: $(PACKAGE) 27 | $(R) CMD INSTALL $(PACKAGE) 28 | 29 | # Special test target since R CMD check is incredibly slow :-( 30 | test: $(PACKAGE) 31 | ./run-tests.sh $(R) $(PACKAGE) unit 32 | 33 | validate: $(PACKAGE) 34 | ./run-tests.sh $(R) $(PACKAGE) validate 35 | 36 | validate-power: $(PACKAGE) 37 | ./run-tests.sh $(R) $(PACKAGE) validate powerAdjust 38 | 39 | regress: $(PACKAGE) 40 | ./run-tests.sh $(R) $(PACKAGE) regress 41 | -------------------------------------------------------------------------------- /gemtc/tests/data/dietfat.fe.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(16781.0195714451, .Names = "d.control.diet"), 2 | summary = structure(list(statistics = structure(c(-0.00770627169745623, 3 | 0.0534341165393374, 0.000188918130758389, 0.000412525487172919 4 | ), .Names = c("Mean", "SD", "Naive SE", "Time-series SE")), 5 | quantiles = structure(c(-0.112410489145885, -0.0437610487614927, 6 | -0.00783282534735827, 0.0284324055826491, 0.0971751154902131 7 | ), .Names = c("2.5%", "25%", "50%", "75%", "97.5%")), 8 | start = 5001, end = 25000, thin = 1, nchain = 4L), .Names = c("statistics", 9 | "quantiles", "start", "end", "thin", "nchain"), class = "summary.mcmc"), 10 | cov = structure(0.00285520481033949, .Dim = c(1L, 1L)), ranks = structure(c(0.5584875, 11 | 0.4415125, 0.4415125, 0.5584875), .Dim = c(2L, 2L), .Dimnames = list( 12 | c("control", "diet"), NULL), class = "mtc.rank.probability", direction = 1), 13 | dic = structure(list(Dbar = 21.9634749556293, pD = 11.080658995388, 14 | DIC = 33.0441339510173, `data points` = 20L), .Names = c("Dbar", 15 | "pD", "DIC", "data points"))), .Names = c("effectiveSize", 16 | "summary", "cov", "ranks", "dic")) 17 | -------------------------------------------------------------------------------- /gemtc/R/likelihoods.R: -------------------------------------------------------------------------------- 1 | #' @include template.R 2 | 3 | fixna <- function(x, v) { 4 | x[is.na(x)] <- v 5 | x 6 | } 7 | 8 | likelihood.code.binom <- list( 9 | read.template("gemtc.likelihood.binom.txt"), 10 | read.template("gemtc.likelihood.binom.power.txt")) 11 | 12 | deviance.binom <- function(data, val, alpha=1) { 13 | r <- data$r 14 | n <- data$n 15 | rfit <- val 16 | 2 * alpha * (fixna(r * log(r / rfit), 0) + fixna((n - r) * log((n - r) / (n - rfit)), 0)) 17 | } 18 | 19 | fitted.values.parameter.binom <- function() { "rhat" } 20 | 21 | likelihood.code.poisson <- list( 22 | read.template("gemtc.likelihood.poisson.txt"), 23 | read.template("gemtc.likelihood.poisson.power.txt")) 24 | 25 | deviance.poisson <- function(data, val, alpha=1) { 26 | r <- data$r 27 | rfit <- val 28 | 2 * alpha * ((rfit - r) + fixna(r * log(r / rfit), 0)) 29 | } 30 | 31 | fitted.values.parameter.poisson <- function() { "theta" } 32 | 33 | likelihood.code.normal <- list( 34 | read.template("gemtc.likelihood.normal.txt"), 35 | read.template("gemtc.likelihood.normal.power.txt")) 36 | 37 | deviance.normal <- function(data, val, alpha=1) { 38 | alpha * (data$m - val)^2 / data$e^2 39 | } 40 | 41 | fitted.values.parameter.normal <- function() { "theta" } 42 | -------------------------------------------------------------------------------- /gemtc/tests/data/welton-diastolic.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(12655.6175975839, 2 | 2372.98210959637), .Names = c("d.psych.usual", "sd.d")), summary = structure(list( 3 | statistics = structure(c(1.35092789320737, 2.19225893128292, 4 | 0.983956914809342, 1.2242240958334, 0.0069576260685708, 0.0086565715985577, 5 | 0.00885983376735788, 0.0278458347498079), .Dim = c(2L, 4L 6 | ), .Dimnames = list(c("d.psych.usual", "sd.d"), c("Mean", 7 | "SD", "Naive SE", "Time-series SE"))), quantiles = structure(c(-0.658053218692988, 8 | 0.324654173971782, 0.787225293886728, 1.33155994239758, 1.35735696956074, 9 | 2.01024138499043, 1.91351043170031, 2.83025388159952, 3.34312874345753, 10 | 5.19866211698561), .Dim = c(2L, 5L), .Dimnames = list(c("d.psych.usual", 11 | "sd.d"), c("2.5%", "25%", "50%", "75%", "97.5%"))), start = 5002, 12 | end = 15000, thin = 2, nchain = 4L), .Names = c("statistics", 13 | "quantiles", "start", "end", "thin", "nchain"), class = "summary.mcmc"), 14 | cov = structure(0.968171210201119, .Dim = c(1L, 1L)), ranks = structure(c(0.07155, 15 | 0.92845, 0.92845, 0.07155), .Dim = c(2L, 2L), .Dimnames = list( 16 | c("psych", "usual"), NULL))), .Names = c("effectiveSize", 17 | "summary", "cov", "ranks")) 18 | -------------------------------------------------------------------------------- /gemtc/tests/data/welton-systolic.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(10420.6336002824, 2 | 3302.35826192739), .Names = c("d.psych.usual", "sd.d")), summary = structure(list( 3 | statistics = structure(c(1.22061247119591, 3.60223738888617, 4 | 1.60030038746422, 1.55551736273052, 0.0113158325591141, 0.0109991687544016, 5 | 0.0162165565595118, 0.0290028342721291), .Dim = c(2L, 4L), .Dimnames = list( 6 | c("d.psych.usual", "sd.d"), c("Mean", "SD", "Naive SE", 7 | "Time-series SE"))), quantiles = structure(c(-2.20644473413903, 8 | 1.06158255902847, 0.277804507411594, 2.48480011174171, 1.32576331984446, 9 | 3.38907415178408, 2.25215558528361, 4.51166268835305, 4.13071453787359, 10 | 7.29511242532043), .Dim = c(2L, 5L), .Dimnames = list(c("d.psych.usual", 11 | "sd.d"), c("2.5%", "25%", "50%", "75%", "97.5%"))), start = 5002, 12 | end = 15000, thin = 2, nchain = 4L), .Names = c("statistics", 13 | "quantiles", "start", "end", "thin", "nchain"), class = "summary.mcmc"), 14 | cov = structure(2.56096133011815, .Dim = c(1L, 1L)), ranks = structure(c(0.20205, 15 | 0.79795, 0.79795, 0.20205), .Dim = c(2L, 2L), .Dimnames = list( 16 | c("psych", "usual"), NULL))), .Names = c("effectiveSize", 17 | "summary", "cov", "ranks")) 18 | -------------------------------------------------------------------------------- /gemtc/tests/data/welton-cholesterol.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(13928.2176788702, 2 | 5435.87856885651), .Names = c("d.psych.usual", "sd.d")), summary = structure(list( 3 | statistics = structure(c(0.319103993427809, 0.290416103025045, 4 | 0.0923727581124487, 0.0885117939083647, 0.000653174036582171, 5 | 0.000625872896875908, 0.000784741752889834, 0.00131018299612887 6 | ), .Dim = c(2L, 4L), .Dimnames = list(c("d.psych.usual", 7 | "sd.d"), c("Mean", "SD", "Naive SE", "Time-series SE"))), 8 | quantiles = structure(c(0.131052073189912, 0.153612310265488, 9 | 0.261683493525484, 0.227989993374357, 0.320082726073534, 10 | 0.277435682435631, 0.376869366761249, 0.338219652175793, 11 | 0.501609650452965, 0.501927629419063), .Dim = c(2L, 5L), .Dimnames = list( 12 | c("d.psych.usual", "sd.d"), c("2.5%", "25%", "50%", "75%", 13 | "97.5%"))), start = 5002, end = 15000, thin = 2, nchain = 4L), .Names = c("statistics", 14 | "quantiles", "start", "end", "thin", "nchain"), class = "summary.mcmc"), 15 | cov = structure(0.00853272644130096, .Dim = c(1L, 1L)), ranks = structure(c(0.0015, 16 | 0.9985, 0.9985, 0.0015), .Dim = c(2L, 2L), .Dimnames = list( 17 | c("psych", "usual"), NULL))), .Names = c("effectiveSize", 18 | "summary", "cov", "ranks")) 19 | -------------------------------------------------------------------------------- /gemtc/man/hfPrevention.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{hfPrevention} 3 | \alias{hfPrevention} 4 | \title{Statins versus placebo in primary and secondary prevention of heart failure} 5 | \description{A dataset of 19 trials comparing statins versus placebo or usual care for cholesterol lowering. The main outcome is the number of deaths. Trials are either primary prevention (no previous heart disease; secondary = 0) or secondary prevention (previous heart disease; secondary = 1).} 6 | \format{A meta-regression dataset containing 38 rows of arm-based data (responders and sample size).} 7 | \source{ 8 | S. Dias, A.J. Sutton, N.J. Welton, and A.E. Ades (2013b), 9 | \emph{Heterogeneity - Subgroups, Meta-Regression, Bias, and Bias-Adjustment}, 10 | Medical Decision Making 33(5):618-640. \cr 11 | [\href{https://doi.org/10.1177/0272989X13485157}{doi:10.1177/0272989X13485157}] 12 | } 13 | \examples{ 14 | # Build a model similar to Program 1(a) from Dias et al. (2013b): 15 | regressor <- list(coefficient='shared', 16 | variable='secondary', 17 | control='control') 18 | 19 | model <- mtc.model(hfPrevention, 20 | type="regression", 21 | regressor=regressor, 22 | hy.prior=mtc.hy.prior("std.dev", "dunif", 0, 5)) 23 | 24 | \dontrun{ 25 | result <- mtc.run(model)} 26 | } 27 | -------------------------------------------------------------------------------- /gemtc/man/read.mtc.network.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{read.mtc.network} 3 | \alias{read.mtc.network} 4 | 5 | \title{Read mtc.network from legacy GeMTC XML files (.gemtc)} 6 | \description{Read legacy GeMTC XML (.gemtc) files.} 7 | \usage{ 8 | read.mtc.network(file) 9 | } 10 | \arguments{ 11 | \item{file}{Path to the file to read (\code{read.mtc.network}).} 12 | } 13 | \value{ 14 | \code{read.mtc.network} returns an object of S3 class \code{mtc.network}. 15 | } 16 | \details{ 17 | \code{read.mtc.network} exists to migrate data from the older GeMTC XML format, and requires the \code{XML} package to be installed. 18 | 19 | Support for writing XML files has been removed. 20 | Instead, use native R methods to read and write networks (e.g. save/load or dput/dget). 21 | } 22 | \author{Gert van Valkenhoef} 23 | \seealso{ 24 | \code{\link{mtc.network}} 25 | } 26 | \examples{ 27 | # Read an example GeMTC XML file 28 | file <- system.file("extdata/luades-smoking.gemtc", package="gemtc") 29 | network <- read.mtc.network(file) 30 | 31 | # Summarize the network (generate some interesting network properties) 32 | summary(network) 33 | ## $Description 34 | ## [1] "MTC dataset: Smoking cessation rates" 35 | ## 36 | ## $`Studies per treatment` 37 | ## A B C D 38 | ## 19 6 19 6 39 | ## 40 | ## $`Number of n-arm studies` 41 | ## 2-arm 3-arm 42 | ## 22 2 43 | } 44 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-inits.to.monitors.R: -------------------------------------------------------------------------------- 1 | context("inits.to.monitors") 2 | 3 | test_that("inits.to.monitors maps scalars", { 4 | expect_that(inits.to.monitors(list(sd.d=3)), equals(c("sd.d"))) 5 | }) 6 | 7 | test_that("inits.to.monitors maps vectors", { 8 | expect_that(inits.to.monitors(list(mu=c(1, -1, 3))), equals(c("mu[1]", "mu[2]", "mu[3]"))) 9 | }) 10 | 11 | test_that("inits.to.monitors removes NAs from vectors", { 12 | expect_that(inits.to.monitors(list(mu=c(1, NA, 3))), equals(c("mu[1]", "mu[3]"))) 13 | }) 14 | 15 | test_that("inits.to.monitors maps matrices", { 16 | expect_that(inits.to.monitors(list(delta=matrix(c(5, 3, -1, 2, 4, 5), ncol=3, byrow=TRUE))), 17 | equals(c("delta[1,1]", "delta[1,2]", "delta[1,3]", "delta[2,1]", "delta[2,2]", "delta[2,3]"))) 18 | }) 19 | 20 | test_that("inits.to.monitors removes NAs from matrices", { 21 | expect_that(inits.to.monitors(list(delta=matrix(c(NA, 3, NA, NA, 4, 5), ncol=3, byrow=TRUE))), 22 | equals(c("delta[1,2]", "delta[2,2]", "delta[2,3]"))) 23 | }) 24 | 25 | test_that("inits.to.monitors adds sd.d if var.d is present", { 26 | expect_that(inits.to.monitors(list(var.d=2)), 27 | equals(c("var.d", "sd.d"))) 28 | }) 29 | 30 | test_that("inits.to.monitors adds sd.d if tau.d is present", { 31 | expect_that(inits.to.monitors(list(tau.d=2)), 32 | equals(c("tau.d", "sd.d"))) 33 | }) 34 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-1.out.txt: -------------------------------------------------------------------------------- 1 | structure(list(study = c("1", "1", "2", "2", "3", "3", "4", "4", 2 | "5", "5", "6", "6", "7", "7", "8", "8", "9", "9", "10", "10", 3 | "11", "11", "12", "12", "13", "13", "14", "14", "15", "15", "16", 4 | "16", "17", "17", "18", "18", "19", "19", "20", "20", "21", "21", 5 | "22", "22"), treatment = c("Control", "BetaB", "Control", "BetaB", 6 | "Control", "BetaB", "Control", "BetaB", "Control", "BetaB", "Control", 7 | "BetaB", "Control", "BetaB", "Control", "BetaB", "Control", "BetaB", 8 | "Control", "BetaB", "Control", "BetaB", "Control", "BetaB", "Control", 9 | "BetaB", "Control", "BetaB", "Control", "BetaB", "Control", "BetaB", 10 | "Control", "BetaB", "Control", "BetaB", "Control", "BetaB", "Control", 11 | "BetaB", "Control", "BetaB", "Control", "BetaB"), responders = c(3L, 12 | 3L, 14L, 7L, 11L, 5L, 127L, 102L, 27L, 28L, 6L, 4L, 152L, 98L, 13 | 48L, 60L, 37L, 25L, 188L, 138L, 52L, 64L, 47L, 45L, 16L, 9L, 14 | 45L, 57L, 31L, 25L, 38L, 33L, 12L, 28L, 6L, 8L, 3L, 6L, 40L, 15 | 32L, 43L, 27L, 39L, 22L), sampleSize = c(39L, 38L, 116L, 114L, 16 | 93L, 69L, 1520L, 1533L, 365L, 355L, 52L, 59L, 939L, 945L, 471L, 17 | 632L, 282L, 278L, 1921L, 1916L, 583L, 873L, 266L, 263L, 293L, 18 | 291L, 883L, 858L, 147L, 154L, 213L, 207L, 122L, 251L, 154L, 151L, 19 | 134L, 174L, 218L, 209L, 364L, 391L, 674L, 680L)), row.names = c(NA, 20 | -44L), class = "data.frame") 21 | -------------------------------------------------------------------------------- /gemtc/man/certolizumab.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{certolizumab} 3 | \alias{certolizumab} 4 | \title{Certolizumab Pegol (CZP) for Rheumatoid Arthritis} 5 | \description{A dataset of 12 trials investigating 6 treatments and placebo for rheumatoid arthritis. The main outcome is the number of patients who improved by at least 50\% on the American College of Rheumatology scale (ACR50) at 6 Months. A covariate is present for the mean disease duration at baseline (years).} 6 | \format{A network meta-regression dataset containing 24 rows of arm-based data (responders and sample size).} 7 | \source{ 8 | S. Dias, A.J. Sutton, N.J. Welton, and A.E. Ades (2013b), 9 | \emph{Heterogeneity - Subgroups, Meta-Regression, Bias, and Bias-Adjustment}, 10 | Medical Decision Making 33(5):618-640. \cr 11 | [\href{https://doi.org/10.1177/0272989X13485157}{doi:10.1177/0272989X13485157}] 12 | } 13 | \examples{ 14 | # Run RE regression model with informative heterogeneity prior 15 | 16 | regressor <- list(coefficient='shared', 17 | variable='diseaseDuration', 18 | control='Placebo') 19 | 20 | # sd ~ half-Normal(mean=0, sd=0.32) 21 | hy.prior <- mtc.hy.prior(type="std.dev", distr="dhnorm", 0, 9.77) 22 | 23 | model <- mtc.model(certolizumab, 24 | type="regression", 25 | regressor=regressor, 26 | hy.prior=hy.prior) 27 | 28 | \dontrun{ 29 | result <- mtc.run(model)} 30 | } 31 | -------------------------------------------------------------------------------- /gemtc/man/mtc.deviance.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{mtc.deviance} 3 | \alias{mtc.deviance} 4 | \alias{plot.mtc.deviance} 5 | \alias{mtc.devplot} 6 | \alias{mtc.levplot} 7 | 8 | \title{Inspect residual deviance} 9 | \description{Inspect the posterior residual deviance and summarize it using plots} 10 | \usage{ 11 | mtc.deviance(result) 12 | 13 | mtc.devplot(x, ...) 14 | mtc.levplot(x, ...) 15 | 16 | \method{plot}{mtc.deviance}(x, auto.layout=TRUE, ...) 17 | } 18 | %- maybe also 'usage' for other objects documented here. 19 | \arguments{ 20 | \item{result}{An object of class \code{\link{mtc.result}}.} 21 | \item{x}{An object of class \code{\link{mtc.deviance}}.} 22 | \item{auto.layout}{If \code{TRUE}, the separate plots will be shown as panels on a single page.} 23 | \item{...}{Graphical parameters.} 24 | } 25 | \value{ 26 | \code{mtc.deviance} returns the deviance statistics of a \code{mtc.result}. 27 | } 28 | \details{ 29 | \code{mtc.devplot} will generate a stem plot of the posterior deviance per arm (if there are only arm-based data) or the mean per data point deviance per study (if there are contrast-based data). 30 | 31 | \code{mtc.levplot} will plot the leverage versus the square root of the residual deviance (mean per data point for each study). 32 | 33 | The generic plot function will display both on a single page (unless \code{auto.layout=FALSE}). 34 | } 35 | \author{Gert van Valkenhoef} 36 | 37 | \seealso{ 38 | \code{\link{mtc.run}} 39 | } 40 | -------------------------------------------------------------------------------- /afstroke-data.csv: -------------------------------------------------------------------------------- 1 | study,treatment,stroke,responders,sampleSize 2 | AFASAK 1,1,0.06,19,336 3 | AFASAK 1,3,,9,335 4 | AFASAK 1,5,,16,336 5 | BAATAF,1,0.03,13,208 6 | BAATAF,2,,3,212 7 | SPAF 1,1,0.08,19,211 8 | SPAF 1,3,,8,210 9 | SPAF 1,5,,25,552 10 | CAFA,1,0.04,9,191 11 | CAFA,3,,6,87 12 | SPINAF,1,0.08,23,290 13 | SPINAF,2,,7,281 14 | EAFT,1,1,50,214 15 | EAFT,3,,20,225 16 | EAFT,6,,88,404 17 | SPAF 2a,3,0.06,19,358 18 | SPAF 2a,6,,21,357 19 | SPAF 2b,3,0.09,20,197 20 | SPAF 2b,6,,21,188 21 | SPAF 3,3,0.38,14,523 22 | SPAF 3,13,,48,521 23 | SPAF 3,14,,48,521 24 | SIFA,3,1,18,454 25 | SIFA,11,,23,462 26 | ESPS 2,1,1,23,107 27 | ESPS 2,5,,17,104 28 | ESPS 2,12,,20,114 29 | ESPS 2,17,,14,104 30 | AFASAK 2,3,0.1,11,170 31 | AFASAK 2,4,,14,167 32 | AFASAK 2,6,,9,169 33 | AFASAK 2,13,,11,171 34 | AFASAK 2,14,,11,171 35 | MWNAF,3,0,1,153 36 | MWNAF,4,,5,150 37 | PATAF,2,0,4,122 38 | PATAF,3,,3,131 39 | PATAF,5,,4,141 40 | LASAF,1,0,3,91 41 | LASAF,5,,4,104 42 | LASAF,8,,1,90 43 | UK-TIA,1,1,4,15 44 | UK-TIA,6,,3,13 45 | UK-TIA,7,,5,21 46 | JNAFESP,2,1,2,60 47 | JNAFESP,3,,2,55 48 | SPORTIF 3,3,0.24,58,1703 49 | SPORTIF 3,9,,42,1704 50 | SAFT,1,0,41,334 51 | SAFT,13,,32,334 52 | NASPEAF,3,0,6,237 53 | NASPEAF,10,,11,242 54 | NASPEAF,15,,3,235 55 | SPORTIF 5,3,0.19,44,1962 56 | SPORTIF 5,9,,52,1960 57 | JAST,1,0.03,19,445 58 | JAST,5,,20,426 59 | ACTIVE-W,3,0.15,65,3371 60 | ACTIVE-W,16,,106,3335 61 | Chinese ATAFS,3,0.19,9,335 62 | Chinese ATAFS,5,,17,369 63 | BAFTA,3,0.13,21,488 64 | BAFTA,5,,44,485 65 | WASPO,3,0,0,36 66 | WASPO,6,,0,39 67 | -------------------------------------------------------------------------------- /gemtc/src/rank.c: -------------------------------------------------------------------------------- 1 | #include "gemtc.h" 2 | 3 | typedef struct Matrix { 4 | int * const data; 5 | int const nRow; 6 | int const nCol; 7 | } Matrix; 8 | 9 | /** 10 | * @param i Row index. 11 | * @param j Column index. 12 | */ 13 | static inline int *get(Matrix *m, int i, int j) { 14 | return m->data + j * (m->nRow) + i; 15 | } 16 | 17 | /** 18 | * Rank the n-array of doubles t, writing results to r. 19 | * The rank of t[i] is the number of elements greater than t[i]. 20 | * Assumes that n is small (complexity O(n^2)). 21 | */ 22 | static inline void rank(double const *t, int *r, int n) { 23 | for (int i = 0; i < n; ++i) { 24 | r[i] = 0; 25 | for (int j = 0; j < n; ++j) { 26 | if (t[j] > t[i]) { 27 | ++r[i]; 28 | } 29 | } 30 | } 31 | } 32 | 33 | SEXP gemtc_rank_count(SEXP _t) { 34 | int const nIter = ncols(_t); 35 | int const nAlt = nrows(_t); 36 | 37 | _t = PROTECT(coerceVector(_t, REALSXP)); 38 | double const *t = REAL(_t); 39 | 40 | SEXP _result = PROTECT(allocMatrix(INTSXP, nAlt, nAlt)); 41 | Matrix c = { INTEGER(_result), nAlt, nAlt }; 42 | for (int i = 0; i < nAlt; ++i) { 43 | for (int j = 0; j < nAlt; ++j) { 44 | *get(&c, i, j) = 0; 45 | } 46 | } 47 | 48 | int r[nAlt]; // alternative ranks 49 | for (int k = 0; k < nIter; ++k) { 50 | rank(t, r, nAlt); // rank the alternatives 51 | 52 | for (int i = 0; i < nAlt; ++i) { 53 | *get(&c, r[i], i) += 1; // update rank counts 54 | } 55 | 56 | t += nAlt; 57 | } 58 | 59 | UNPROTECT(2); 60 | return _result; 61 | } 62 | -------------------------------------------------------------------------------- /gemtc/man/plotCovariateEffect.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{plotCovariateEffect} 3 | \alias{plotCovariateEffect} 4 | \title{Plot treatment effects versus covariate values} 5 | \description{ 6 | The plot will show the median treatment effect and the 95\% credible interval on the y-axis and the covariate value on the x-axis. 7 | One plot page will be generated per pair of treatments. 8 | } 9 | \usage{ 10 | plotCovariateEffect(result, t1, t2, xlim=NULL, ylim=NULL, 11 | ask=dev.interactive(orNone=TRUE)) 12 | } 13 | \arguments{ 14 | \item{result}{Results object - created by \code{mtc.result}} 15 | \item{t1}{A list of baseline treatments to calculate treatment effects against. Will be extended to match the length of t2.} 16 | \item{t2}{A list of treatments to calculate the effects for. Will be extended to match the length of t1. 17 | If left empty and t1 is a single treatment, effects of all treatments except t1 will be calculated.} 18 | \item{xlim}{The x-axis limits.} 19 | \item{ylim}{The y-axis limits.} 20 | \item{ask}{If TRUE, a prompt will be displayed before generating the next page of a multi-page plot.} 21 | } 22 | \details{ 23 | Default x-axis limits will be set to three standard deviations above and below the centering value of the covariate. 24 | The y-axis limits will be set based on the minimum and maximum 95\% CrI limits among the set of effects computed. 25 | } 26 | \value{ 27 | None. 28 | } 29 | \author{Gert van Valkenhoef} 30 | \seealso{ 31 | \code{\link{relative.effect}}, \code{\link{mtc.run}} 32 | } 33 | -------------------------------------------------------------------------------- /gemtc/R/ll.normal.identity.R: -------------------------------------------------------------------------------- 1 | #' @include likelihoods.R 2 | 3 | # Arm-level effect estimate (given a one-row data frame) 4 | mtc.arm.mle.normal.identity <- function(data, k=0.5) { 5 | c('mean'=as.numeric(data['mean']), 'sd'=as.numeric(data['std.err'])) 6 | } 7 | 8 | # Relative effect estimate (given a two-row data frame 9 | mtc.rel.mle.normal.identity <- function(data, correction.force=TRUE, correction.type="constant", correction.magnitude=1) { 10 | e1 <- mtc.arm.mle.normal.identity(data[1,]) 11 | e2 <- mtc.arm.mle.normal.identity(data[2,]) 12 | c(e2['mean'] - e1['mean'], sqrt(e1['sd']^2 + e2['sd']^2)) 13 | } 14 | 15 | mtc.code.likelihood.normal.identity <- function(powerAdjust) { 16 | paste("theta[i, k] <- $armLinearModel$", likelihood.code.normal[powerAdjust + 1], sep="\n") 17 | } 18 | 19 | fitted.values.parameter.normal.identity <- fitted.values.parameter.normal 20 | deviance.normal.identity <- deviance.normal 21 | 22 | scale.log.normal.identity <- function() { FALSE } 23 | scale.name.normal.identity <- function() { "Mean Difference" } 24 | 25 | inits.info.normal.identity <- function() { 26 | list( 27 | limits=c(-Inf, +Inf), 28 | param='mu', 29 | transform=identity) 30 | } 31 | 32 | required.columns.ab.normal.identity <- function() { 33 | c('m'='mean', 'e'='std.err') 34 | } 35 | 36 | validate.data.normal.identity <- function(data.ab) { 37 | stopifnot(all(data.ab[['std.err']] > 0)) 38 | } 39 | 40 | study.baseline.priors.normal.identity <- function() { 41 | "for (i in studies.a) { 42 | mu[i] ~ dnorm(0, prior.prec) 43 | } 44 | " 45 | } 46 | -------------------------------------------------------------------------------- /gemtc/R/mtc.data.studyrow.R: -------------------------------------------------------------------------------- 1 | mtc.data.studyrow <- function(data, 2 | armVars=c('treatment'='t', 'responders'='r', 'sampleSize'='n'), 3 | nArmsVar='na', studyVars=c(), 4 | studyNames=1:nrow(data), treatmentNames=NA, 5 | patterns=c('%s..', '%s..%d.')) { 6 | 7 | studyNames <- as.character(studyNames) 8 | 9 | colsOrNA <- function(row, cols) { 10 | rval <- rep(NA, length(cols)) 11 | sel <- cols %in% colnames(row) 12 | rval[sel] <- row[cols[sel]] 13 | rval 14 | } 15 | 16 | nArmsCol <- sprintf(patterns[1], nArmsVar) 17 | studyCols <- sprintf(patterns[1], studyVars) 18 | 19 | out <- do.call(rbind, lapply(1:nrow(data), function(i) { 20 | row <- data[i,] 21 | na <- row[nArmsCol] 22 | studyEntries <- row[studyCols] 23 | names(studyEntries) <- names(studyVars) 24 | do.call(rbind, lapply(1:unlist(na), function(j) { 25 | armCols <- sprintf(patterns[2], armVars, j) 26 | armEntries <- colsOrNA(row, armCols) 27 | names(armEntries) <- names(armVars) 28 | c(list('study'=i), studyEntries, armEntries) 29 | })) 30 | })) 31 | 32 | colNames <- colnames(out) 33 | out <- lapply(colnames(out), function(col) { 34 | unlist(out[,col]) 35 | }) 36 | names(out) <- colNames 37 | 38 | out[['study']] <- studyNames[out[['study']]] 39 | if (all(!is.na(treatmentNames))) { 40 | out[['treatment']] <- treatmentNames[out[['treatment']]] 41 | } else { 42 | out[['treatment']] <- as.character(out[['treatment']]) 43 | } 44 | out[['stringsAsFactors']] <- FALSE 45 | do.call(data.frame, out) 46 | } 47 | -------------------------------------------------------------------------------- /gemtc/tests/data/dietfat.re.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(6010.91813446356, 2 | 1428.60500515852), .Names = c("d.control.diet", "sd.d")), summary = structure(list( 3 | statistics = structure(c(-0.0138621842733287, 0.134696044870237, 4 | 0.090505271825022, 0.121416291517638, 0.000319984457203024, 5 | 0.000429271415393222, 0.00118719005156229, 0.00321004646676098 6 | ), .Dim = c(2L, 4L), .Dimnames = list(c("d.control.diet", 7 | "sd.d"), c("Mean", "SD", "Naive SE", "Time-series SE"))), 8 | quantiles = structure(c(-0.196956964956764, 0.00514998536486905, 9 | -0.0638059724036764, 0.0478537227781431, -0.0143086024444535, 10 | 0.103100704484174, 0.0380008035675889, 0.184911494352956, 11 | 0.162834437851103, 0.451120504851119), .Dim = c(2L, 5L), .Dimnames = list( 12 | c("d.control.diet", "sd.d"), c("2.5%", "25%", "50%", 13 | "75%", "97.5%"))), start = 5001, end = 25000, thin = 1, 14 | nchain = 4L), .Names = c("statistics", "quantiles", "start", 15 | "end", "thin", "nchain"), class = "summary.mcmc"), cov = structure(0.00819120422812111, .Dim = c(1L, 16 | 1L)), ranks = structure(c(0.575775, 0.424225, 0.424225, 0.575775 17 | ), .Dim = c(2L, 2L), .Dimnames = list(c("control", "diet"), NULL), class = "mtc.rank.probability", direction = 1), 18 | dic = structure(list(Dbar = 20.9592507798904, pD = 13.5301447471747, 19 | DIC = 34.4893955270651, `data points` = 20L), .Names = c("Dbar", 20 | "pD", "DIC", "data points"))), .Names = c("effectiveSize", 21 | "summary", "cov", "ranks", "dic")) 22 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-relative.effect.table.R: -------------------------------------------------------------------------------- 1 | context("relative.effect.table") 2 | 3 | test_that("it works for the smoking example", { 4 | smoking_result <- dget(system.file("extdata/luades-smoking.samples.gz", package="gemtc")) 5 | smoking_table <- relative.effect.table(smoking_result) 6 | 7 | # Check dimnames 8 | expect_that(rownames(smoking_table), equals(c("A", "B", "C", "D"))) 9 | expect_that(colnames(smoking_table), equals(c("A", "B", "C", "D"))) 10 | 11 | # Check that the diagonal contains NA 12 | expect_that(diag(smoking_table[,,2]), is_equivalent_to(as.numeric(rep(NA, 4)))) 13 | 14 | # Check that off-diagonal entries contain the quantiles 15 | q <- function(q1, q2, q3) { c("2.5%"=q1, "50%"=q2, "97.5%"=q3) } 16 | expect_that(smoking_table[1,2,], equals(q(-0.29846826342809, 0.490982134423406, 1.34066639613713))) 17 | expect_that(smoking_table[1,3,], equals(q(0.387798548149361, 0.827333271108623, 1.3530539185826))) 18 | expect_that(smoking_table[1,4,], equals(q(0.269236199821778, 1.09825953831406, 2.00604408009687))) 19 | expect_that(smoking_table[2,3,], equals(q(-0.480946561958643, 0.341121326321452, 1.17021895949004))) 20 | expect_that(smoking_table[2,4,], equals(q(-0.308278534656184, 0.604352628567083, 1.57902423190838))) 21 | expect_that(smoking_table[3,4,], equals(q(-0.532179016795455, 0.261896715203374, 1.11556777887809))) 22 | expect_that(smoking_table[2,1,], equals(q(-1.34066639613713, -0.490982134423406, 0.29846826342809))) 23 | 24 | expect_that(attr(smoking_table, "model"), equals(smoking_result[['model']])) 25 | expect_that(smoking_table, is_a("mtc.relative.effect.table")) 26 | }) 27 | -------------------------------------------------------------------------------- /gemtc/R/solveLP.R: -------------------------------------------------------------------------------- 1 | #' @param obj Numeric vector of objective coefficients 2 | #' @param mat Numeric matrix of constraint coefficients 3 | #' @param rhs Numeric vector of constraint right-hand sides 4 | #' @param eq Logical vector; TRUE for equality, FALSE for <= 5 | #' @param max Logical scalar; TRUE for maximize, FALSE for minimize 6 | solveLP <- function(obj, mat, rhs, eq, max=FALSE) { 7 | # Solution using RCDD (results in memory corruption...) 8 | # constraints <- cbind(eq, rhs, -mat) 9 | # sol <- rcdd::lpcdd(constraints, obj, minimize=!max) 10 | # if (sol$solution.type == "Optimal") { 11 | # sol$optimal.value 12 | # } else if (sol$solution.type == "DualInconsistent" || sol$solution.type == "StrucDualInconsistent") { 13 | # if (max) { +Inf } else { -Inf } 14 | # } else { 15 | # stop(paste("LP solver:", sol$solution.type)) 16 | # } 17 | 18 | # Solution using Rglpk 19 | GLP_OPT <- 5 # solution is optimal 20 | GLP_UNBND <- 6 # solution is unbounded 21 | status <- c("solution is undefined", "solution is feasible", "solution is infeasible", "no feasible solution exists", "solution is optimal", "solution is unbounded") 22 | 23 | dir <- c("<=", "==")[eq + 1] 24 | m <- ncol(mat) 25 | # Explicitly set bounds to (-Inf, +Inf) - the default is [0, +Inf) 26 | bounds <- list(lower=list(ind=1:m, val=rep(-Inf, m)), 27 | upper=list(ind=1:m, val=rep(+Inf, m))) 28 | sol <- Rglpk::Rglpk_solve_LP(obj, mat, dir, rhs, max=max, bounds=bounds, control = list(canonicalize_status=FALSE)) 29 | if (sol$status == GLP_OPT) { 30 | sol$optimum 31 | } else if (sol$status == GLP_UNBND) { 32 | if (max) { +Inf } else { -Inf } 33 | } else { 34 | stop(paste("LP solver:", status[sol$status])) 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /gemtc/R/arrayize.R: -------------------------------------------------------------------------------- 1 | #'From a named vector with "BUGS format" names (v[1], m[2,3]), create a list of vectors and matrices 2 | arrayize <- function(x) { 3 | # parse expressions into array indexes 4 | exprs <- parse(text=names(x)) 5 | assgn <- lapply(exprs, function(expr) { 6 | if (class(expr) == "name") { 7 | list(name=as.character(expr), index=c()) 8 | } else if (expr[[1]] == "[") { 9 | list(name=as.character(expr[[2]]), index=sapply(3:length(expr), function(i) { expr[[i]] })) 10 | } else { 11 | stop("Unrecognized expression") 12 | } 13 | }) 14 | 15 | # find the unique variables and their dimension 16 | vars <- list() 17 | for (a in assgn) { 18 | name <- a[['name']] 19 | index <- a[['index']] 20 | if (!is.null(vars[[name]])) { 21 | stopifnot(length(index) == length(vars[[name]])) 22 | vars[[name]] <- pmax(vars[[name]], index) 23 | } else { 24 | vars[[name]] <- index 25 | } 26 | } 27 | 28 | # allocate the variables 29 | vars <- lapply(vars, function(dim) { 30 | if (length(dim) == 0) { 31 | NA 32 | } else if (length(dim) == 1) { 33 | rep(NA, dim[1]) 34 | } else if (length(dim) == 2) { 35 | matrix(NA, nrow=dim[1], ncol=dim[2]) 36 | } else { 37 | stop("higher dimensional objects not supported") 38 | } 39 | }) 40 | 41 | # assign values 42 | for (i in 1:length(x)) { 43 | name <- assgn[[i]][['name']] 44 | index <- assgn[[i]][['index']] 45 | if (length(index) == 0) { 46 | vars[[name]] <- unname(x[i]) 47 | } else if (length(index) == 1) { 48 | vars[[name]][index[1]] <- unname(x[i]) 49 | } else if (length(index) == 2) { 50 | vars[[name]][index[1], index[2]] <- unname(x[i]) 51 | } 52 | } 53 | 54 | vars[order(names(vars))] 55 | } 56 | -------------------------------------------------------------------------------- /gemtc/inst/extdata/parkinson.gemtc: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /gemtc/R/mtc.hy.prior.R: -------------------------------------------------------------------------------- 1 | as.character.mtc.hy.prior <- function(x, ...) { 2 | type <- x[['type']] 3 | distr <- x[['distr']] 4 | args <- x[['args']] 5 | 6 | expr <- if (distr == "dhnorm") { 7 | paste0("dnorm", "(", paste(args, collapse=", "), ") T(0,)") 8 | } else { 9 | paste0(distr, "(", paste(args, collapse=", "), ")") 10 | } 11 | 12 | if (type == "std.dev") { 13 | paste0("sd.d ~ ", expr, "\ntau.d <- pow(sd.d, -2)") 14 | } else if (type == "var") { 15 | paste0("var.d ~ ", expr, "\nsd.d <- sqrt(var.d)\ntau.d <- 1 / var.d") 16 | } else { 17 | paste0("tau.d ~ ", expr, "\nsd.d <- sqrt(1 / tau.d)") 18 | } 19 | } 20 | 21 | mtc.hy.prior <- function(type, distr, ...) { 22 | stopifnot(class(type) == "character") 23 | stopifnot(length(type) == 1) 24 | stopifnot(type %in% c('std.dev', 'var', 'prec')) 25 | 26 | obj <- list(type=type, distr=distr, args=list(...)) 27 | class(obj) <- "mtc.hy.prior" 28 | obj 29 | } 30 | 31 | hy.lor.outcomes <- c('mortality', 'semi-objective', 'subjective') 32 | hy.lor.comparisons <- c('pharma-control', 'pharma-pharma', 'non-pharma') 33 | 34 | hy.lor.mu <- matrix( 35 | c(-4.06, -3.02, -2.13, -4.27, -3.23, -2.34, -3.93, -2.89, -2.01), 36 | ncol=3, nrow=3, 37 | dimnames=list(hy.lor.outcomes, hy.lor.comparisons)) 38 | 39 | hy.lor.sigma <- matrix( 40 | c(1.45, 1.85, 1.58, 1.48, 1.88, 1.62, 1.51, 1.91, 1.64), 41 | ncol=3, nrow=3, 42 | dimnames=list(hy.lor.outcomes, hy.lor.comparisons)) 43 | 44 | mtc.hy.empirical.lor <- function(outcome.type, comparison.type) { 45 | stopifnot(outcome.type %in% hy.lor.outcomes) 46 | stopifnot(comparison.type %in% hy.lor.comparisons) 47 | mtc.hy.prior("var", "dlnorm", 48 | hy.lor.mu[outcome.type, comparison.type], 49 | signif(hy.lor.sigma[outcome.type, comparison.type]^-2, digits=3)) 50 | } 51 | -------------------------------------------------------------------------------- /gemtc/R/rank.probability.R: -------------------------------------------------------------------------------- 1 | #' @include stopIfNotConsistent.R 2 | 3 | rank.probability <- function(result, preferredDirection=1, covariate=NA) { 4 | stopIfNotConsistent(result, 'rank.probability') 5 | 6 | stopifnot(preferredDirection %in% c(1, -1)) 7 | 8 | treatments <- sort(unique(as.vector(extract.comparisons(colnames(result[['samples']][[1]]))))) 9 | 10 | n.alt <- length(treatments) 11 | 12 | # count ranks given a matrix d of relative effects (treatments as rows) 13 | rank.count <- function(d) { 14 | .Call(gemtc_rank_count, d) 15 | } 16 | 17 | d <- relative.effect(result, treatments[1], treatments, covariate=covariate, preserve.extra=FALSE)[['samples']] 18 | ranks <- rank.count(t(as.matrix(d))) 19 | colnames(ranks) <- treatments 20 | 21 | data <- result[['samples']] 22 | n.iter <- nchain(data) * (end(data) - start(data) + thin(data)) / thin(data) 23 | 24 | result <- t(ranks / n.iter) 25 | if (identical(preferredDirection, -1)) { 26 | result <- result[,ncol(result):1] 27 | } 28 | class(result) <- "mtc.rank.probability" 29 | attr(result, "direction") <- preferredDirection 30 | result 31 | } 32 | 33 | sucra <- function(ranks) { 34 | apply(ranks, 1, function(p) { 35 | a <- length(p) 36 | sum(cumsum(p[-a]))/(a-1) 37 | }) 38 | } 39 | 40 | rank.quantiles <- function(ranks, probs=c("2.5%"=0.025, "50%"=0.5, "97.5%"=0.975)) { 41 | sapply(probs, function(x) { 42 | apply(ranks, 1, function(p) { 43 | which(cumsum(p) >= x)[1] 44 | }) 45 | }) 46 | } 47 | 48 | print.mtc.rank.probability <- function(x, ...) { 49 | cat(paste("Rank probability; preferred direction = ", attr(x, "direction"), "\n", sep="")) 50 | attr(x, "direction") <- NULL 51 | print(unclass(x), ...) 52 | } 53 | 54 | plot.mtc.rank.probability <- function(x, ...) { 55 | barplot(t(x), ...) 56 | } 57 | -------------------------------------------------------------------------------- /gemtc/man/atrialFibrillation.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{atrialFibrillation} 3 | \alias{atrialFibrillation} 4 | \title{Prevention of stroke in atrial fibrillation patients} 5 | \description{A dataset of 25 trials investigating 17 treatments for stroke prevention in atrial fibrillation patients. The main outcome is the number of patients with a stroke, and a covariate captures the proportion of patients with a prior stroke. 6 | 7 | Data are take from Table 1 of Cooper et al. (2009), with the following corrections applied: SPAF 3 and AFASAK 2 do not have a treatment 13 arm, and SPAF 1 does not contain treatment 5, but treatment 6. Thanks to prof. Cooper for providing the original analysis dataset.} 8 | \format{A network meta-regression dataset containing 60 rows of arm-based data (responders and sample size).} 9 | \source{ 10 | Cooper et al. (2009), 11 | \emph{Adressing between-study heterogeneity and inconsistency in mixed treatment comparisons: Application to stroke prevention treatments in individuals with non-rheumatic atrial fibrillation}, 12 | Statistics in Medicine 28:1861-1881. 13 | [\href{https://doi.org/10.1002/sim.3594}{doi:10.1002/sim.3594}] 14 | } 15 | \examples{ 16 | # Build a model similar to Model 4(b) from Cooper et al. (2009): 17 | classes <- list("control"=c("01"), 18 | "anti-coagulant"=c("02","03","04","09"), 19 | "anti-platelet"=c("05","06","07","08","10","11","12","16","17"), 20 | "mixed"=c("13","14","15")) 21 | 22 | regressor <- list(coefficient='shared', 23 | variable='stroke', 24 | classes=classes) 25 | 26 | model <- mtc.model(atrialFibrillation, 27 | type="regression", 28 | regressor=regressor, 29 | om.scale=10) 30 | 31 | \dontrun{ 32 | result <- mtc.run(model)} 33 | } 34 | -------------------------------------------------------------------------------- /gemtc/R/ll.binom.log.R: -------------------------------------------------------------------------------- 1 | #' @include ll-helper.counts.R 2 | #' @include likelihoods.R 3 | 4 | # Arm-level effect estimate (given a one-row data frame) 5 | # Returns mean, standard deviation. 6 | mtc.arm.mle.binom.log <- function(data, k=0.5) { 7 | s <- unname(data['responders'] + k) 8 | f <- unname(data['sampleSize'] + 2 * k) 9 | c('mean'=log(s/f), 'sd'=sqrt(1/s - 1/f)) 10 | } 11 | 12 | # Relative effect estimate (given a two-row data frame) 13 | mtc.rel.mle.binom.log <- function(data, correction.force=TRUE, correction.type="constant", correction.magnitude=1) { 14 | correction <- correction.counts(data, correction.force, correction.type, correction.magnitude) 15 | 16 | e1 <- mtc.arm.mle.binom.log(data[1,], correction[1]) 17 | e2 <- mtc.arm.mle.binom.log(data[2,], correction[2]) 18 | c(e2['mean'] - e1['mean'], sqrt(e1['sd']^2 + e2['sd']^2)) 19 | } 20 | 21 | mtc.code.likelihood.binom.log <- function(powerAdjust) { 22 | paste("log(p[i, k]) <- min($armLinearModel$, -1E-16)", likelihood.code.binom[powerAdjust + 1], sep="\n") 23 | } 24 | 25 | fitted.values.parameter.binom.log <- fitted.values.parameter.binom 26 | deviance.binom.log <- deviance.binom 27 | 28 | scale.log.binom.log <- function() { TRUE } 29 | scale.name.binom.log <- function() { "Risk Ratio" } 30 | 31 | # Initial values outside this range result in probability 0 or 1 for the 32 | # binomial, which may lead to BUGS/JAGS rejecting the data 33 | inits.info.binom.log <- function() { 34 | list( 35 | limits=c(-745, -1E-7), 36 | param='p.base', 37 | transform=exp) 38 | } 39 | 40 | required.columns.ab.binom.log <- required.columns.counts 41 | validate.data.binom.log <- validate.data.counts 42 | 43 | study.baseline.priors.binom.log <- function() { 44 | "for (i in studies.a) { 45 | mu[i] <- log(p.base[i]) 46 | p.base[i] ~ dunif(0, 1) 47 | } 48 | " 49 | } 50 | -------------------------------------------------------------------------------- /gemtc/R/ll.binom.logit.R: -------------------------------------------------------------------------------- 1 | #' @include ll-helper.counts.R 2 | #' @include likelihoods.R 3 | 4 | # Arm-level effect estimate (given a one-row data frame) 5 | # Returns mean, standard deviation. 6 | mtc.arm.mle.binom.logit <- function(data, k=0.5) { 7 | s <- unname(data['responders'] + k) 8 | f <- unname(data['sampleSize'] - s + 2 * k) 9 | c('mean'=log(s/f), 'sd'=sqrt(1/s + 1/f)) 10 | } 11 | 12 | # Relative effect estimate (given a two-row data frame) 13 | mtc.rel.mle.binom.logit <- function(data, correction.force=TRUE, correction.type="constant", correction.magnitude=1) { 14 | correction <- correction.counts(data, correction.force, correction.type, correction.magnitude) 15 | 16 | e1 <- mtc.arm.mle.binom.logit(data[1,], k=correction[1]) 17 | e2 <- mtc.arm.mle.binom.logit(data[2,], k=correction[2]) 18 | 19 | c(e2['mean'] - e1['mean'], sqrt(e1['sd']^2 + e2['sd']^2)) 20 | } 21 | 22 | mtc.code.likelihood.binom.logit <- function(powerAdjust) { 23 | paste("logit(p[i, k]) <- $armLinearModel$", likelihood.code.binom[powerAdjust + 1], sep="\n") 24 | } 25 | 26 | fitted.values.parameter.binom.logit <- fitted.values.parameter.binom 27 | deviance.binom.logit <- deviance.binom 28 | 29 | scale.log.binom.logit <- function() { TRUE } 30 | scale.name.binom.logit <- function() { "Odds Ratio" } 31 | 32 | # Initial values outside this range result in probability 0 or 1 for the 33 | # binomial, which may lead to BUGS/JAGS rejecting the data 34 | inits.info.binom.logit <- function() { 35 | list( 36 | limits=c(-745, 36.8), 37 | param='mu', 38 | transform=identity) 39 | } 40 | 41 | required.columns.ab.binom.logit <- required.columns.counts 42 | validate.data.binom.logit <- validate.data.counts 43 | 44 | study.baseline.priors.binom.logit <- function() { 45 | "for (i in studies.a) { 46 | mu[i] ~ dnorm(0, prior.prec) 47 | } 48 | " 49 | } 50 | -------------------------------------------------------------------------------- /gemtc/tests/data/diabetes-surv.data.txt: -------------------------------------------------------------------------------- 1 | "study" "treatment" "responders" "sampleSize" "E" 2 | "1" "MRC-E" "Diuretic" 43 1081 5.8 3 | "2" "MRC-E" "Placebo" 34 2213 5.8 4 | "3" "MRC-E" "BB" 37 1102 5.8 5 | "4" "EWPH" "Diuretic" 29 416 4.7 6 | "5" "EWPH" "Placebo" 20 424 4.7 7 | "6" "SHEP" "Diuretic" 140 1631 3 8 | "7" "SHEP" "Placebo" 118 1578 3 9 | "8" "HAPPHY" "Diuretic" 75 3272 3.8 10 | "9" "HAPPHY" "BB" 86 3297 3.8 11 | "10" "ALLHAT" "Diuretic" 302 6766 4 12 | "11" "ALLHAT" "CCB" 154 3954 4 13 | "12" "ALLHAT" "ACEi" 119 4096 4 14 | "13" "INSIGHT" "Diuretic" 176 2511 3 15 | "14" "INSIGHT" "CCB" 136 2508 3 16 | "15" "ANBP-2" "Diuretic" 200 2826 4.1 17 | "16" "ANBP-2" "ACEi" 138 2800 4.1 18 | "17" "ALPINE" "Diuretic" 8 196 1 19 | "18" "ALPINE" "ARB" 1 196 1 20 | "19" "FEVER" "Placebo" 154 4870 3.3 21 | "20" "FEVER" "CCB" 177 4841 3.3 22 | "21" "DREAM" "Placebo" 489 2646 3 23 | "22" "DREAM" "ACEi" 449 2623 3 24 | "23" "HOPE" "Placebo" 155 2883 4.5 25 | "24" "HOPE" "ACEi" 102 2837 4.5 26 | "25" "PEACE" "Placebo" 399 3472 4.8 27 | "26" "PEACE" "ACEi" 335 3432 4.8 28 | "27" "CHARM" "Placebo" 202 2721 3.1 29 | "28" "CHARM" "ARB" 163 2715 3.1 30 | "29" "SCOPE" "Placebo" 115 2175 3.7 31 | "30" "SCOPE" "ARB" 93 2167 3.7 32 | "31" "AASK" "BB" 70 405 3.8 33 | "32" "AASK" "CCB" 32 202 3.8 34 | "33" "AASK" "ACEi" 45 410 3.8 35 | "34" "STOP-2" "BB" 97 1960 4 36 | "35" "STOP-2" "CCB" 95 1965 4 37 | "36" "STOP-2" "ACEi" 93 1970 4 38 | "37" "ASCOT" "BB" 799 7040 5.5 39 | "38" "ASCOT" "CCB" 567 7072 5.5 40 | "39" "NORDIL" "BB" 251 5059 4.5 41 | "40" "NORDIL" "CCB" 216 5095 4.5 42 | "41" "INVEST" "BB" 665 8078 4 43 | "42" "INVEST" "CCB" 569 8098 4 44 | "43" "CAPPP" "BB" 380 5230 6.1 45 | "44" "CAPPP" "ACEi" 337 5183 6.1 46 | "45" "LIFE" "BB" 320 3979 4.8 47 | "46" "LIFE" "ARB" 242 4020 4.8 48 | "47" "VALUE" "CCB" 845 5074 4.2 49 | "48" "VALUE" "ARB" 690 5087 4.2 50 | -------------------------------------------------------------------------------- /gemtc/R/mtc.model.consistency.R: -------------------------------------------------------------------------------- 1 | # Consistency model 2 | mtc.model.consistency <- function(model) { 3 | style.tree <- function(tree) { 4 | tree <- set.edge.attribute(tree, 'arrow.mode', value=2) 5 | tree <- set.edge.attribute(tree, 'color', value='black') 6 | tree <- set.edge.attribute(tree, 'lty', value=1) 7 | tree 8 | } 9 | model[['tree']] <- 10 | style.tree(minimum.diameter.spanning.tree(mtc.network.graph(model[['network']]))) 11 | 12 | model[['data']] <- mtc.model.data(model) 13 | model[['inits']] <- mtc.init(model) 14 | 15 | model[['code']] <- mtc.model.code(model, mtc.basic.parameters(model), consistency.relative.effect.matrix(model)) 16 | 17 | monitors <- inits.to.monitors(model[['inits']][[1]]) 18 | model[['monitors']] <- list( 19 | available=monitors, 20 | enabled=c(monitors[grep('^d\\.', monitors)], monitors[grep('^sd.d$', monitors)]) 21 | ) 22 | 23 | class(model) <- "mtc.model" 24 | 25 | model 26 | } 27 | 28 | mtc.model.name.consistency <- function(model) { 29 | "consistency" 30 | } 31 | 32 | func.param.matrix.consistency <- function(model, t1, t2) { 33 | tree.relative.effect(model[['tree']], t1, t2) 34 | } 35 | 36 | consistency.relative.effect.matrix <- function(model) { 37 | # Generate list of linear expressions 38 | params <- mtc.basic.parameters(model) 39 | tree <- model[['tree']] 40 | re <- tree.relative.effect(tree, V(tree)[1], t2=NULL) 41 | expr <- apply(re, 2, function(col) { paste(sapply(which(col != 0), function(i) { 42 | paste(if (col[i] == -1) "-" else "", params[i], sep="") 43 | }), collapse = " + ") }) 44 | expr <- sapply(1:length(expr), function(i) { paste('d[1, ', i + 1, '] <- ', expr[i], sep='') }) 45 | expr <- c('d[1, 1] <- 0', expr, 'for (i in 2:nt) {\n\tfor (j in 1:nt) {\n\t\td[i, j] <- d[1, j] - d[1, i]\n\t}\n}') 46 | paste(expr, collapse="\n") 47 | } 48 | -------------------------------------------------------------------------------- /gemtc/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: gemtc 2 | Version: 0.8-4 3 | Date: 2020-03-31 4 | Title: Network Meta-Analysis Using Bayesian Methods 5 | Author: Gert van Valkenhoef, Joel Kuiper 6 | Maintainer: Gert van Valkenhoef 7 | Description: Network meta-analyses (mixed treatment comparisons) in the Bayesian 8 | framework using JAGS. Includes methods to assess heterogeneity and 9 | inconsistency, and a number of standard visualizations. 10 | Depends: 11 | coda (>= 0.13) 12 | Imports: 13 | igraph (>= 1.0), 14 | meta (>= 2.1), 15 | plyr (>= 1.8), 16 | graphics, 17 | grDevices, 18 | stats, 19 | utils, 20 | grid, 21 | rjags (>= 4-0), 22 | truncnorm, 23 | Rglpk 24 | Suggests: 25 | testthat (>= 0.8), 26 | Matrix, 27 | XML (>= 3.6) 28 | URL: http://github.com/gertvv/gemtc 29 | License: GPL-3 30 | LazyData: true 31 | Collate: 32 | 'anohe.R' 33 | 'arrayize.R' 34 | 'blobbogram.R' 35 | 'template.R' 36 | 'code.R' 37 | 'data.R' 38 | 'deviance.R' 39 | 'forest.R' 40 | 'solveLP.R' 41 | 'inits.R' 42 | 'likelihoods.R' 43 | 'll-helper.counts.R' 44 | 'll.binom.cloglog.R' 45 | 'll.binom.log.R' 46 | 'll.binom.logit.R' 47 | 'll.call.R' 48 | 'll.normal.identity.R' 49 | 'll.poisson.log.R' 50 | 'minimum.diameter.spanning.tree.R' 51 | 'mtc.data.studyrow.R' 52 | 'mtc.hy.prior.R' 53 | 'mtc.model.R' 54 | 'mtc.model.consistency.R' 55 | 'mtc.model.nodesplit.R' 56 | 'mtc.model.regression.R' 57 | 'mtc.model.ume.R' 58 | 'mtc.model.use.R' 59 | 'mtc.network.R' 60 | 'mtc.network.xml.R' 61 | 'stopIfNotConsistent.R' 62 | 'mtc.result.R' 63 | 'mtc.run.R' 64 | 'nodesplit.R' 65 | 'plotCovariateEffect.R' 66 | 'priors.R' 67 | 'rank.probability.R' 68 | 'regression.R' 69 | 'relative.effect.R' 70 | 'relative.effect.table.R' 71 | RoxygenNote: 7.1.0 72 | -------------------------------------------------------------------------------- /gemtc/tests/data/studyrow/tsd2-3.out.txt: -------------------------------------------------------------------------------- 1 | structure(list(study = c("MRC-E", "MRC-E", "MRC-E", "EWPH", "EWPH", 2 | "SHEP", "SHEP", "HAPPHY", "HAPPHY", "ALLHAT", "ALLHAT", "ALLHAT", 3 | "INSIGHT", "INSIGHT", "ANBP-2", "ANBP-2", "ALPINE", "ALPINE", 4 | "FEVER", "FEVER", "DREAM", "DREAM", "HOPE", "HOPE", "PEACE", 5 | "PEACE", "CHARM", "CHARM", "SCOPE", "SCOPE", "AASK", "AASK", 6 | "AASK", "STOP-2", "STOP-2", "STOP-2", "ASCOT", "ASCOT", "NORDIL", 7 | "NORDIL", "INVEST", "INVEST", "CAPPP", "CAPPP", "LIFE", "LIFE", 8 | "VALUE", "VALUE"), time = c(5.8, 5.8, 5.8, 4.7, 4.7, 3, 3, 3.8, 9 | 3.8, 4, 4, 4, 3, 3, 4.1, 4.1, 1, 1, 3.3, 3.3, 3, 3, 4.5, 4.5, 10 | 4.8, 4.8, 3.1, 3.1, 3.7, 3.7, 3.8, 3.8, 3.8, 4, 4, 4, 5.5, 5.5, 11 | 4.5, 4.5, 4, 4, 6.1, 6.1, 4.8, 4.8, 4.2, 4.2), treatment = c("Diuretic", 12 | "Placebo", "BetaB", "Diuretic", "Placebo", "Diuretic", "Placebo", 13 | "Diuretic", "BetaB", "Diuretic", "CCB", "ACEi", "Diuretic", "CCB", 14 | "Diuretic", "ACEi", "Diuretic", "ARB", "Placebo", "CCB", "Placebo", 15 | "ACEi", "Placebo", "ACEi", "Placebo", "ACEi", "Placebo", "ARB", 16 | "Placebo", "ARB", "BetaB", "CCB", "ACEi", "BetaB", "CCB", "ACEi", 17 | "BetaB", "CCB", "BetaB", "CCB", "BetaB", "CCB", "BetaB", "ACEi", 18 | "BetaB", "ARB", "CCB", "ARB"), responders = c(43L, 34L, 37L, 19 | 29L, 20L, 140L, 118L, 75L, 86L, 302L, 154L, 119L, 176L, 136L, 20 | 200L, 138L, 8L, 1L, 154L, 177L, 489L, 449L, 155L, 102L, 399L, 21 | 335L, 202L, 163L, 115L, 93L, 70L, 32L, 45L, 97L, 95L, 93L, 799L, 22 | 567L, 251L, 216L, 665L, 569L, 380L, 337L, 320L, 242L, 845L, 690L 23 | ), sampleSize = c(1081L, 2213L, 1102L, 416L, 424L, 1631L, 1578L, 24 | 3272L, 3297L, 6766L, 3954L, 4096L, 2511L, 2508L, 2826L, 2800L, 25 | 196L, 196L, 4870L, 4841L, 2646L, 2623L, 2883L, 2837L, 3472L, 26 | 3432L, 2721L, 2715L, 2175L, 2167L, 405L, 202L, 410L, 1960L, 1965L, 27 | 1970L, 7040L, 7072L, 5059L, 5095L, 8078L, 8098L, 5230L, 5183L, 28 | 3979L, 4020L, 5074L, 5087L)), row.names = c(NA, -48L), class = "data.frame") 29 | -------------------------------------------------------------------------------- /gemtc/R/ll.binom.cloglog.R: -------------------------------------------------------------------------------- 1 | #' @include ll-helper.counts.R 2 | #' @include likelihoods.R 3 | 4 | # Arm-level effect estimate (given a one-row data frame) 5 | # Returns mean, standard deviation. 6 | mtc.arm.mle.binom.cloglog <- function(data, k=0.5) { 7 | s <- data['responders'] + k 8 | n <- data['sampleSize'] + 2*k 9 | mu <- unname(log(-log(1 - s/n))) 10 | sigma <- unname(sqrt(1/n^2)/exp(mu)) 11 | c('mean'=mu, 'sd'=min(1, sigma)) 12 | } 13 | 14 | # Relative effect estimate (given a two-row data frame) 15 | mtc.rel.mle.binom.cloglog <- function(data, correction.force=TRUE, correction.type="constant", correction.magnitude=1) { 16 | correction <- correction.counts(data, correction.force, correction.type, correction.magnitude) 17 | 18 | e1 <- mtc.arm.mle.binom.cloglog(data[1,], correction[1]) 19 | e2 <- mtc.arm.mle.binom.cloglog(data[2,], correction[2]) 20 | c(e2['mean'] - e1['mean'], sqrt(e1['sd']^2 + e2['sd']^2)) 21 | } 22 | 23 | mtc.code.likelihood.binom.cloglog <- function(powerAdjust) { 24 | paste("cloglog(p[i, k]) <- $armLinearModel$", likelihood.code.binom[powerAdjust + 1], sep="\n") 25 | } 26 | 27 | fitted.values.parameter.binom.cloglog <- fitted.values.parameter.binom 28 | deviance.binom.cloglog <- deviance.binom 29 | 30 | scale.log.binom.cloglog <- function() { TRUE } 31 | scale.name.binom.cloglog <- function() { "Hazard Ratio" } 32 | 33 | # Initial values outside this range result in probability 0 or 1 for the 34 | # binomial, which may lead to BUGS/JAGS rejecting the data 35 | inits.info.binom.cloglog <- function() { 36 | list( 37 | limits=c(-37.4, 3.6), 38 | param='p.base', 39 | transform=function(theta) { 1 - exp(-exp(theta)) }) 40 | } 41 | 42 | required.columns.ab.binom.cloglog <- required.columns.counts 43 | validate.data.binom.cloglog <- validate.data.counts 44 | study.baseline.priors.binom.cloglog <- function() { 45 | "for (i in studies.a) { 46 | mu[i] <- cloglog(p.base[i]) 47 | p.base[i] ~ dunif(0, 1) 48 | } 49 | " 50 | } 51 | -------------------------------------------------------------------------------- /gemtc/NAMESPACE: -------------------------------------------------------------------------------- 1 | useDynLib(gemtc, .registration = TRUE) 2 | 3 | import(graphics) 4 | import(grDevices) 5 | import(stats) 6 | import(utils) 7 | 8 | import(grid) 9 | import(coda) 10 | importFrom(igraph, E, V, "V<-", edge, edges, vertex, ends, path, set.edge.attribute, are.connected, get.shortest.paths, graph.empty, simplify, clusters, induced.subgraph, get.edges, degree, get.edge.attribute, shortest.paths, as.undirected, graph.edgelist, vertices) 11 | importFrom(plyr, aaply, laply) 12 | 13 | S3method(print, mtc.network) 14 | S3method(summary, mtc.network) 15 | S3method(plot, mtc.network) 16 | 17 | S3method(print, mtc.model) 18 | S3method(summary, mtc.model) 19 | S3method(plot, mtc.model) 20 | 21 | S3method(print, mtc.result) 22 | S3method(summary, mtc.result) 23 | S3method(plot, mtc.result) 24 | S3method(as.mcmc.list, mtc.result) 25 | S3method(forest, mtc.result) 26 | 27 | S3method(print, summary.mtc.result) 28 | 29 | S3method(print, mtc.anohe) 30 | S3method(plot, mtc.anohe) 31 | S3method(summary, mtc.anohe) 32 | 33 | S3method(print, mtc.anohe.summary) 34 | S3method(plot, mtc.anohe.summary) 35 | 36 | S3method(print, mtc.nodesplit) 37 | S3method(plot, mtc.nodesplit) 38 | S3method(summary, mtc.nodesplit) 39 | 40 | S3method(print, mtc.nodesplit.summary) 41 | S3method(plot, mtc.nodesplit.summary) 42 | 43 | S3method(print, mtc.rank.probability) 44 | S3method(plot, mtc.rank.probability) 45 | 46 | S3method(as.character, mtc.hy.prior) 47 | 48 | S3method(as.data.frame, mtc.relative.effect.table) 49 | S3method(print, mtc.relative.effect.table) 50 | S3method(forest, mtc.relative.effect.table) 51 | 52 | S3method(plot, mtc.deviance) 53 | 54 | export( 55 | mtc.network, mtc.data.studyrow, read.mtc.network, 56 | mtc.model, mtc.hy.prior, mtc.hy.empirical.lor, 57 | mtc.run, 58 | mtc.deviance, mtc.devplot, mtc.levplot, 59 | relative.effect, relative.effect.table, 60 | rank.probability, sucra, rank.quantiles, 61 | blobbogram, forest, 62 | plotCovariateEffect, 63 | mtc.anohe, 64 | mtc.nodesplit, mtc.nodesplit.comparisons, 65 | ll.call) 66 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-regression.R: -------------------------------------------------------------------------------- 1 | context("regression") 2 | 3 | test_that("regressionParams is correct", { 4 | expect_equal(regressionParams(list('coefficient'='shared', 'control'=1), 4), c('B')) 5 | expect_equal(regressionParams(list('coefficient'='shared', 'control'=3), 5), c('B')) 6 | 7 | expect_equal(regressionParams(list('coefficient'='unrelated', 'control'=1), 4), c('beta[2]', 'beta[3]', 'beta[4]')) 8 | expect_equal(regressionParams(list('coefficient'='unrelated', 'control'=3), 5), c('beta[1]', 'beta[2]', 'beta[4]', 'beta[5]')) 9 | expect_equal(regressionParams(list('coefficient'='unrelated', 'control'=4), 4), c('beta[1]', 'beta[2]', 'beta[3]')) 10 | 11 | expect_equal(regressionParams(list('coefficient'='exchangeable', 'control'=3), 4), c('beta[1]', 'beta[2]', 'beta[4]', 'B')) 12 | 13 | expect_equal(regressionParams(list('coefficient'='unrelated'), 8, nc=3), c('B[2]', 'B[3]')) 14 | }) 15 | 16 | test_that("regressionAdjustMatrix is correct", { 17 | expect_equal(regressionAdjustMatrix(c(1,1,2), c(1,2,3), list('coefficient'='shared', 'control'=1), 4), 18 | cbind(0,1,0)) 19 | expect_equal(regressionAdjustMatrix(c(1,1,2), c(1,2,3), list('coefficient'='shared', 'control'=2), 4), 20 | cbind(0,-1,1)) 21 | 22 | expect_equal(regressionAdjustMatrix(c(1,1,2), c(1,2,3), list('coefficient'='unrelated', 'control'=1), 4), 23 | cbind(c(0,0,0), c(1,0,0), c(-1,1,0))) 24 | expect_equal(regressionAdjustMatrix(c(1,1,2), c(1,2,3), list('coefficient'='unrelated', 'control'=2), 4), 25 | cbind(c(0,0,0), c(-1,0,0), c(0,1,0))) 26 | expect_equal(regressionAdjustMatrix(c(1), c(3), list('coefficient'='unrelated', 'control'=3), 4), 27 | cbind(c(-1,0,0))) 28 | 29 | expect_equal(regressionAdjustMatrix(c(1,1,2), c(1,2,3), list('coefficient'='exchangeable', 'control'=1), 4), 30 | cbind(c(0,0,0,0), c(1,0,0,0), c(-1,1,0,0))) 31 | 32 | expect_equal(regressionAdjustMatrix(c(1,1,2,2), c(1,2,3,4), list('coefficient'='shared', 'classes'=list('C'=1, 'X'=c(2,3), 'Y'=4)), 4), 33 | cbind(c(0, 0), c(1,0), c(0, 0), c(-1, 1))) 34 | }) 35 | -------------------------------------------------------------------------------- /gemtc/tests/data/luades-smoking.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(18760.1322057525, 2 | 15993.0916467965, 17028.4935445138, 11262.8528592698), .Names = c("d.A.B", 3 | "d.A.C", "d.A.D", "sd.d")), summary = structure(list(statistics = structure(c(0.491411250749662, 4 | 0.836279257213568, 1.10153637289963, 0.845257226765208, 0.402059818062437, 5 | 0.239726571519915, 0.437678108219602, 0.187590797981963, 0.00284299223794579, 6 | 0.00169512284352334, 0.0030948515829898, 0.00132646725341242, 7 | 0.0032354663225967, 0.00210232452118238, 0.00337672731298428, 8 | 0.00187207637671992), .Dim = c(4L, 4L), .Dimnames = list(c("d.A.B", 9 | "d.A.C", "d.A.D", "sd.d"), c("Mean", "SD", "Naive SE", "Time-series SE" 10 | ))), quantiles = structure(c(-0.280360888921278, 0.391780257839431, 11 | 0.261735552994774, 0.545783643803621, 0.223163460361759, 0.678327288685079, 12 | 0.813042937363757, 0.710979804248265, 0.482875065942942, 0.827870799432167, 13 | 1.09277743716581, 0.822875855629437, 0.748909361951364, 0.98839611057776, 14 | 1.38206752410806, 0.954372891765905, 1.30163014132725, 1.32740699197803, 15 | 1.99511003931358, 1.27538451517256), .Dim = 4:5, .Dimnames = list( 16 | c("d.A.B", "d.A.C", "d.A.D", "sd.d"), c("2.5%", "25%", "50%", 17 | "75%", "97.5%"))), start = 10010, end = 60000, thin = 10, 18 | nchain = 4L), .Names = c("statistics", "quantiles", "start", 19 | "end", "thin", "nchain"), class = "summary.mcmc"), cov = structure(c(0.1616520973004, 20 | 0.0237094894962299, 0.0582218375920789, 0.0237094894962299, 0.0574688290926931, 21 | 0.0375692420251048, 0.0582218375920789, 0.0375692420251048, 0.19156212641469 22 | ), .Dim = c(3L, 3L), .Dimnames = list(c("d.A.B", "d.A.C", "d.A.D" 23 | ), c("d.A.B", "d.A.C", "d.A.D"))), ranks = structure(c(0.000200036006481167, 24 | 0.0590606309135644, 0.22804104738853, 0.712878318097257, 0.00285051309235662, 25 | 0.176931847732592, 0.601458262487248, 0.218939409093637, 0.10281850733132, 26 | 0.663019343481827, 0.170430677521954, 0.0639115040707327, 0.894310975975676, 27 | 0.10116821027785, 0.000250045008101458, 0.00445080114420596), .Dim = c(4L, 28 | 4L), .Dimnames = list(c("A", "B", "C", "D"), NULL))), .Names = c("effectiveSize", 29 | "summary", "cov", "ranks")) 30 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.hy.prior.R: -------------------------------------------------------------------------------- 1 | context("mtc.hy.prior") 2 | 3 | test_that("the standard uniform prior on standard deviation is generated correctly", { 4 | expect_that(as.character(mtc.hy.prior("std.dev", "dunif", 0, "om.scale")), equals("sd.d ~ dunif(0, om.scale)\ntau.d <- pow(sd.d, -2)")) 5 | expect_that(as.character(mtc.hy.prior("std.dev", "dunif", 0, 5)), equals("sd.d ~ dunif(0, 5)\ntau.d <- pow(sd.d, -2)")) 6 | expect_that(as.character(mtc.hy.prior("std.dev", "dunif", 0.1, 2)), equals("sd.d ~ dunif(0.1, 2)\ntau.d <- pow(sd.d, -2)")) 7 | }) 8 | 9 | test_that("other priors can be specified by name", { 10 | expect_that(as.character(mtc.hy.prior("std.dev", "dgamma", 0.01, 0.01)), equals("sd.d ~ dgamma(0.01, 0.01)\ntau.d <- pow(sd.d, -2)")) 11 | expect_that(as.character(mtc.hy.prior("std.dev", "dlnorm", -1.3, 0.49)), equals("sd.d ~ dlnorm(-1.3, 0.49)\ntau.d <- pow(sd.d, -2)")) 12 | }) 13 | 14 | test_that("priors can have more or less than two parameters", { 15 | expect_that(as.character(mtc.hy.prior("std.dev", "dgamma", 0.01, 0.02, 0.03)), equals("sd.d ~ dgamma(0.01, 0.02, 0.03)\ntau.d <- pow(sd.d, -2)")) 16 | expect_that(as.character(mtc.hy.prior("std.dev", "dgamma", 0.01)), equals("sd.d ~ dgamma(0.01)\ntau.d <- pow(sd.d, -2)")) 17 | }) 18 | 19 | test_that("the prior can be specified on the variance", { 20 | expect_that(as.character(mtc.hy.prior("var", "dlnorm", -1.3, 0.49)), equals("var.d ~ dlnorm(-1.3, 0.49)\nsd.d <- sqrt(var.d)\ntau.d <- 1 / var.d")) 21 | }) 22 | 23 | test_that("the prior can be specified on the precision", { 24 | expect_that(as.character(mtc.hy.prior("prec", "dlnorm", -1.3, 0.49)), equals("tau.d ~ dlnorm(-1.3, 0.49)\nsd.d <- sqrt(1 / tau.d)")) 25 | }) 26 | 27 | test_that("LOR empirical priors have correct values", { 28 | expect_that(as.character(mtc.hy.empirical.lor("mortality", "pharma-control")), equals("var.d ~ dlnorm(-4.06, 0.476)\nsd.d <- sqrt(var.d)\ntau.d <- 1 / var.d")) 29 | expect_that(as.character(mtc.hy.empirical.lor("mortality", "pharma-pharma")), equals("var.d ~ dlnorm(-4.27, 0.457)\nsd.d <- sqrt(var.d)\ntau.d <- 1 / var.d")) 30 | expect_that(as.character(mtc.hy.empirical.lor("subjective", "pharma-pharma")), equals("var.d ~ dlnorm(-2.34, 0.381)\nsd.d <- sqrt(var.d)\ntau.d <- 1 / var.d")) 31 | }) 32 | -------------------------------------------------------------------------------- /gemtc/R/mtc.network.xml.R: -------------------------------------------------------------------------------- 1 | #' @include mtc.network.R 2 | 3 | read.mtc.network <- function(file) { 4 | # Check that the file exists and can be read. 5 | # This is not best practice, but the XML parser throws an incredibly cryptic 6 | # error if it can't read the file, so this seems better. 7 | if (file.access(file, 4) == -1) { 8 | stop(paste0("The file \"", file, "\" does not exist or can not be read.")) 9 | } 10 | 11 | doc <- XML::xmlInternalTreeParse(file) 12 | description <- unlist(XML::xpathApply(doc, "/network", XML::xmlGetAttr, "description")) 13 | type <- unlist(XML::xpathApply(doc, "/network", XML::xmlGetAttr, "type", "rate")) 14 | treatments <- XML::xpathApply(doc, "/network/treatments/treatment", 15 | function(node) { 16 | c( 17 | id = XML::xmlGetAttr(node, "id"), 18 | description = XML::xmlValue(node) 19 | ) 20 | } 21 | ) 22 | if (identical(type, "rate")) { 23 | data.ab <- XML::xpathApply(doc, "/network/studies/study/measurement", 24 | function(node) { 25 | list( 26 | study = XML::xmlGetAttr(XML::xmlParent(node), "id"), 27 | treatment = XML::xmlGetAttr(node, "treatment"), 28 | responders = as.numeric(XML::xmlGetAttr(node, "responders")), 29 | sampleSize = as.numeric(XML::xmlGetAttr(node, "sample")) 30 | ) 31 | } 32 | ) 33 | } else if (identical(type, "continuous")) { 34 | data.ab <- XML::xpathApply(doc, "/network/studies/study/measurement", 35 | function(node) { 36 | list( 37 | study = XML::xmlGetAttr(XML::xmlParent(node), "id"), 38 | treatment = XML::xmlGetAttr(node, "treatment"), 39 | mean = as.numeric(XML::xmlGetAttr(node, "mean")), 40 | std.dev = as.numeric(XML::xmlGetAttr(node, "standardDeviation")), 41 | sampleSize = as.numeric(XML::xmlGetAttr(node, "sample")) 42 | ) 43 | } 44 | ) 45 | } else if (identical(type, "none")) { 46 | data.ab <- XML::xpathApply(doc, "/network/studies/study/measurement", 47 | function(node) { 48 | list( 49 | study = XML::xmlGetAttr(XML::xmlParent(node), "id"), 50 | treatment = XML::xmlGetAttr(node, "treatment") 51 | ) 52 | } 53 | ) 54 | } 55 | mtc.network(data.ab, treatments=treatments, description=description) 56 | } 57 | -------------------------------------------------------------------------------- /gemtc/R/priors.R: -------------------------------------------------------------------------------- 1 | # Returns a matrix with one row for each of the given pairs, 2 | # and columns 'mean' and 'sd' describing their relative effect 3 | rel.mle.ab <- function(data, model, pairs) { 4 | matrix(sapply(1:nrow(pairs), function(i) { 5 | sel1 <- data[['treatment']] == pairs[['t1']][i] 6 | sel2 <- data[['treatment']] == pairs[['t2']][i] 7 | columns <- ll.call("required.columns.ab", model) 8 | ll.call("mtc.rel.mle", model, as.matrix(data[sel1 | sel2, columns, drop=FALSE])) 9 | }), ncol=2, byrow=TRUE, dimnames=list(NULL, c('mean', 'sd'))) 10 | } 11 | 12 | # Returns a matrix with one row for each of the given pairs, 13 | # and columns 'mean' and 'sd' describing their relative effect 14 | rel.mle.re <- function(data, pairs) { 15 | # the mean vector 16 | mu <- data[['diff']] 17 | mu[1] <- 0.0 # the baseline relative to itself 18 | 19 | # construct the covariance matrix 20 | se <- data[['std.err']] 21 | sigma <- matrix(se[1]^2, nrow=length(se), ncol=length(se)) 22 | diag(sigma) <- se^2 23 | sigma[1,] <- 0 24 | sigma[,1] <- 0 25 | 26 | # construct the permutation matrix 27 | b <- sapply(1:nrow(pairs), function(i) { 28 | x <- rep(0, length(se)) 29 | x[data[['treatment']] == pairs[['t1']][i]] <- -1 30 | x[data[['treatment']] == pairs[['t2']][i]] <- 1 31 | x 32 | }) 33 | b <- matrix(b, nrow=length(se)) 34 | 35 | mu <- t(b) %*% mu 36 | sigma <- t(b) %*% sigma %*% b 37 | rval <- cbind(mu, sqrt(diag(sigma))) 38 | colnames(rval) <- c('mean', 'sd') 39 | rval 40 | } 41 | 42 | # Guess the measurement scale based on differences observed in the data set 43 | guess.scale <- function(model) { 44 | data.ab <- model[['network']][['data.ab']] 45 | max.ab <- 0 46 | if (!is.null(data.ab)) { 47 | max.ab <- max(sapply(unique(data.ab[['study']]), function(study) { 48 | pairs <- mtc.treatment.pairs(mtc.study.design(model[['network']], study)) 49 | max(abs(rel.mle.ab(data.ab[data.ab[['study']] == study, , drop=TRUE], model, pairs)[,'mean'])) 50 | })) 51 | } 52 | data.re <- model[['network']][['data.re']] 53 | max.re <- 0 54 | if (!is.null(data.re)) { 55 | max.re <- max(sapply(unique(data.re[['study']]), function(study) { 56 | pairs <- mtc.treatment.pairs(mtc.study.design(model[['network']], study)) 57 | max(abs(rel.mle.re(data.re[data.re[['study']] == study, , drop=TRUE], pairs)[,'mean'])) 58 | })) 59 | } 60 | 61 | max(max.ab, max.re) 62 | } 63 | -------------------------------------------------------------------------------- /gemtc/tests/data/welton-systolic.gemtc: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /gemtc/R/regression.R: -------------------------------------------------------------------------------- 1 | regressionParams <- function(regressor, nt, nc=0) { 2 | if (!is.null(regressor[['control']])) { 3 | control <- as.numeric(regressor[['control']]) 4 | betas <- paste0('beta[', (1:nt)[-control], ']') 5 | regression.parameters <- list('shared'='B', 6 | 'unrelated'=betas, 7 | 'exchangeable'=c(betas, 'B')) #, 'reg.sd' 8 | regression.parameters[[regressor[['coefficient']]]] 9 | } else { # by class 10 | paste0('B[', 2:nc, ']') 11 | } 12 | } 13 | 14 | regressionClassMap <- function(classes) { 15 | trt.to.class <- rep(NA, sum(sapply(classes, length))) 16 | for (i in 1:length(classes)) { 17 | trt.to.class[as.numeric(classes[[i]])] <- i 18 | } 19 | trt.to.class 20 | } 21 | 22 | #' @return true if t is a control treatment for the regression model 23 | isRegressionControl <- function(model, t) { 24 | regressor <- model[['regressor']] 25 | 26 | t <- as.numeric(t) 27 | if (!is.null(regressor[['classes']])) { 28 | regressionClassMap(regressor[['classes']])[t] == 1 29 | } else { 30 | t == as.numeric(regressor[['control']]) 31 | } 32 | } 33 | 34 | regressionAdjustMatrix <- function(t1, t2, regressor, nt) { 35 | nc <- length(regressor[['classes']]) 36 | nparams <- length(regressionParams(regressor, nt, nc)) 37 | pairs <- treatment.pairs(t1, t2, 1:nt) 38 | 39 | if (nc > 0) { 40 | pairs <- matrix(regressionClassMap(regressor[['classes']])[pairs], nrow=nrow(pairs)) 41 | control <- 1 42 | } else { 43 | control <- as.numeric(regressor[['control']]) 44 | } 45 | 46 | betaIndex <- function(i) { 47 | if (i > control) i - 1 else i 48 | } 49 | transform <- apply(pairs, 1, function(pair) { 50 | v <- rep(0, nparams) 51 | t1 <- pair[1] 52 | t2 <- pair[2] 53 | if (regressor[['coefficient']] == 'shared' && nc == 0) { 54 | if (t1 == control && t2 != control) { 55 | v[1] <- 1 56 | } else if (t1 != control && t2 == control) { 57 | v[1] <- -1 58 | } 59 | } else { 60 | if (t1 == control && t2 != control) { 61 | v[betaIndex(t2)] <- 1 62 | } else if (t1 != control && t2 == control) { 63 | v[betaIndex(t1)] <- -1 64 | } else if (t1 != control && t2 != control && t1 != t2) { 65 | v[betaIndex(t1)] <- -1 66 | v[betaIndex(t2)] <- 1 67 | } 68 | } 69 | v 70 | }) 71 | matrix(transform, ncol=nrow(pairs)) 72 | } 73 | -------------------------------------------------------------------------------- /gemtc/R/ll.poisson.log.R: -------------------------------------------------------------------------------- 1 | #' @include likelihoods.R 2 | 3 | # Arm-level effect estimate (given a one-row data frame) 4 | # Returns mean, standard deviation. 5 | mtc.arm.mle.poisson.log <- function(data, k=0.5) { 6 | r <- data['responders'] + k 7 | E <- data['exposure'] 8 | mu <- as.numeric(log(r/E)) 9 | sigma <- as.numeric(sqrt(1/E)) 10 | c('mean'=mu, 'sd'=sigma) 11 | } 12 | 13 | # Relative effect estimate (given a two-row data frame) 14 | mtc.rel.mle.poisson.log <- function(data, correction.force=TRUE, correction.type="constant", correction.magnitude=1) { 15 | correction.need <- data[1,"responders"] == 0 || data[2,"responders"] == 0 16 | 17 | groupRatio <- if (correction.type == "reciprocal") { 18 | data[1,'exposure'] / data[2,'exposure'] 19 | } else { 20 | 1 21 | } 22 | 23 | correction <- if (correction.force || correction.need) { 24 | correction.magnitude * c(groupRatio/(groupRatio+1), 1/(groupRatio+1)) 25 | } else { 26 | c(0, 0) 27 | } 28 | 29 | e1 <- mtc.arm.mle.poisson.log(data[1,], correction[1]) 30 | e2 <- mtc.arm.mle.poisson.log(data[2,], correction[2]) 31 | c(e2['mean'] - e1['mean'], sqrt(e1['sd']^2 + e2['sd']^2)) 32 | } 33 | 34 | mtc.code.likelihood.poisson.log <- function(powerAdjust) { 35 | paste("log(lambda[i, k]) <- $armLinearModel$", 36 | "theta[i, k] <- E[i, k] * lambda[i, k]", 37 | likelihood.code.poisson[powerAdjust + 1], sep="\n") 38 | } 39 | 40 | fitted.values.parameter.poisson.log <- fitted.values.parameter.poisson 41 | deviance.poisson.log <- deviance.poisson 42 | 43 | scale.log.poisson.log <- function() { TRUE } 44 | scale.name.poisson.log <- function() { "Hazard Ratio" } 45 | 46 | # Initial values outside this range result in rate 0 for the 47 | # poisson, which may lead to BUGS/JAGS rejecting the data 48 | scale.limit.inits.poisson.log <- function() { c(-745, +Inf) } 49 | inits.info.poisson.log <- function() { 50 | list( 51 | limits=c(-745, +Inf), 52 | param='lambda.base', 53 | transform=exp) 54 | } 55 | 56 | required.columns.ab.poisson.log <- function() { 57 | c('r'='responders', 'E'='exposure') 58 | } 59 | 60 | validate.data.poisson.log <- function(data.ab) { 61 | stopifnot(all(data.ab[['responders']] >= 0)) 62 | stopifnot(all(data.ab[['exposure']] >= 0)) 63 | } 64 | 65 | study.baseline.priors.poisson.log <- function() { 66 | "for (i in studies.a) { 67 | mu[i] <- log(lambda.base[i]) 68 | lambda.base[i] ~ dgamma(0.001, 0.001) 69 | } 70 | " 71 | } 72 | -------------------------------------------------------------------------------- /gemtc/man/relative.effect.table.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{relative.effect.table} 3 | \alias{relative.effect.table} 4 | \alias{forest.mtc.relative.effect.table} 5 | \alias{print.mtc.relative.effect.table} 6 | \alias{as.data.frame.mtc.relative.effect.table} 7 | 8 | \title{Table of relative effects} 9 | \description{Generates a table of the relative effects of all pairs of treatments. Unlike \code{\link{relative.effect}}, this method stores summaries only, not raw samples.} 10 | \usage{ 11 | relative.effect.table(result, covariate=NA) 12 | 13 | \method{print}{mtc.relative.effect.table}(x, ...) 14 | \method{forest}{mtc.relative.effect.table}(x, t1, use.description=FALSE, ...) 15 | \method{as.data.frame}{mtc.relative.effect.table}(x, ...) 16 | } 17 | \arguments{ 18 | \item{result}{An object of S3 class \code{mtc.result} to derive the relative effects from.} 19 | \item{covariate}{(Regression analyses only) Value of the covariate at which to compute relative effects.} 20 | \item{x}{An object of S3 class \code{mtc.relative.effect.table}.} 21 | \item{t1}{Baseline treatment for the Forest plot.} 22 | \item{use.description}{Display treatment descriptions instead of treatment IDs.} 23 | \item{...}{Additional arguments.} 24 | } 25 | \value{ 26 | Returns an \code{mtc.relative.effect.table} object containing the quantiles of the calculated relative effects of all pair-wise comparisons among the treatments. 27 | 28 | The result will be pretty printed as an n-by-n table of relative treatment effects. 29 | It can also be used to produce Forest plots against any arbitrary baseline. 30 | Finally, the \code{as.data.frame} generic method makes it possible to export the table for use in Excel or other spreadsheet software, using the core R methods \code{write.csv} or \code{write.csv2}. 31 | } 32 | \author{Gert van Valkenhoef} 33 | \seealso{ 34 | \code{\link{relative.effect}} 35 | } 36 | \examples{ 37 | model <- mtc.model(smoking) 38 | # To save computation time we load the samples instead of running the model 39 | \dontrun{results <- mtc.run(model)} 40 | results <- dget(system.file("extdata/luades-smoking.samples.gz", package="gemtc")) 41 | 42 | # Creates a forest plot of the relative effects 43 | tbl <- relative.effect.table(results) 44 | 45 | # Print the n*n table 46 | print(tbl) 47 | 48 | # Plot effect relative to treatment "C" 49 | forest(tbl, "C") 50 | 51 | # Write to CSV (e.g. to import to Excel, then use in a Word table) 52 | \dontrun{write.csv(tbl, "smoking-effects.csv")} 53 | # Note: use write.csv2 for Western European locales 54 | } 55 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-mtc.model_columns.R: -------------------------------------------------------------------------------- 1 | context("mtc.model (column handling)") 2 | 3 | test_that("std.dev + sampleSize is rewritten to std.err", { 4 | data <- read.table(textConnection('study treatment mean std.dev sampleSize 5 | s01 A 0.0 1.5 12 6 | s01 B 1.0 2.0 31'), header=T) 7 | network <- mtc.network(data) 8 | model <- mtc.model(network, likelihood='normal', link='identity') 9 | expect_that(model$network[['data.ab']]$std.err, equals(c(1.5/sqrt(12), 2.0/sqrt(31)))) 10 | }) 11 | 12 | test_that("normal.identity requires the right columns", { 13 | expect_that(required.columns.ab.normal.identity(), equals(c('m'='mean', 'e'='std.err'))) 14 | }) 15 | 16 | test_that("data.ab missing sampleSize throws error", { 17 | data <- read.table(textConnection('study treatment mean std.dev 18 | s01 A 0.0 1.5 19 | s01 B 1.0 2.0'), header=T) 20 | network <- mtc.network(data) 21 | expect_error(mtc.model(network, likelihood='normal', link='identity')) 22 | }) 23 | 24 | test_that("data.ab missing std.dev throws error", { 25 | data <- read.table(textConnection('study treatment mean sampleSize 26 | s01 A 0.0 12 27 | s01 B 1.0 31'), header=T) 28 | network <- mtc.network(data) 29 | expect_error(mtc.model(network, likelihood='normal', link='identity')) 30 | }) 31 | 32 | test_that("data.ab missing mean throws error", { 33 | data <- read.table(textConnection('study treatment std.dev sampleSize 34 | s01 A 0.0 12 35 | s01 B 1.0 31'), header=T) 36 | network <- mtc.network(data) 37 | expect_error(mtc.model(network, likelihood='normal', link='identity')) 38 | }) 39 | 40 | test_that("data.ab with std.err does not throw error", { 41 | data <- read.table(textConnection('study treatment mean std.err 42 | s01 A 0.0 0.5 43 | s01 B 1.0 0.7'), header=T) 44 | network <- mtc.network(data) 45 | model <- mtc.model(network, likelihood='normal', link='identity') 46 | }) 47 | 48 | test_that("data.re missing diff throws error", { 49 | data <- read.table(textConnection('study treatment diff std.err 50 | s01 A NA 0.5 51 | s01 B 1.0 0.7'), header=T) 52 | network <- mtc.network(data.re=data) 53 | network$data.re$diff <- NULL 54 | expect_error(mtc.model(network, likelihood='normal', link='identity')) 55 | }) 56 | 57 | test_that("data.re missing std.err throws error", { 58 | data <- read.table(textConnection('study treatment diff std.err 59 | s01 A NA 0.5 60 | s01 B 1.0 0.7'), header=T) 61 | network <- mtc.network(data.re=data) 62 | network$data.re$std.err <- NULL 63 | expect_error(mtc.model(network, likelihood='normal', link='identity')) 64 | }) 65 | -------------------------------------------------------------------------------- /gemtc/tests/data/welton-diastolic.gemtc: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /gemtc/R/plotCovariateEffect.R: -------------------------------------------------------------------------------- 1 | plotCovariateEffect <- function(result, t1, t2, xlim=NULL, ylim=NULL, ask=dev.interactive(orNone=TRUE)) { 2 | regressor <- result[['model']][['regressor']] 3 | if (is.null(xlim)) { 4 | if (regressor[['type']] == 'continuous') { 5 | studies <- result[['model']][['network']][['studies']] 6 | observed <- studies[, regressor[['variable']]] 7 | ctr <- regressor[['center']] 8 | xlim <- c(min(observed, na.rm=TRUE), max(observed, na.rm=TRUE)) 9 | xvals <- seq(xlim[1], xlim[2], length.out=7) 10 | } else { 11 | xlim <- c(-0.5, 1.5) 12 | xvals <- c(0, 1) 13 | } 14 | } else { 15 | xvals <- seq(xlim[1], xlim[2], length.out=7) 16 | } 17 | 18 | pairs <- treatment.pairs(t1, t2, result[['model']][['network']][['treatments']][['id']]) 19 | res <- lapply(xvals, function(xval) { 20 | re <- relative.effect(result, t1, t2, preserve.extra=FALSE, covariate=xval) 21 | samples <- as.matrix(re[['samples']]) 22 | stats <- t(apply(samples, 2, quantile, probs=c(0.025, 0.5, 0.975))) 23 | comps <- extract.comparisons(rownames(stats)) 24 | data.frame(t1=comps[,1], t2=comps[,2], median=stats[,"50%"], lower=stats[,"2.5%"], upper=stats[,"97.5%"]) 25 | }) 26 | 27 | if (is.null(ylim)) { 28 | ylim <- c(min(sapply(res, function(stats) { min(stats[['lower']]) })), 29 | max(sapply(res, function(stats) { max(stats[['upper']]) }))) 30 | } 31 | 32 | first <- TRUE 33 | devAskNewPage(FALSE) 34 | for (pair in split(pairs, seq(nrow(pairs)))) { 35 | yvals <- sapply(res, function(stats) { stats[stats[['t1']] == pair[1] & stats[['t2']] == pair[2], c('median', 'lower', 'upper')] }) 36 | if (regressor[['type']] == 'continuous') { 37 | plot(xvals, yvals['median', ], type='l', xlim=xlim, ylim=ylim, main="Treatment effect vs. covariate", xlab=regressor[["variable"]], ylab=paste("d", pair[1], pair[2], sep=".")) 38 | lines(xvals, yvals['lower', ], lty=2) 39 | lines(xvals, yvals['upper', ], lty=2) 40 | } else { 41 | plot(xvals, yvals['median', ], type='p', xlim=xlim, ylim=ylim, main="Treatment effect vs. covariate", xlab=regressor[["variable"]], ylab=paste("d", pair[1], pair[2], sep="."), xaxp=c(0, 1, 1)) 42 | segments(xvals, unlist(yvals['lower',]), xvals, unlist(yvals['upper',])) 43 | eps <- 0.01 44 | segments(xvals-eps, unlist(yvals['lower',]), xvals+eps, unlist(yvals['lower',])) 45 | segments(xvals-eps, unlist(yvals['upper',]), xvals+eps, unlist(yvals['upper',])) 46 | } 47 | if (first) devAskNewPage(ask) 48 | first <- FALSE 49 | } 50 | } 51 | -------------------------------------------------------------------------------- /gemtc/R/relative.effect.table.R: -------------------------------------------------------------------------------- 1 | #' @include forest.R 2 | 3 | relative.effect.table <- function(result, covariate=NA) { 4 | ts <- as.character(result[['model']][['network']][['treatments']][['id']]) 5 | tbl <- array(NA, dim=c(length(ts), length(ts), 3), dimnames=list(ts, ts, c("2.5%", "50%", "97.5%"))) 6 | comps <- combn(ts, 2) 7 | 8 | for (i in 1:ncol(comps)) { 9 | comp <- comps[,i] 10 | samples <- as.matrix(relative.effect(result, comp[1], comp[2], preserve.extra=FALSE, covariate=covariate)$samples) 11 | q <- quantile(samples, prob=c(0.025, 0.5, 0.975)) 12 | tbl[comp[1], comp[2],] <- unname(q) 13 | q.inv <- c(-q[3], -q[2], -q[1]) 14 | tbl[comp[2], comp[1],] <- unname(q.inv) 15 | } 16 | 17 | attr(tbl, "model") <- result[['model']] 18 | attr(tbl, "covariate") <- covariate 19 | class(tbl) <- "mtc.relative.effect.table" 20 | 21 | tbl 22 | } 23 | 24 | relative.effect.table.to.matrix <- function(x, formatNumber=formatC) { 25 | y <- apply(x, c(1,2), function(x) { 26 | if (all(!is.na(x))) { 27 | paste0(formatNumber(x[2]), " (", formatNumber(x[1]), ", ", formatNumber(x[3]), ")") 28 | } else { 29 | NA 30 | } 31 | }) 32 | diag(y) <- rownames(x) 33 | y 34 | } 35 | 36 | as.data.frame.mtc.relative.effect.table <- function(x, ...) { 37 | as.data.frame(relative.effect.table.to.matrix(x, paste), stringsAsFactors=FALSE) 38 | } 39 | 40 | print.mtc.relative.effect.table <- function(x, ...) { 41 | scale.log <- if (ll.call('scale.log', attr(x, 'model'))) 'Log ' else '' 42 | scale.name <- ll.call('scale.name', attr(x, 'model')) 43 | y <- relative.effect.table.to.matrix(x) 44 | 45 | cat(paste0(scale.log, scale.name, " (95% CrI)\n\n")) 46 | write.table(format(y, justify="centre"), quote=FALSE, row.names=FALSE, col.names=FALSE) 47 | } 48 | 49 | forest.mtc.relative.effect.table <- function(x, t1=rownames(x)[1], use.description=FALSE, ...) { 50 | i1 <- which(rownames(x) == t1) 51 | stats <- x[i1, -i1,] 52 | 53 | model <- attr(x, 'model') 54 | network <- model[['network']] 55 | 56 | ts <- rownames(stats) 57 | if (use.description) { 58 | ts <- treatment.id.to.description(network, ts) 59 | t1 <- treatment.id.to.description(network, t1) 60 | } 61 | 62 | data <- data.frame(id=ts, 63 | pe=stats[,2], ci.l=stats[,1], ci.u=stats[,3], 64 | style="normal") 65 | 66 | blobbogram(data, 67 | columns=c(), column.labels=c(), 68 | id.label="", 69 | ci.label=paste(ll.call('scale.name', model), "(95% CrI)"), 70 | log.scale=ll.call('scale.log', model), 71 | center.label=paste("Compared with", t1), 72 | ...) 73 | } 74 | -------------------------------------------------------------------------------- /gemtc/man/relative.effect.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{relative.effect} 3 | \alias{relative.effect} 4 | 5 | \title{Calculating relative effects} 6 | \description{Calculates the relative effects of pairs of treatments.} 7 | \usage{ 8 | relative.effect(result, t1, t2 = c(), preserve.extra = TRUE, covariate = NA) 9 | } 10 | \arguments{ 11 | \item{result}{An object of S3 class \code{mtc.result} to derive the relative effects from.} 12 | \item{t1}{A list of baselines to calculate a relative effects against. Will be extended to match the length of t2.} 13 | \item{t2}{A list of treatments to calculate the relative effects for. Will be extended to match the length of t1. 14 | If left empty and t1 is a single treatment, relative effects of all treatments except t1 will be calculated.} 15 | \item{preserve.extra}{Indicates whether to preserve extra parameters such as the sd.d.} 16 | \item{covariate}{(Regression analyses only) Value of the covariate at which to compute relative effects.} 17 | } 18 | \value{ 19 | Returns an \code{mtc.results} object containing the calculated relative effects. 20 | 21 | Note that this method stores the raw samples, which may result in excessive memory usage. You may want to consider using \code{\link{relative.effect.table}} instead. 22 | } 23 | \author{Gert van Valkenhoef, Joël Kuiper} 24 | \seealso{ 25 | \code{\link{rank.probability}}, 26 | \code{\link{relative.effect.table}} 27 | } 28 | \examples{ 29 | model <- mtc.model(smoking) 30 | # To save computation time we load the samples instead of running the model 31 | \dontrun{results <- mtc.run(model)} 32 | results <- dget(system.file("extdata/luades-smoking.samples.gz", package="gemtc")) 33 | 34 | # Creates a forest plot of the relative effects 35 | forest(relative.effect(results, "A")) 36 | 37 | summary(relative.effect(results, "B", c("A", "C", "D"))) 38 | ## Iterations = 5010:25000 39 | ## Thinning interval = 10 40 | ## Number of chains = 4 41 | ## Sample size per chain = 2000 42 | ## 43 | ## 1. Empirical mean and standard deviation for each variable, 44 | ## plus standard error of the mean: 45 | ## 46 | ## Mean SD Naive SE Time-series SE 47 | ## d.B.A -0.4965 0.4081 0.004563 0.004989 48 | ## d.B.C 0.3394 0.4144 0.004634 0.004859 49 | ## d.B.D 0.6123 0.4789 0.005354 0.005297 50 | ## sd.d 0.8465 0.1913 0.002139 0.002965 51 | ## 52 | ## 2. Quantiles for each variable: 53 | ## 54 | ## 2.5% 25% 50% 75% 97.5% 55 | ## d.B.A -1.3407 -0.7530 -0.4910 -0.2312 0.2985 56 | ## d.B.C -0.4809 0.0744 0.3411 0.5977 1.1702 57 | ## d.B.D -0.3083 0.3005 0.6044 0.9152 1.5790 58 | ## sd.d 0.5509 0.7119 0.8180 0.9542 1.2827 59 | } 60 | -------------------------------------------------------------------------------- /gemtc/tests/data/smoking-ume.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(40678.3887325717, 2 | 15833.0792839309, 33311.7697175392, 19299.7145068589, 28158.6103226059, 3 | 6471.61933667915), .Names = c("d.A.B", "d.A.C", "d.B.C", "d.B.D", 4 | "d.C.D", "sd.d")), summary = structure(list(statistics = structure(c(0.336365312238535, 5 | 0.833765623573284, -0.0803913786818312, 1.08031153644781, 0.216526085807077, 6 | 0.83948242948833, 0.533058750194505, 0.252207326725614, 0.687693671974806, 7 | 0.973577269993074, 0.725982947709848, 0.202248694059633, 0.0018846472851668, 8 | 0.000891687554963064, 0.00243136429416231, 0.00344211544810595, 9 | 0.00256673732675716, 0.00071505711527845, 0.00264753310869987, 10 | 0.00202264420687058, 0.00376855039624721, 0.00702156102374052, 11 | 0.00433630997972007, 0.00252233974560594), .Dim = c(6L, 4L), .Dimnames = list( 12 | c("d.A.B", "d.A.C", "d.B.C", "d.B.D", "d.C.D", "sd.d"), c("Mean", 13 | "SD", "Naive SE", "Time-series SE"))), quantiles = structure(c(-0.710591577355186, 14 | 0.35349363615015, -1.4459301944132, -0.840135245107086, -1.23083872322239, 15 | 0.529196289733208, -0.00564462769044614, 0.665742932183605, -0.524830998669572, 16 | 0.448883887948418, -0.24975027088693, 0.69620008035736, 0.333399430714947, 17 | 0.825334998369572, -0.0794605286828713, 1.07393725396434, 0.221202078759538, 18 | 0.811589590921506, 0.675290040130688, 0.992219887984337, 0.364678787229087, 19 | 1.71037756088689, 0.69011663279255, 0.949292829033654, 1.40102217589302, 20 | 1.3568061649767, 1.27806414220814, 3.01354151874289, 1.6409550652184, 21 | 1.31598470784675), .Dim = c(6L, 5L), .Dimnames = list(c("d.A.B", 22 | "d.A.C", "d.B.C", "d.B.D", "d.C.D", "sd.d"), c("2.5%", "25%", 23 | "50%", "75%", "97.5%"))), start = 5001, end = 25000, thin = 1, 24 | nchain = 4L), .Names = c("statistics", "quantiles", "start", 25 | "end", "thin", "nchain"), class = "summary.mcmc"), cov = structure(c(0.284151631158927, 26 | -0.00100924064376064, 0.00108834969612548, 0.000295100487924394, 27 | 0.00236931588045582, -0.00100924064376064, 0.0636085356540805, 28 | -0.000129240655780235, -0.000142862694673348, -0.00135195013663183, 29 | 0.00108834969612548, -0.000129240655780235, 0.472922586474192, 30 | 0.0058821312155195, -0.000261236470192804, 0.000295100487924394, 31 | -0.000142862694673348, 0.0058821312155195, 0.947852700647167, 32 | -0.00169917905663473, 0.00236931588045582, -0.00135195013663183, 33 | -0.000261236470192804, -0.00169917905663473, 0.52705124036548 34 | ), .Dim = c(5L, 5L), .Dimnames = list(c("d.A.B", "d.A.C", "d.B.C", 35 | "d.B.D", "d.C.D"), c("d.A.B", "d.A.C", "d.B.C", "d.B.D", "d.C.D" 36 | )))), .Names = c("effectiveSize", "summary", "cov")) 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | GeMTC R package 2 | =============== 3 | 4 | [![Build Status](https://travis-ci.com/gertvv/gemtc.svg?branch=master)](https://travis-ci.com/gertvv/gemtc) 5 | [![Build Status (develop)](https://travis-ci.com/gertvv/gemtc.svg?branch=develop)](https://travis-ci.com/gertvv/gemtc) 6 | 7 | [GeMTC](http://drugis.org/gemtc) is an R package for Network 8 | Meta-Analysis (also know as Mixed Treatment Comparison, MTC) model 9 | generation. 10 | 11 | Building 12 | -------- 13 | 14 | Use `R CMD build gemtc` to build the R package. The `Makefile` offers a 15 | number of targets for convenience, but is entirely optional. Use `make 16 | install` to both build and install the package. 17 | 18 | You will need a working installation of rjags, which in turn requires a 19 | working installation of JAGS. 20 | 21 | Testing 22 | ------- 23 | 24 | The `testthat` package is used for testing. Tests reside in the 25 | `tests/testthat` directory. There are three levels of tests: 26 | 27 | - `unit`: unit tests - these test relatively isolated pieces of 28 | functionality and should be fast to run. They will be run by `make 29 | test` or `R CMD check`. 30 | 31 | - `regress`: regression tests exercise full code paths, and typically 32 | run all code that an analyst would run on a given dataset. They aim 33 | to catch bugs in existing functionality due to the introduction of 34 | new code. They should not take very long to run, and do not aim to 35 | produce reasonable posterior estimates. These can be run using `make 36 | regress`. 37 | 38 | - `validate`: valition tests verify the posterior summaries obtained by 39 | the R package against results that were previously (manually) checked 40 | against results published in the literature. They typically take very 41 | long to run, and are probabilistic in nature. Many individual 42 | comparisons are made, so a couple of failures over the entire test 43 | suite are to be expected. However, these should not be systematic. 44 | These tests can be run using `make validate`. 45 | 46 | License 47 | ------- 48 | 49 | GeMTC is free software: you can redistribute it and/or modify 50 | it under the terms of the GNU General Public License as published by 51 | the Free Software Foundation, either version 3 of the License, or 52 | (at your option) any later version. 53 | 54 | GeMTC is distributed in the hope that it will be useful, 55 | but WITHOUT ANY WARRANTY; without even the implied warranty of 56 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 57 | GNU General Public License for more details. 58 | 59 | You should have received a copy of the GNU General Public License 60 | along with GeMTC. If not, see . 61 | 62 | See LICENSE.txt for details. 63 | -------------------------------------------------------------------------------- /gemtc/tests/data/ns-complex.csv: -------------------------------------------------------------------------------- 1 | study,Study,treatment,diff,std.err 2 | s01,Li et al (1999),A,NA,NA 3 | s01,Li et al (1999),H,-0.72,0.71 4 | s02,Wein et al (1999),A,NA,NA 5 | s02,Wein et al (1999),B,-0.46,0.3 6 | s03,Heymsfield et al (2000),A,NA,NA 7 | s03,Heymsfield et al (2000),I,-0.95,0.35 8 | s04,Liao et al (2002),A,NA,NA 9 | s04,Liao et al (2002),D,-0.66,1.22 10 | s05,STOP-NIDDM (2002),A,NA,NA 11 | s05,STOP-NIDDM (2002),F,-0.29,0.09 12 | s06,Pan et al (2003),A,NA,NA 13 | s06,Pan et al (2003),F,-0.51,0.48 14 | s07,Xendos (2004),D,NA,NA 15 | s07,Xendos (2004),P,-0.73,0.31 16 | s08,Kosaka et al (2005),A,NA,NA 17 | s08,Kosaka et al (2005),D,-1.24,0.6 18 | s09,DREAM Trial Investigators (2006a),A,NA,NA 19 | s09,DREAM Trial Investigators (2006a),J,-0.09431,0.064464886 20 | s10,DREAM Trial Investigators (2006b),A,NA,NA 21 | s10,DREAM Trial Investigators (2006b),K,-0.967584026,0.073388284 22 | s11,Eriksson et al (2006),A,NA,NA 23 | s11,Eriksson et al (2006),G,-1.74,1.1 24 | s12,Roumen et al (2008),A,NA,NA 25 | s12,Roumen et al (2008),D,-0.8675,0.427 26 | s13,Kawamori et al (2009),D,NA,NA 27 | s13,Kawamori et al (2009),S,-0.5192,0.1623 28 | s14,Lindahl et al (2009),A,NA,NA 29 | s14,Lindahl et al (2009),D,-1.204,0.4758 30 | s15,Penn et al (2009),A,NA,NA 31 | s15,Penn et al (2009),D,-0.7985,0.4571 32 | s16,Ramachandran et al (2009),D,NA,NA 33 | s16,Ramachandran et al (2009),Q,-0.0161,0.1949 34 | s17,DeFronzo et al (2011),B,NA,NA 35 | s17,DeFronzo et al (2011),L,-1.2729,0.2856 36 | s18,NAVIGATOR (2010b),D,NA,NA 37 | s18,NAVIGATOR (2010b),O,0.0676,0.0367 38 | s19,NAVIGATOR (2010a),D,NA,NA 39 | s19,NAVIGATOR (2010a),R,-0.1508,0.0344 40 | s20,Lindblad (2010),D,NA,NA 41 | s20,Lindblad (2010),M,-0.352398387,0.204124145 42 | s21,Lindstrom (2013),A,NA,NA 43 | s21,Lindstrom (2013),D,-0.487760351,0.126568343 44 | s22,Saito (2011),A,NA,NA 45 | s22,Saito (2011),D,-0.579818495,0.222845032 46 | s23,Sakane (2011),A,NA,NA 47 | s23,Sakane (2011),D,-0.62735944,0.384900179 48 | s24,Xu (2013),A,NA,NA 49 | s24,Xu (2013),D,-0.198450939,0.554700196 50 | s25,Zinman (2010),D,NA,NA 51 | s25,Zinman (2010),T,-1.171182982,0.31000362 52 | s26,Jarrett et al (1979),A,NA,NA 53 | s26,Jarrett et al (1979),B,-0.3687,0.54 54 | s27,DPPRG (2009),A,NA,0.0453 55 | s27,DPPRG (2009),D,-0.3864,0.0662 56 | s27,DPPRG (2009),H,-0.1978,0.0655 57 | s28,Yates (2011),A,NA,0.466981803 58 | s28,Yates (2011),D,-0.338273859,0.632455532 59 | s28,Yates (2011),E,-1.123930097,0.707106781 60 | s29,Ramachandran et al (2006),A,NA,0.1724 61 | s29,Ramachandran et al (2006),D,-0.473,0.2514 62 | s29,Ramachandran et al (2006),H,-0.429,0.2388 63 | s29,Ramachandran et al (2006),N,-0.463,0.2513 64 | s30,Li et al (2008),A,NA,0.1666 65 | s30,Li et al (2008),B,-0.545,0.217 66 | s30,Li et al (2008),C,-0.673,0.251 67 | s30,Li et al (2008),D,-0.416,0.25 68 | -------------------------------------------------------------------------------- /gemtc/R/mtc.run.R: -------------------------------------------------------------------------------- 1 | #' @include deviance.R 2 | 3 | mtc.model.run <- function(network, type, ...) { 4 | runNames <- names(formals(mtc.run)) 5 | runNames <- runNames[runNames != 'model'] 6 | args <- list(...) 7 | 8 | # Call mtc.model with any arguments not intended for mtc.run 9 | modelArgs <- args[!(names(args) %in% runNames)] 10 | modelArgs$network <- network 11 | modelArgs$type <- type 12 | model <- do.call(mtc.model, modelArgs) 13 | 14 | # Call mtc.run with all arguments intended for mtc.run 15 | runArgs <- args[names(args) %in% runNames] 16 | runArgs$model <- model 17 | do.call(mtc.run, runArgs) 18 | } 19 | 20 | # If is.na(sampler), a sampler will be chosen based on availability, in this order: 21 | # JAGS, BUGS. When the sampler is BUGS, BRugs or R2WinBUGS will be used. 22 | mtc.run <- function(model, sampler=NA, n.adapt=5000, n.iter=20000, thin=1) { 23 | if (!is.na(sampler)) { 24 | if (sampler %in% c("JAGS", "rjags")) { 25 | warning("Setting the sampler is deprecated.") 26 | } else { 27 | stop("Setting the sampler is deprecated, only JAGS is supported.") 28 | } 29 | } 30 | 31 | result <- mtc.sample(model, n.adapt=n.adapt, n.iter=n.iter, thin=thin) 32 | 33 | result <- c(result, list(model = model)) 34 | class(result) <- "mtc.result" 35 | result 36 | } 37 | 38 | mtc.build.syntaxModel <- function(model) { 39 | list( 40 | model = model[['code']], 41 | data = model[['data']], 42 | inits = model[['inits']], 43 | vars = if (!is.null(model[['monitors']][['enabled']])) model[['monitors']][['enabled']] else c(mtc.basic.parameters(model), "sd.d") 44 | ) 45 | } 46 | 47 | mtc.sample <- function(model, n.adapt=n.adapt, n.iter=n.iter, thin=thin) { 48 | # generate JAGS model 49 | syntax <- mtc.build.syntaxModel(model) 50 | 51 | # compile & run JAGS model 52 | file.model <- tempfile() 53 | cat(paste(syntax[['model']], "\n", collapse=""), file=file.model) 54 | 55 | vars <- syntax[['vars']] 56 | if (model$dic) { 57 | dic.vars <- deviance.monitors(model) 58 | dic.vars <- dic.vars[!(dic.vars %in% vars)] # jags complains about redundant variables 59 | vars <- c(vars, dic.vars) 60 | } 61 | 62 | # Note: n.iter must be specified *excluding* the n.adapt 63 | jags <- rjags::jags.model(file.model, data=syntax[['data']], 64 | inits=syntax[['inits']], 65 | n.chains=model[['n.chain']], 66 | n.adapt=n.adapt) 67 | samples <- rjags::coda.samples(jags, variable.names=vars, 68 | n.iter=n.iter, thin=thin) 69 | unlink(file.model) 70 | 71 | deviance.stats <- if (model[['dic']]) { 72 | apply(as.matrix(samples[, deviance.monitors(model), drop=FALSE]), 2, mean) 73 | } 74 | samples <- samples[, syntax[['vars']], drop=FALSE] 75 | 76 | # return 77 | list(samples=samples, deviance=computeDeviance(model, deviance.stats)) 78 | } 79 | -------------------------------------------------------------------------------- /gemtc/man/ll.call.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{ll.call} 3 | \alias{ll.call} 4 | \title{Call a likelihood/link-specific function} 5 | \description{ 6 | GeMTC implements various likelihood/link combinations. 7 | Functionality specific to the likelihood/link is handled by methods with names ending in 8 | \code{..}. 9 | This convenience function calls such methods. 10 | } 11 | \usage{ 12 | ll.call(fnName, model, ...) 13 | } 14 | \arguments{ 15 | \item{fnName}{The name of the function to call. See details for available functions.} 16 | \item{model}{An object of S3 class \code{mtc.model} describing a network meta-analysis model, or a 17 | list containing elements named 'likelihood' and 'link'.} 18 | \item{...}{Additional arguments to be passed to the function.} 19 | } 20 | \value{ 21 | The return value of the called function. 22 | } 23 | \details{ 24 | The following methods currently need to be implemented to implement a likelihood/link: 25 | \itemize{ 26 | \item{\code{mtc.arm.mle}: calculates a (corrected) maximum likelihood estimate for an arm-level 27 | effect. Used to generate starting values.} 28 | \item{\code{mtc.rel.mle}: calculates a (corrected) maximum likelihood estimate for a relative 29 | effect. Used to generate starting values.} 30 | \item{\code{mtc.code.likelihood}: generates JAGS code implementing the likelihood.} 31 | \item{\code{scale.log}: returns TRUE if plots should use the log scale.} 32 | \item{\code{scale.name}: returns the user-facing name of the outcome metric.} 33 | \item{\code{scale.limit.inits}: returns an upper and lower bound for the initial values, because 34 | some initial values might trigger boundary conditions such as probability 0 or 1 for the binomial.} 35 | \item{\code{required.columns.ab}: returns the required columns for arm-based data.} 36 | } 37 | The first two methods can now also be used to selectively apply continuity corrections in case the maximum likelihood estimates are used for other purposes. \code{mtc.arm.mle} has an additional \code{k=0.5} argument to specify the correction factor. \code{mtc.rel.mle} has arguments \code{correction.force=TRUE} to force application of the continuity correction even if unnecessary, \code{correction.type="constant"} to specify the type of correction (specify \code{"reciprocal"}) for a correction proportional to the reciprocal of the size of the other arm, and \code{correction.magnitude=1} to specify the (total) magnitude of the correction. These corrections apply only for count data, and will be ignored for continuous likelihood/links. 38 | } 39 | \author{Gert van Valkenhoef} 40 | \seealso{ 41 | \code{\link{mtc.model}} 42 | } 43 | \examples{ 44 | # The "model" may be a stub. 45 | model <- list(likelihood="poisson", link="log") 46 | 47 | ll.call("scale.name", model) 48 | # "Hazard Ratio" 49 | 50 | ll.call("mtc.arm.mle", model, c('responders'=12, 'exposure'=80)) 51 | # mean sd 52 | #-1.8562980 0.1118034 53 | } 54 | -------------------------------------------------------------------------------- /gemtc/man/mtc.anohe.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{mtc.anohe} 3 | \alias{mtc.anohe} 4 | \alias{plot.mtc.anohe} 5 | \alias{print.mtc.anohe} 6 | \alias{summary.mtc.anohe} 7 | \alias{plot.mtc.anohe.summary} 8 | \alias{print.mtc.anohe.summary} 9 | 10 | \title{Analysis of heterogeneity (ANOHE)} 11 | \description{ 12 | (EXPERIMENTAL) 13 | Generate an analysis of heterogeneity for the given network. Three types of model are estimated: unrelated study effects, unrelated mean effects, and consistency. Output of the \code{summary} function can passed to \code{plot} for a visual representation. 14 | } 15 | \usage{ 16 | mtc.anohe(network, ...) 17 | } 18 | \arguments{ 19 | \item{network}{An object of S3 class \code{\link{mtc.network}}.} 20 | \item{...}{Arguments to be passed to \code{\link{mtc.run}} or \code{\link{mtc.model}}. This can be used to set the likelihood/link or the number of iterations, for example.} 21 | } 22 | \details{ 23 | Analysis of heterogeneity is intended to be a unified set of statistics and a visual display that allows the simultaneous assessment of both heterogeneity and inconsistency in network meta-analysis \link[=gemtc-package]{[van Valkenhoef et al. 2014b (draft)]}. 24 | 25 | \code{mtc.anohe} returns the MCMC results for all three types of model. To get appropriate summary statistics, call \code{summary()} on the results object. The summary can be plotted. 26 | 27 | To control parameters of the MCMC estimation, see \code{\link{mtc.run}}. 28 | To specify the likelihood/link or to control other model parameters, see \code{\link{mtc.model}}. 29 | The \code{...} arguments are first matched against \code{\link{mtc.run}}, and those that do not match are passed to \code{\link{mtc.model}}. 30 | } 31 | \note{This method should not be considered stable. It is an experimental feature and heavily work in progress. The interface may change at any time. 32 | } 33 | \value{ 34 | For \code{mtc.anohe}: 35 | an object of class \code{mtc.anohe}. This is a list with the following elements: 36 | \item{result.use}{The result for the USE model (see \code{\link{mtc.run}}).} 37 | \item{result.ume}{The result for the UME model (see \code{\link{mtc.run}}).} 38 | \item{result.cons}{The result for the consistency model (see \code{\link{mtc.run}}).} 39 | 40 | For \code{summary}: 41 | an object of class \code{mtc.anohe.summary}. This is a list with the following elements: 42 | \item{cons.model}{Generated consistency model.} 43 | \item{studyEffects}{Study-level effect summaries (multi-arm trials downweighted).} 44 | \item{pairEffects}{Pair-wise pooled effect summaries (from the UME model).} 45 | \item{consEffects}{Consistency effect summaries.} 46 | \item{indEffects}{Indirect effect summaries (back-calculated).} 47 | \item{isquared.comp}{Per-comparison I-squared statistics.} 48 | \item{isquared.glob}{Global I-squared statistics.} 49 | } 50 | \author{Gert van Valkenhoef, Joël Kuiper} 51 | \seealso{ 52 | \code{\link{mtc.model}} 53 | \code{\link{mtc.run}} 54 | } 55 | -------------------------------------------------------------------------------- /gemtc/man/mtc.hy.prior.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{mtc.hy.prior} 3 | \alias{mtc.hy.prior} 4 | \alias{mtc.hy.empirical.lor} 5 | 6 | \title{Set priors for the heterogeneity parameter} 7 | \description{ 8 | These functions generate priors for the heterogeneity parameter in \code{\link{mtc.model}}. 9 | Priors can be set explicitly or, for outcomes on the log odds-ratio scale, based on empirical research. 10 | } 11 | \usage{ 12 | mtc.hy.prior(type, distr, ...) 13 | 14 | mtc.hy.empirical.lor(outcome.type, comparison.type) 15 | } 16 | %- maybe also 'usage' for other objects documented here. 17 | \arguments{ 18 | \item{type}{Type of heterogeneity prior: 'std.dev', 'var', or 'prec' for standard deviation, variance, or precision respectively.} 19 | \item{distr}{Prior distribution name (JAGS syntax). Typical ones would be 'dunif' (uniform), 'dgamma' (Gamma), or 'dlnorm' (log-normal). Use 'dhnorm' for the half-normal. Note that, as in JAGS, the precision (and not the variance or standard deviation) is used for the normal distribution and its derivatives.} 20 | \item{...}{Arguments to the \code{distr}. Can be numerical values or "om.scale" for the estimated outcome measure scale (see \code{\link{mtc.model}})} 21 | \item{outcome.type}{The type of outcome to get an empirical prior for. Can be one of 'mortality' (all-cause mortality), 'semi-objective' (e.g. cause-specific mortality, major morbidity event, drop-outs), or 'subjective' (e.g. pain, mental health, dichotomous biomarkers).} 22 | \item{comparison.type}{The type of comparison to get an empirical prior for. Can be one of 'pharma-control' (pharmacological interventions versus control), 'pharma-pharma' (pharmacological versus pharmacological interventions) and 'non-pharma' (any other comparisons).} 23 | } 24 | \value{ 25 | A value to be passed to \code{\link{mtc.model}}. 26 | } 27 | \details{ 28 | The generated prior is a list, the structure of which may change without notice. It can be converted to JAGS compatible code using \code{as.character}. 29 | 30 | Empirical priors for the log odds-ratio (LOR) are taken from \link[=gemtc-package]{[Turner et al. 2012]}. 31 | } 32 | \author{Gert van Valkenhoef} 33 | \seealso{ 34 | \code{\link{mtc.model}} 35 | } 36 | \examples{ 37 | # NOTE: the mtc.run commands below are for illustrative purposes, such a small 38 | # number of iterations should obviously not be used in practice. 39 | 40 | # set a uniform prior standard deviation 41 | model1 <- mtc.model(smoking, hy.prior=mtc.hy.prior("std.dev", "dunif", 0, 2)) 42 | result <- mtc.run(model1, n.adapt=10, n.iter=10) 43 | 44 | # set an empirical (log-normal) prior on the variance 45 | model2 <- mtc.model(smoking, hy.prior=mtc.hy.empirical.lor("subjective", "non-pharma")) 46 | result <- mtc.run(model2, n.adapt=10, n.iter=10) 47 | 48 | # set a gamma prior on the precision 49 | model3 <- mtc.model(smoking, hy.prior=mtc.hy.prior("prec", "dgamma", 0.01, 0.01)) 50 | result <- mtc.run(model3, n.adapt=10, n.iter=10) 51 | } 52 | -------------------------------------------------------------------------------- /gemtc/tests/data/parkinson.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(3934.30621977895, 2 | 4345.15300412452, 5495.48247327213, 18720.5195523817, 1927.06410762688 3 | ), .Names = c("d.D.A", "d.D.B", "d.D.C", "d.D.E", "sd.d")), summary = structure(list( 4 | statistics = structure(c(0.527257567168366, -1.31969346646673, 5 | 0.0250168760985751, -0.296222276328364, 0.371187206431259, 6 | 0.606113295290406, 0.676380439487972, 0.467119006296636, 7 | 0.416906806331891, 0.354600142722087, 0.00214293410633585, 8 | 0.00239136597711941, 0.00165151508486736, 0.00147398814940053, 9 | 0.00125370082764253, 0.00982572232119561, 0.0103768968571905, 10 | 0.00638042588878175, 0.00305655351132901, 0.00813750244212774 11 | ), .Dim = c(5L, 4L), .Dimnames = list(c("d.D.A", "d.D.B", 12 | "d.D.C", "d.D.E", "sd.d"), c("Mean", "SD", "Naive SE", "Time-series SE" 13 | ))), quantiles = structure(c(-0.685556621192158, -2.6792936418435, 14 | -0.903817026029012, -1.12244734090854, 0.0126018827083878, 15 | 0.164611176640526, -1.72963549695134, -0.246721968223545, 16 | -0.505495920386082, 0.117974276816246, 0.534710824264388, 17 | -1.31685239475968, 0.0299957213125759, -0.299146800940355, 18 | 0.268558648659097, 0.900805485564012, -0.899283214403698, 19 | 0.299718384848243, -0.0913124984378242, 0.508462643662048, 20 | 1.69632655137478, -0.0180394000516347, 0.917365586015456, 21 | 0.548021059605455, 1.3522944682501), .Dim = c(5L, 5L), .Dimnames = list( 22 | c("d.D.A", "d.D.B", "d.D.C", "d.D.E", "sd.d"), c("2.5%", 23 | "25%", "50%", "75%", "97.5%"))), start = 5001, end = 25000, 24 | thin = 1, nchain = 4L), .Names = c("statistics", "quantiles", 25 | "start", "end", "thin", "nchain"), class = "summary.mcmc"), cov = structure(c(0.367373326727795, 26 | 0.28843620708944, 0.100687618518661, -0.000209413138930767, 0.28843620708944, 27 | 0.457490498921942, 0.0801742194282771, -0.000907053291308965, 28 | 0.100687618518661, 0.0801742194282771, 0.218200166043556, 0.000499422289314709, 29 | -0.000209413138930767, -0.000907053291308965, 0.000499422289314709, 30 | 0.173811285165857), .Dim = c(4L, 4L), .Dimnames = list(c("d.D.A", 31 | "d.D.B", "d.D.C", "d.D.E"), c("d.D.A", "d.D.B", "d.D.C", "d.D.E" 32 | ))), ranks = structure(c(0.7291, 0.000825, 0.1306625, 0.0932, 33 | 0.0462125, 0.13365, 0.010075, 0.401175, 0.3522625, 0.1028375, 34 | 0.078175, 0.0173125, 0.2473, 0.4614, 0.1958125, 0.05845, 0.06275, 35 | 0.2066375, 0.0883, 0.5838625, 0.000625, 0.9090375, 0.014225, 36 | 0.0048375, 0.071275), .Dim = c(5L, 5L), .Dimnames = list(c("A", 37 | "B", "C", "D", "E"), NULL), class = "mtc.rank.probability", direction = 1), 38 | dic = structure(list(Dbar = 13.5910323741519, pD = 12.3959335603808, 39 | DIC = 25.9869659345327, `data points` = 15L), .Names = c("Dbar", 40 | "pD", "DIC", "data points"))), .Names = c("effectiveSize", 41 | "summary", "cov", "ranks", "dic")) 42 | -------------------------------------------------------------------------------- /gemtc/man/mtc.data.studyrow.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{mtc.data.studyrow} 3 | \alias{mtc.data.studyrow} 4 | 5 | \title{Convert one-study-per-row datasets} 6 | \description{Converts datasets in the one-study-per-row format to one-arm-per-row format used by GeMTC} 7 | \usage{ 8 | mtc.data.studyrow(data, 9 | armVars=c('treatment'='t', 'responders'='r', 'sampleSize'='n'), 10 | nArmsVar='na', 11 | studyVars=c(), 12 | studyNames=1:nrow(data), 13 | treatmentNames=NA, 14 | patterns=c('\%s..', '\%s..\%d.')) 15 | } 16 | \arguments{ 17 | \item{data}{Data in one-study-per-row format.} 18 | \item{armVars}{Vector of per-arm variables. The name of each component will be the column name in the resulting dataset. The column name in the source dataset is derived from the value of each component.} 19 | \item{nArmsVar}{Variable holding the number of arms for each study.} 20 | \item{studyVars}{Vector of per-study variables. The name of each component will be the column name in the resulting dataset. The column name in the source dataset is derived from the value of each component.} 21 | \item{studyNames}{Vector of study names.} 22 | \item{treatmentNames}{Vector of treatment names.} 23 | \item{patterns}{Patterns to generate column names in the source dataset. The first is for per-study variables, the second for per-arm variables.} 24 | } 25 | \value{A data table with the requested columns.} 26 | \details{ 27 | Maps the one-study-per-row format that is widely used and convenient for BUGS models to the one-arm-per-row format used by GeMTC. 28 | As the primary purpose is to input datasets from BUGS models, the defaults work for the standard BUGS data table format. 29 | In most cases, it should be possible to just copy/paste the BUGS data table (without the final 'END') and \code{read.table} it into R, then apply \code{mtc.data.studyrow}. 30 | In many cases, the resulting table can be processed directly by \code{\link{mtc.network}}. 31 | } 32 | \author{Gert van Valkenhoef} 33 | \seealso{\code{\link{mtc.network}}} 34 | \examples{ 35 | ## Example taken from the NICE DSU TSD series in Evidence Synthesis, #2 36 | ## Dopamine agonists for the treatment of Parkinson's 37 | 38 | # Read the bugs-formatted data 39 | data.src <- read.table(textConnection(' 40 | t[,1] t[,2] t[,3] y[,1] y[,2] y[,3] se[,1] se[,2] se[,3] na[] 41 | 1 3 NA -1.22 -1.53 NA 0.504 0.439 NA 2 42 | 1 2 NA -0.7 -2.4 NA 0.282 0.258 NA 2 43 | 1 2 4 -0.3 -2.6 -1.2 0.505 0.510 0.478 3 44 | 3 4 NA -0.24 -0.59 NA 0.265 0.354 NA 2 45 | 3 4 NA -0.73 -0.18 NA 0.335 0.442 NA 2 46 | 4 5 NA -2.2 -2.5 NA 0.197 0.190 NA 2 47 | 4 5 NA -1.8 -2.1 NA 0.200 0.250 NA 2'), header=TRUE) 48 | 49 | # Convert the data, setting treatment names 50 | data <- mtc.data.studyrow(data.src, 51 | armVars=c('treatment'='t', 'mean'='y', 'std.err'='se'), 52 | treatmentNames=c('Placebo', 'DA1', 'DA2', 'DA3', 'DA4')) 53 | 54 | # Check that the data are correct 55 | print(data) 56 | 57 | # Create a network 58 | network <- mtc.network(data) 59 | } 60 | -------------------------------------------------------------------------------- /gemtc/R/code.R: -------------------------------------------------------------------------------- 1 | #' @include template.R 2 | 3 | mtc.model.code <- function(model, params, relEffectMatrix, template='gemtc.model.template.txt', 4 | linearModel='delta[i, k]', regressionPriors='') { 5 | powerAdjust <- !is.null(model[['powerAdjust']]) && !is.na(model[['powerAdjust']]) 6 | 7 | template <- read.template(template) 8 | 9 | if (length(model[['data']][['studies.a']]) > 0) { 10 | arm.code <- read.template('gemtc.armeffect.likelihood.txt') 11 | template <- template.block.sub(template, 'armeffect', arm.code) 12 | lik.code <- do.call(paste("mtc.code.likelihood", model[['likelihood']], model[['link']], sep="."), list(powerAdjust=powerAdjust)) 13 | template <- template.block.sub(template, 'likelihood', lik.code) 14 | } else { 15 | template <- template.block.sub(template, 'armeffect', '## OMITTED') 16 | } 17 | 18 | if (length(model[['data']][['studies.r2']]) > 0) { 19 | rel.code <- 20 | if (powerAdjust) read.template('gemtc.releffect.likelihood.power.r2.txt') 21 | else read.template('gemtc.releffect.likelihood.r2.txt') 22 | template <- template.block.sub(template, 'releffect.r2', rel.code) 23 | } else { 24 | template <- template.block.sub(template, 'releffect.r2', '## OMITTED') 25 | } 26 | 27 | if (length(model[['data']][['studies.rm']]) > 0) { 28 | rel.code <- 29 | if (powerAdjust) read.template('gemtc.releffect.likelihood.power.rm.txt') 30 | else read.template('gemtc.releffect.likelihood.rm.txt') 31 | template <- template.block.sub(template, 'releffect.rm', rel.code) 32 | } else { 33 | template <- template.block.sub(template, 'releffect.rm', '## OMITTED') 34 | } 35 | 36 | template <- template.block.sub(template, 'armLinearModel', paste0('mu[i] + ', linearModel)) 37 | template <- template.block.sub(template, 'relLinearModel', linearModel) 38 | 39 | hyModel <- if (model[['linearModel']] == "fixed") { 40 | read.template('gemtc.fixedeffect.txt') 41 | } else { 42 | read.template('gemtc.randomeffects.txt') 43 | } 44 | template <- template.block.sub(template, 'heterogeneityModel', hyModel) 45 | 46 | # substitute in heterogeneity prior 47 | template <- template.block.sub(template, 'hy.prior', as.character(model[['hy.prior']])) 48 | 49 | template <- template.block.sub(template, 'relativeEffectMatrix', relEffectMatrix) 50 | 51 | if (length(model[['data']][['studies.a']]) > 0) { 52 | sbPriors <- ll.call('study.baseline.priors', model) 53 | template <- template.block.sub(template, 'studyBaselinePriors', sbPriors) 54 | } else { 55 | template <- template.block.sub(template, 'studyBaselinePriors', '## OMITTED') 56 | } 57 | 58 | # Generate parameter priors 59 | priors <- paste(params, "~", "dnorm(0, prior.prec)", collapse="\n") 60 | template <- template.block.sub(template, 'relativeEffectPriors', priors) 61 | 62 | template <- template.block.sub(template, 'regressionPriors', regressionPriors) 63 | 64 | template 65 | } 66 | -------------------------------------------------------------------------------- /gemtc/tests/data/parkinson-diff.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(3891.12097025544, 2 | 4432.57531445087, 6658.24807465956, 20737.6277667317, 1995.81253232397 3 | ), .Names = c("d.D.A", "d.D.B", "d.D.C", "d.D.E", "sd.d")), summary = structure(list( 4 | statistics = structure(c(0.539428872466251, -1.30376790565251, 5 | 0.0333447637350221, -0.298516345157708, 0.36799996250286, 6 | 0.602976696797114, 0.669734944885716, 0.454308455044185, 7 | 0.413032079274214, 0.346916459714541, 0.00213184455601352, 8 | 0.00236787060563144, 0.00160622294656063, 0.00146028892051188, 9 | 0.00122653490584691, 0.00974470734158414, 0.0102832368412415, 10 | 0.00564384111363581, 0.00289697004164241, 0.00778232979982177 11 | ), .Dim = c(5L, 4L), .Dimnames = list(c("d.D.A", "d.D.B", 12 | "d.D.C", "d.D.E", "sd.d"), c("Mean", "SD", "Naive SE", "Time-series SE" 13 | ))), quantiles = structure(c(-0.629920816508038, -2.63548417902084, 14 | -0.863029204548734, -1.12975108662943, 0.0121824678185656, 15 | 0.167028439321915, -1.71155159083651, -0.237133391937875, 16 | -0.505727141432974, 0.118759393028087, 0.537842616244198, 17 | -1.29408565153562, 0.0327891158057697, -0.298145540338414, 18 | 0.268292563529314, 0.911940584066416, -0.887383560149662, 19 | 0.304645449169863, -0.0895042492022365, 0.507211269315543, 20 | 1.73526999421649, -0.0236512247434855, 0.91746863997123, 21 | 0.53421338205999, 1.31196431534602), .Dim = c(5L, 5L), .Dimnames = list( 22 | c("d.D.A", "d.D.B", "d.D.C", "d.D.E", "sd.d"), c("2.5%", 23 | "25%", "50%", "75%", "97.5%"))), start = 5001, end = 25000, 24 | thin = 1, nchain = 4L), .Names = c("statistics", "quantiles", 25 | "start", "end", "thin", "nchain"), class = "summary.mcmc"), cov = structure(c(0.363580896880358, 26 | 0.282990197527293, 0.0956482066367819, -0.000322613846238518, 27 | 0.282990197527293, 0.448544896401073, 0.0739985279005633, -0.00115712864824303, 28 | 0.0956482066367819, 0.0739985279005633, 0.206396172324634, 3.40861344562332e-05, 29 | -0.000322613846238518, -0.00115712864824303, 3.40861344562332e-05, 30 | 0.170595498509581), .Dim = c(4L, 4L), .Dimnames = list(c("d.D.A", 31 | "d.D.B", "d.D.C", "d.D.E"), c("d.D.A", "d.D.B", "d.D.C", "d.D.E" 32 | ))), ranks = structure(c(0.731925, 0.0008625, 0.13165, 0.09035, 33 | 0.0452125, 0.1379125, 0.0101875, 0.4007625, 0.3543625, 0.096775, 34 | 0.0770375, 0.0170125, 0.2552125, 0.4600125, 0.190725, 0.0524125, 35 | 0.0666, 0.1976375, 0.0907375, 0.5926125, 0.0007125, 0.9053375, 36 | 0.0147375, 0.0045375, 0.074675), .Dim = c(5L, 5L), .Dimnames = list( 37 | c("A", "B", "C", "D", "E"), NULL), class = "mtc.rank.probability", direction = 1), 38 | dic = structure(list(Dbar = 6.55069695573273, pD = 5.35284675849313, 39 | DIC = 11.9035437142259, `data points` = 8L), .Names = c("Dbar", 40 | "pD", "DIC", "data points"))), .Names = c("effectiveSize", 41 | "summary", "cov", "ranks", "dic")) 42 | -------------------------------------------------------------------------------- /gemtc/tests/data/parkinson-shared.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(3236.13896085256, 2 | 3664.44054848893, 7095.0287125562, 21741.3136886355, 2026.76911384777 3 | ), .Names = c("d.D.A", "d.D.B", "d.D.C", "d.D.E", "sd.d")), summary = structure(list( 4 | statistics = structure(c(0.528404444070371, -1.33097507581097, 5 | 0.0290190544844919, -0.29794289367157, 0.372892670669298, 6 | 0.617969802681483, 0.687976767892201, 0.458350900559442, 7 | 0.417644667449479, 0.353153704437786, 0.00218485319022295, 8 | 0.00243236518937689, 0.00162051514974271, 0.00147659688239963, 9 | 0.00124858689604554, 0.0109768729596711, 0.0115128913002589, 10 | 0.00547496020518293, 0.00283590412226499, 0.00786273470777539 11 | ), .Dim = c(5L, 4L), .Dimnames = list(c("d.D.A", "d.D.B", 12 | "d.D.C", "d.D.E", "sd.d"), c("Mean", "SD", "Naive SE", "Time-series SE" 13 | ))), quantiles = structure(c(-0.690851646854597, -2.70652398102216, 14 | -0.881903774891221, -1.14748631648327, 0.00887824743524836, 15 | 0.151067448281384, -1.74981531583448, -0.242561461606207, 16 | -0.505996155874541, 0.118722262808919, 0.52222564344534, 17 | -1.3303970146185, 0.0314663449506125, -0.294570850556096, 18 | 0.273019631578773, 0.9043392278308, -0.903151499651083, 0.305807962281106, 19 | -0.0928278307113507, 0.512065948425344, 1.74778681522262, 20 | 0.00508916061162468, 0.910061840582692, 0.557416328324281, 21 | 1.34985639725901), .Dim = c(5L, 5L), .Dimnames = list(c("d.D.A", 22 | "d.D.B", "d.D.C", "d.D.E", "sd.d"), c("2.5%", "25%", "50%", 23 | "75%", "97.5%"))), start = 5001, end = 25000, thin = 1, nchain = 4L), .Names = c("statistics", 24 | "quantiles", "start", "end", "thin", "nchain"), class = "summary.mcmc"), 25 | cov = structure(c(0.381886677026191, 0.30297706151421, 0.0970884013426844, 26 | -0.000752856748590283, 0.30297706151421, 0.4733120331594, 27 | 0.0779558622141362, -0.00124681746901071, 0.0970884013426844, 28 | 0.0779558622141362, 0.210085548043652, -0.00162648964502598, 29 | -0.000752856748590283, -0.00124681746901071, -0.00162648964502598, 30 | 0.174427068248986), .Dim = c(4L, 4L), .Dimnames = list(c("d.D.A", 31 | "d.D.B", "d.D.C", "d.D.E"), c("d.D.A", "d.D.B", "d.D.C", 32 | "d.D.E"))), ranks = structure(c(0.7217375, 0.001, 0.1354125, 33 | 0.0937125, 0.0481375, 0.1345625, 0.0113125, 0.3982375, 0.35735, 34 | 0.0985375, 0.0836125, 0.0183875, 0.247675, 0.45365, 0.196675, 35 | 0.0592, 0.0633125, 0.202425, 0.0904, 0.5846625, 0.0008875, 36 | 0.9059875, 0.01625, 0.0048875, 0.0719875), .Dim = c(5L, 5L 37 | ), .Dimnames = list(c("A", "B", "C", "D", "E"), NULL), class = "mtc.rank.probability", direction = 1), 38 | dic = structure(list(Dbar = 9.63384178632538, pD = 8.44764869933823, 39 | DIC = 18.0814904856636, `data points` = 11L), .Names = c("Dbar", 40 | "pD", "DIC", "data points"))), .Names = c("effectiveSize", 41 | "summary", "cov", "ranks", "dic")) 42 | -------------------------------------------------------------------------------- /gemtc/tests/data/diabetes-surv.fe.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(13257.5176105158, 2 | 18570.3514988159, 19714.9780375518, 18399.615901103, 13905.0869983506 3 | ), .Names = c("d.BB.ACEi", "d.BB.ARB", "d.BB.CCB", "d.BB.Diuretic", 4 | "d.BB.Placebo")), summary = structure(list(statistics = structure(c(-0.301540663399051, 5 | -0.395911112370575, -0.195984693945416, 0.0575021372577395, -0.189830114417826, 6 | 0.0454896301399155, 0.0455843801945271, 0.0307644311120705, 0.0555961706102509, 7 | 0.0498098407599676, 0.000227448150699577, 0.000227921900972636, 8 | 0.000153822155560353, 0.000277980853051254, 0.000249049203799838, 9 | 0.000395593871333845, 0.000334604178655371, 0.000219151260780193, 10 | 0.00041012868858728, 0.000422462391100981), .Dim = c(5L, 4L), .Dimnames = list( 11 | c("d.BB.ACEi", "d.BB.ARB", "d.BB.CCB", "d.BB.Diuretic", "d.BB.Placebo" 12 | ), c("Mean", "SD", "Naive SE", "Time-series SE"))), quantiles = structure(c(-0.390274323682604, 13 | -0.485516173726417, -0.256001331058066, -0.0508422049735636, 14 | -0.286385593375223, -0.332377316838832, -0.426511757360858, -0.216741087023141, 15 | 0.0200291198763657, -0.223580434500793, -0.301361420975243, -0.39590830078798, 16 | -0.196040980645715, 0.0576573018884401, -0.189682419949215, -0.271177271583763, 17 | -0.365340089016754, -0.175115218650967, 0.0947548809040393, -0.156592920765596, 18 | -0.211767320182714, -0.306603968203401, -0.13537298905239, 0.166287394820668, 19 | -0.0924166636480759), .Dim = c(5L, 5L), .Dimnames = list(c("d.BB.ACEi", 20 | "d.BB.ARB", "d.BB.CCB", "d.BB.Diuretic", "d.BB.Placebo"), c("2.5%", 21 | "25%", "50%", "75%", "97.5%"))), start = 5005, end = 55000, thin = 5, 22 | nchain = 4L), .Names = c("statistics", "quantiles", "start", 23 | "end", "thin", "nchain"), class = "summary.mcmc"), cov = structure(c(0.00206930645026631, 24 | 0.00059346723322347, 0.000448418299846062, 0.00116916353076063, 25 | 0.00150411046083656, 0.00059346723322347, 0.0020779357177192, 26 | 0.000668576879884258, 0.00060099216263063, 0.000854194167532837, 27 | 0.000448418299846062, 0.000668576879884258, 0.000946450221649333, 28 | 0.000584016614198571, 0.00054601377328179, 0.00116916353076063, 29 | 0.00060099216263063, 0.000584016614198571, 0.00309093418652412, 30 | 0.00121170615381684, 0.00150411046083656, 0.000854194167532837, 31 | 0.00054601377328179, 0.00121170615381684, 0.00248102023653333 32 | ), .Dim = c(5L, 5L), .Dimnames = list(c("d.BB.ACEi", "d.BB.ARB", 33 | "d.BB.CCB", "d.BB.Diuretic", "d.BB.Placebo"), c("d.BB.ACEi", 34 | "d.BB.ARB", "d.BB.CCB", "d.BB.Diuretic", "d.BB.Placebo"))), ranks = structure(c(0, 35 | 0, 0.14985, 0, 0.85015, 0, 0, 0, 0.850125, 0, 0.14985, 2.5e-05, 36 | 2e-04, 0, 2.5e-05, 0.44745, 0, 0.552325, 0.01375, 5e-05, 0, 0.540875, 37 | 0, 0.445325, 0.943975, 0.042025, 0, 0.011675, 0, 0.002325, 0.042075, 38 | 0.957925, 0, 0, 0, 0), .Dim = c(6L, 6L), .Dimnames = list(c("ACEi", 39 | "ARB", "BB", "CCB", "Diuretic", "Placebo"), NULL))), .Names = c("effectiveSize", 40 | "summary", "cov", "ranks")) 41 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-has.indirect.evidence.R: -------------------------------------------------------------------------------- 1 | context("has.indirect.evidence") 2 | 3 | test_that("single pair-wise comparison gives FALSE", { 4 | data <- read.table(textConnection('study treatment 5 | s01 A 6 | s01 B'), header=T) 7 | network <- mtc.network(data) 8 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(FALSE)) 9 | }) 10 | 11 | test_that("comparison in triangle gives TRUE", { 12 | data <- read.table(textConnection('study treatment 13 | s01 A 14 | s01 B 15 | s02 B 16 | s02 C 17 | s03 C 18 | s03 A'), header=T) 19 | network <- mtc.network(data) 20 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(TRUE)) 21 | 22 | data <- read.table(textConnection('study treatment 23 | s01 A 24 | s01 B 25 | s01 C 26 | s02 B 27 | s02 C 28 | s03 C 29 | s03 A'), header=T) 30 | network <- mtc.network(data) 31 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(TRUE)) 32 | }) 33 | 34 | test_that("comparison in three-arm trial gives FALSE", { 35 | data <- read.table(textConnection('study treatment 36 | s01 A 37 | s01 B 38 | s01 C'), header=T) 39 | network <- mtc.network(data) 40 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(FALSE)) 41 | 42 | data <- read.table(textConnection('study treatment 43 | s01 A 44 | s01 B 45 | s01 C 46 | s02 A 47 | s02 C'), header=T) 48 | network <- mtc.network(data) 49 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(FALSE)) 50 | }) 51 | 52 | test_that("four-arm trials are handled correctly", { 53 | data <- read.table(textConnection('study treatment 54 | s01 A 55 | s01 B 56 | s01 C 57 | s01 D'), header=T) 58 | network <- mtc.network(data) 59 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(FALSE)) 60 | 61 | data <- read.table(textConnection('study treatment 62 | s01 A 63 | s01 B 64 | s01 C 65 | s01 D 66 | s02 B 67 | s02 C'), header=T) 68 | network <- mtc.network(data) 69 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(FALSE)) 70 | 71 | data <- read.table(textConnection('study treatment 72 | s01 A 73 | s01 B 74 | s01 C 75 | s01 D 76 | s02 B 77 | s02 C 78 | s03 A 79 | s03 D'), header=T) 80 | network <- mtc.network(data) 81 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(FALSE)) # used to be TRUE pre-0.6 82 | }) 83 | 84 | test_that("data.re is incorporated", { 85 | data <- read.table(textConnection('study treatment diff std.err 86 | s01 A NA 0.5 87 | s01 B 1.0 0.8 88 | s01 C -1.0 0.8'), header=T) 89 | network <- mtc.network(data.re=data) 90 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(FALSE)) 91 | 92 | data <- read.table(textConnection('study treatment diff std.err 93 | s01 A NA 0.5 94 | s01 B 1.0 0.8 95 | s01 C -1.0 0.8 96 | s02 A NA NA 97 | s02 C 0.1 0.8 98 | s03 B NA NA 99 | s03 C -1.8 0.8'), header=T) 100 | network <- mtc.network(data.re=data) 101 | expect_that(has.indirect.evidence(network, 'A', 'B'), equals(TRUE)) 102 | }) 103 | -------------------------------------------------------------------------------- /gemtc/man/rank.probability.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{rank.probability} 3 | \alias{rank.probability} 4 | \alias{print.mtc.rank.probability} 5 | \alias{plot.mtc.rank.probability} 6 | \alias{sucra} 7 | \alias{rank.quantiles} 8 | \title{Calculating rank-probabilities} 9 | \description{ 10 | Rank probabilities indicate the probability for each treatment to be best, second best, etc. 11 | } 12 | \details{ 13 | For each MCMC iteration, the treatments are ranked by their effect relative to an arbitrary baseline. 14 | A frequency table is constructed from these rankings and normalized by the number of iterations to give the rank probabilities. 15 | } 16 | \usage{ 17 | rank.probability(result, preferredDirection=1, covariate=NA) 18 | 19 | \method{print}{mtc.rank.probability}(x, ...) 20 | \method{plot}{mtc.rank.probability}(x, ...) 21 | 22 | sucra(ranks) 23 | rank.quantiles(ranks, probs=c("2.5\%"=0.025, "50\%"=0.5, "97.5\%"=0.975)) 24 | } 25 | \arguments{ 26 | \item{result}{Object of S3 class \code{mtc.result} to be used in creation of the rank probability table} 27 | \item{preferredDirection}{Preferential direction of the outcome. Set 1 if higher values are preferred, -1 if lower values are preferred.} 28 | \item{covariate}{(Regression analyses only) Value of the covariate at which to compute rank probabilities.} 29 | \item{x}{An object of S3 class \code{rank.probability}.} 30 | \item{...}{Additional arguments.} 31 | \item{ranks}{A ranking matrix where the treatments are the rows (e.g. the result of rank.probability).} 32 | \item{probs}{Probabilities at which to give quantiles.} 33 | } 34 | \value{\code{rank.probability}: A matrix (with class \code{mtc.rank.probability}) with the treatments as rows and the ranks as columns. 35 | \code{sucra}: A vector of SUCRA values. 36 | \code{rank.quantiles}: A matrix with treatments as rows and quantiles as columns, giving the quantile ranks (by default, the median and 2.5\% and 97.5\% ranks). 37 | } 38 | 39 | \author{Gert van Valkenhoef, Joël Kuiper} 40 | 41 | \seealso{ 42 | \code{\link{relative.effect}} 43 | } 44 | \examples{ 45 | model <- mtc.model(smoking) 46 | # To save computation time we load the samples instead of running the model 47 | \dontrun{results <- mtc.run(model)} 48 | results <- dget(system.file("extdata/luades-smoking.samples.gz", package="gemtc")) 49 | 50 | ranks <- rank.probability(results) 51 | print(ranks) 52 | ## Rank probability; preferred direction = 1 53 | ## [,1] [,2] [,3] [,4] 54 | ## A 0.000000 0.003000 0.105125 0.891875 55 | ## B 0.057875 0.175875 0.661500 0.104750 56 | ## C 0.228250 0.600500 0.170875 0.000375 57 | ## D 0.713875 0.220625 0.062500 0.003000 58 | 59 | print(sucra(ranks)) 60 | ## A B C D 61 | ## 0.03670833 0.39591667 0.68562500 0.88175000 62 | 63 | print(rank.quantiles(ranks)) 64 | ## 2.5% 50% 97.5% 65 | ## A 3 4 4 66 | ## B 1 3 4 67 | ## C 1 2 3 68 | ## D 1 1 3 69 | 70 | plot(ranks) # plot a cumulative rank plot 71 | plot(ranks, beside=TRUE) # plot a 'rankogram' 72 | } 73 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-studyrow.R: -------------------------------------------------------------------------------- 1 | context("mtc.data.studyrow") 2 | 3 | studyrow_file <- function(name) { 4 | paste0("../data/studyrow/", name) 5 | } 6 | 7 | test_that("TSD2 example 1 (dichotomous data, binomial/logit)", { 8 | treatments <- c('Control', 'BetaB') 9 | data <- mtc.data.studyrow(read.table(studyrow_file('tsd2-1.data.txt'), header=TRUE), treatmentNames=treatments) 10 | expect_that(data, equals(dget(studyrow_file('tsd2-1.out.txt')))) 11 | }) 12 | 13 | test_that("TSD2 example 2 (count data, poisson/log)", { 14 | treatments <- c('control', 'diet') 15 | studies <- c('DART', 'London Corn/Olive', 'London Low Fat', 'Minnesota Coronary', 'MRC Soya', 'Oslo Diet-Heart', 'STARS', 'Sydney Diet-Heart', 'Veterans Administration', 'Veterans Diet & Skin CA') 16 | data <- mtc.data.studyrow( 17 | read.table(studyrow_file('tsd2-2.data.txt'), header=TRUE), 18 | armVars=c('treatment'='t', 'responders'='r', 'exposure'='E'), 19 | treatmentNames=treatments, studyNames=studies) 20 | 21 | # Needs check.attributes=FALSE because locales may sort upper/lower case differently 22 | # This leads to differences in levels(data$studies) 23 | expect_that(data, equals(dget(studyrow_file('tsd2-2.out.txt')), check.attributes=FALSE)) 24 | }) 25 | 26 | test_that("TSD2 example 3 (count data, binomial/cloglog)", { 27 | studies <- c('MRC-E', 'EWPH', 'SHEP', 'HAPPHY', 'ALLHAT', 'INSIGHT', 'ANBP-2', 'ALPINE', 'FEVER', 'DREAM', 'HOPE', 'PEACE', 'CHARM', 'SCOPE', 'AASK', 'STOP-2', 'ASCOT', 'NORDIL', 'INVEST', 'CAPPP', 'LIFE', 'VALUE') 28 | treatments <- c('Diuretic', 'Placebo', 'BetaB', 'CCB', 'ACEi', 'ARB') 29 | data <- mtc.data.studyrow( 30 | read.table(studyrow_file('tsd2-3.data.txt'), header=TRUE), 31 | studyVars=c('time'='time'), 32 | studyNames=studies, treatmentNames=treatments) 33 | expect_that(data, equals(dget(studyrow_file('tsd2-3.out.txt')))) 34 | }) 35 | 36 | ## TSD2 example 4 (competing risks, multinomial/log) not supported 37 | 38 | test_that("TSD2 example 5 (continuous data, normal/identity)", { 39 | data <- mtc.data.studyrow( 40 | read.table(studyrow_file('tsd2-5.data.txt'), header=TRUE), 41 | armVars=c('treatment'='t', 'mean'='y', 'std.err'='se')) 42 | expect_that(data, equals(dget(studyrow_file('tsd2-5.out.txt')))) 43 | }) 44 | 45 | ## TSD2 example 6 (categorical data, binomial/probit) not supported 46 | 47 | test_that("TSD2 example 7 (relative effect data)", { 48 | data <- mtc.data.studyrow( 49 | read.table(studyrow_file('tsd2-7.data.txt'), header=TRUE), 50 | armVars=c('treatment'='t', 'diff'='y', 'std.err'='se'), 51 | studyVars=c('var'='V')) 52 | expect_that(data, equals(dget(studyrow_file('tsd2-7.out.txt')))) 53 | }) 54 | 55 | test_that("TSD2 example 8 (mixed data)", { 56 | data1 <- mtc.data.studyrow( 57 | read.table(studyrow_file('tsd2-8.data1.txt'), header=TRUE), 58 | armVars=c('treatment'='t.a', 'mean'='y.a', 'std.err'='se.a'), 59 | nArmsVar='na.a') 60 | expect_that(data1, equals(dget(studyrow_file('tsd2-8.out1.txt')))) 61 | 62 | data2 <- mtc.data.studyrow( 63 | read.table(studyrow_file('tsd2-8.data2.txt'), header=TRUE), 64 | armVars=c('treatment'='t', 'diff'='y', 'std.err'='se'), 65 | nArmsVar='na', 66 | studyNames=4:7) 67 | expect_that(data2, equals(dget(studyrow_file('tsd2-8.out2.txt')))) 68 | }) 69 | -------------------------------------------------------------------------------- /gemtc/man/mtc.nodesplit.Rd: -------------------------------------------------------------------------------- 1 | \encoding{utf8} 2 | \name{mtc.nodesplit} 3 | \alias{mtc.nodesplit} 4 | \alias{mtc.nodesplit.comparisons} 5 | \alias{plot.mtc.nodesplit} 6 | \alias{print.mtc.nodesplit} 7 | \alias{summary.mtc.nodesplit} 8 | \alias{plot.mtc.nodesplit.summary} 9 | \alias{print.mtc.nodesplit.summary} 10 | 11 | \title{Node-splitting analysis of inconsistency} 12 | \description{ 13 | Generate and run an ensemble of node-splitting models, results of which can be jointly summarized and plotted. 14 | } 15 | \usage{ 16 | mtc.nodesplit(network, comparisons=mtc.nodesplit.comparisons(network), ...) 17 | mtc.nodesplit.comparisons(network) 18 | } 19 | \arguments{ 20 | \item{network}{An object of S3 class \code{\link{mtc.network}}.} 21 | \item{comparisons}{Data frame specifying the comparisons to be split. The frame has two columns: 't1' and 't2'.} 22 | \item{...}{Arguments to be passed to \code{\link{mtc.run}} or \code{\link{mtc.model}}. This can be used to set the likelihood/link or the number of iterations, for example.} 23 | } 24 | \details{ 25 | \code{mtc.nodesplit} returns the MCMC results for all relevant node-splitting models \link[=gemtc-package]{[van Valkenhoef et al. 2015]}. To get appropriate summary statistics, call \code{summary()} on the results object. The summary can be plotted. 26 | See \code{\link{mtc.model}} for details on how the node-splitting models are generated. 27 | 28 | To control parameters of the MCMC estimation, see \code{\link{mtc.run}}. 29 | To specify the likelihood/link or to control other model parameters, see \code{\link{mtc.model}}. 30 | The \code{...} arguments are first matched against \code{\link{mtc.run}}, and those that do not match are passed to \code{\link{mtc.model}}. 31 | 32 | \code{mtc.nodesplit.comparisons} returns a data frame enumerating all comparisons that can reasonably be split (i.e. have independent indirect evidence). 33 | } 34 | \value{ 35 | For \code{mtc.nodesplit}: 36 | an object of class \code{mtc.nodesplit}. This is a list with the following elements: 37 | \item{d.X.Y}{For each comparison (t1=X, t2=Y), the MCMC results} 38 | \item{consistency}{The consistency model results} 39 | 40 | For \code{summary}: 41 | an object of class \code{mtc.nodesplit.summary}. This is a list with the following elements: 42 | \item{dir.effect}{Summary of direct effects for each split comparison} 43 | \item{ind.effect}{Summary of indirect effects for each split comparison} 44 | \item{cons.effect}{Summary of consistency model effects for each split comparison} 45 | \item{p.value}{Inconsistency p-values for each split comparison} 46 | \item{cons.model}{The generated consistency model} 47 | } 48 | \author{Gert van Valkenhoef, Joël Kuiper} 49 | \seealso{ 50 | \code{\link{mtc.model}} 51 | \code{\link{mtc.run}} 52 | } 53 | \examples{ 54 | # Run all relevant node-splitting models 55 | \dontrun{ result.ns <- mtc.nodesplit(parkinson, thin=50) } 56 | # (read results from file instead of running:) 57 | result.ns <- readRDS(system.file('extdata/parkinson.ns.rds', package='gemtc')) 58 | 59 | # List the individual models 60 | names(result.ns) 61 | 62 | # Time series plots and convergence diagnostics for d.A.C model 63 | plot(result.ns$d.A.C) 64 | gelman.diag(result.ns$d.A.C, multivariate=FALSE) 65 | 66 | # Overall summary and plot 67 | summary.ns <- summary(result.ns) 68 | print(summary.ns) 69 | plot(summary.ns) 70 | } 71 | -------------------------------------------------------------------------------- /gemtc/tests/data/diabetes-surv.summaries.txt: -------------------------------------------------------------------------------- 1 | structure(list(effectiveSize = structure(c(7701.96253403554, 2 | 11853.7424143953, 13219.3554587523, 7712.93613063799, 7797.87635111991, 3 | 3458.58925557315), .Names = c("d.BB.ACEi", "d.BB.ARB", "d.BB.CCB", 4 | "d.BB.Diuretic", "d.BB.Placebo", "sd.d")), summary = structure(list( 5 | statistics = structure(c(-0.327626906891094, -0.399132480909606, 6 | -0.167458262024474, 0.0731575306043285, -0.213791055392142, 7 | 0.128332139273804, 0.0779792158802535, 0.0951012852270691, 8 | 0.0642168699566395, 0.0881397972027764, 0.0858579445618846, 9 | 0.0449514621417379, 0.000275698161702685, 0.000336233818418083, 10 | 0.000227040921064572, 0.000311621241472451, 0.000303553674092236, 11 | 0.000158927418523366, 0.00089087967955544, 0.000873935060388915, 12 | 0.000559195490685848, 0.00100452884767618, 0.000972267375021695, 13 | 0.000767422322292738), .Dim = c(6L, 4L), .Dimnames = list( 14 | c("d.BB.ACEi", "d.BB.ARB", "d.BB.CCB", "d.BB.Diuretic", 15 | "d.BB.Placebo", "sd.d"), c("Mean", "SD", "Naive SE", 16 | "Time-series SE"))), quantiles = structure(c(-0.487520981588871, 17 | -0.597042842260783, -0.294673672637857, -0.0992747487528009, 18 | -0.391455765894431, 0.0522312835677245, -0.376941454937604, 19 | -0.457729534404734, -0.208742922564925, 0.0153745386272644, 20 | -0.267706842761932, 0.0972042991151154, -0.326305760488719, 21 | -0.396192476023362, -0.168407082083191, 0.0727383328065576, 22 | -0.211173920815801, 0.123944080020042, -0.276014122793346, 23 | -0.337268502985686, -0.12672381631178, 0.129895894932752, 24 | -0.156671949551461, 0.154629797985139, -0.179467501645404, 25 | -0.217254544568136, -0.0378938846115613, 0.250554193768916, 26 | -0.0522004460235535, 0.228588042902114), .Dim = c(6L, 5L), .Dimnames = list( 27 | c("d.BB.ACEi", "d.BB.ARB", "d.BB.CCB", "d.BB.Diuretic", 28 | "d.BB.Placebo", "sd.d"), c("2.5%", "25%", "50%", "75%", 29 | "97.5%"))), start = 5001, end = 25000, thin = 1, nchain = 4L), .Names = c("statistics", 30 | "quantiles", "start", "end", "thin", "nchain"), class = "summary.mcmc"), 31 | cov = structure(c(0.00608075810929919, 0.0023763154157881, 32 | 0.00192212637972664, 0.00322677238321556, 0.00407480747953777, 33 | 0.0023763154157881, 0.00904425445184035, 0.00221522079280882, 34 | 0.00222345366762904, 0.0038238547747999, 0.00192212637972664, 35 | 0.00221522079280882, 0.00412380638702795, 0.00236202550537823, 36 | 0.00220901101396279, 0.00322677238321556, 0.00222345366762904, 37 | 0.00236202550537823, 0.00776862385094655, 0.00352346761176047, 38 | 0.00407480747953777, 0.0038238547747999, 0.00220901101396279, 39 | 0.00352346761176047, 0.00737158664439164), .Dim = c(5L, 5L 40 | ), .Dimnames = list(c("d.BB.ACEi", "d.BB.ARB", "d.BB.CCB", 41 | "d.BB.Diuretic", "d.BB.Placebo"), c("d.BB.ACEi", "d.BB.ARB", 42 | "d.BB.CCB", "d.BB.Diuretic", "d.BB.Placebo"))), ranks = structure(c(0, 43 | 3.75e-05, 0.1960125, 0.0006125, 0.803225, 0.0001125, 5e-05, 44 | 0.0001125, 0.791475, 0.009975, 0.192925, 0.0054625, 0.0055625, 45 | 0.00305, 0.0116625, 0.6921125, 0.0037, 0.2839125, 0.06235, 46 | 0.02305, 8e-04, 0.277975, 0.000125, 0.6357, 0.70435, 0.2076875, 47 | 5e-05, 0.01865, 2.5e-05, 0.0692375, 0.2276875, 0.7660625, 48 | 0, 0.000675, 0, 0.005575), .Dim = c(6L, 6L), .Dimnames = list( 49 | c("ACEi", "ARB", "BB", "CCB", "Diuretic", "Placebo"), 50 | NULL))), .Names = c("effectiveSize", "summary", "cov", 51 | "ranks")) 52 | -------------------------------------------------------------------------------- /gemtc/tests/data/welton-cholesterol.gemtc: -------------------------------------------------------------------------------- 1 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | -------------------------------------------------------------------------------- /gemtc/R/mtc.result.R: -------------------------------------------------------------------------------- 1 | #' @include forest.R 2 | #' @include stopIfNotConsistent.R 3 | 4 | ## mtc.result class methods 5 | print.mtc.result <- function(x, ...) { 6 | cat("MTC ", x[['model']][['type']], " results: ", x[['model']][['description']], sep="") 7 | print(x[['samples']]) 8 | } 9 | 10 | summary.mtc.result <- function(object, ...) { 11 | scale.log <- if (ll.call('scale.log', object[['model']])) 'Log ' else '' 12 | scale.name <- ll.call('scale.name', object[['model']]) 13 | rval <- list('measure'=paste0(scale.log, scale.name), 14 | 'summaries'=summary(object[['samples']]), 15 | 'DIC'=unlist(object[['deviance']][c('Dbar', 'pD', 'DIC', 'data points')]), 16 | 'regressor'=object[['model']][['regressor']], 17 | 'covariate'=object[['covariate']]) 18 | class(rval) <- 'summary.mtc.result' 19 | rval 20 | } 21 | 22 | print.summary.mtc.result <- function(x, ...) { 23 | cat(paste("\nResults on the", x[['measure']], "scale\n")) 24 | print(x[['summaries']]) 25 | if (!is.null(x[['DIC']])) { 26 | cat("-- Model fit (residual deviance):\n\n") 27 | dic <- x[['DIC']] 28 | print(dic[c('Dbar', 'pD', 'DIC')]) 29 | cat(paste0("\n", dic['data points'], " data points, ratio ", 30 | format(dic['Dbar'] / dic['data points'], digits=4), 31 | ", I^2 = ", format(100 * max(0, min(1, (dic['Dbar'] - dic['data points'] + 1)/dic['Dbar'])), digits=1), 32 | "%\n")) 33 | } 34 | if (!is.null(x[['regressor']])) { 35 | cat("\n-- Regression settings:\n\n") 36 | r <- x[['regressor']] 37 | if (!is.null(x[['regressor']][['classes']])) { 38 | cat(paste0("Regression on \"", r[['variable']], "\", ", r[['coefficient']], " coefficients, by class\n")) 39 | } else { 40 | cat(paste0("Regression on \"", r[['variable']], "\", ", r[['coefficient']], " coefficients, \"", r[['control']], "\" as control\n")) 41 | } 42 | if (!is.null(x[['covariate']])) { 43 | cat(paste0("Values at ", r[['variable']], " = ", x[['covariate']], "\n")) 44 | } else { 45 | cat(paste0("Input standardized: x' = (", r[['variable']], " - ", format(r[['center']], digits=getOption("digits")), ") / ", format(r[['scale']], digits=getOption("digits")), "\n")) 46 | cat(paste0("Estimates at the centering value: ", r[['variable']], " = ", format(r[['center']], digits=getOption("digits")), "\n")) 47 | } 48 | } 49 | cat("\n") 50 | } 51 | 52 | plot.mtc.result <- function(x, ...) { 53 | plot(x[['samples']], ...) 54 | } 55 | 56 | forest.mtc.result <- function(x, use.description=FALSE, ...) { 57 | stopIfNotConsistent(x, "forest.mtc.result") 58 | 59 | varnames <- colnames(x[['samples']][[1]]) 60 | samples <- as.matrix(x[['samples']][, grep("^d\\.", varnames)]) 61 | stats <- t(apply(samples, 2, quantile, probs=c(0.025, 0.5, 0.975))) 62 | model <- x[['model']] 63 | network <- model[['network']] 64 | comps <- extract.comparisons(varnames) 65 | groups <- comps[,1] 66 | group.names <- unique(groups) 67 | group.labels <- paste("Compared with", if (use.description) treatment.id.to.description(network, group.names) else group.names) 68 | names(group.labels) <- group.names 69 | params <- list(...) 70 | 71 | data <- data.frame( 72 | id=if (use.description) treatment.id.to.description(network, comps[,2]) else comps[,2], 73 | pe=stats[,2], ci.l=stats[,1], ci.u=stats[,3], 74 | group=groups, style="normal") 75 | 76 | blobbogram(data, 77 | columns=c(), column.labels=c(), 78 | id.label="", 79 | ci.label=paste(ll.call('scale.name', model), "(95% CrI)"), 80 | log.scale=ll.call('scale.log', model), 81 | grouped=TRUE, group.labels=group.labels, 82 | ...) 83 | } 84 | 85 | as.mcmc.list.mtc.result <- function(x, ...) { 86 | x[['samples']] 87 | } 88 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-ll.binom.log.R: -------------------------------------------------------------------------------- 1 | context("ll.binom.log") 2 | 3 | test_that("mtc.arm.mle (default correction)", { 4 | expect_that(mtc.arm.mle.binom.log(c('responders'=0, 'sampleSize'=25)), 5 | equals(c('mean'=log(0.5/26), 'sd'=sqrt(1/0.5 - 1/26)))) 6 | 7 | expect_that(mtc.arm.mle.binom.log(c('responders'=12, 'sampleSize'=25)), 8 | equals(c('mean'=log(12.5/26), 'sd'=sqrt(1/12.5 - 1/26)))) 9 | 10 | expect_that(mtc.arm.mle.binom.log(c('responders'=25, 'sampleSize'=25)), 11 | equals(c('mean'=log(25.5/26), 'sd'=sqrt(1/25.5 - 1/26)))) 12 | }) 13 | 14 | test_that("mtc.arm.mle (no correction)", { 15 | expect_equal(mtc.arm.mle.binom.log(c('responders'=12, 'sampleSize'=25), k=0), 16 | c('mean'=log(12/25), 'sd'=sqrt(1/12 - 1/25))) 17 | }) 18 | 19 | test_that("mtc.arm.mle (other correction)", { 20 | expect_equal(mtc.arm.mle.binom.log(c('responders'=0, 'sampleSize'=25), k=0.05), 21 | c('mean'=log(0.05/25.1), 'sd'=sqrt(1/0.05 - 1/25.1))) 22 | }) 23 | 24 | test_that("mtc.rel.mle (forced default correction)", { 25 | expect_that(mtc.rel.mle.binom.log(rbind(c('responders'=0, 'sampleSize'=25), c('responders'=3, 'sampleSize'=25))), 26 | equals(c('mean'=log(7), 'sd'=sqrt(1/3.5 + 1/0.5 - 2/26)))) 27 | 28 | expect_that(mtc.rel.mle.binom.log(rbind(c('responders'=0, 'sampleSize'=25), c('responders'=0, 'sampleSize'=25))), 29 | equals(c('mean'=0, 'sd'=sqrt(2/0.5 - 2/26)))) 30 | }) 31 | 32 | test_that("mtc.rel.mle (as-needed default correction)", { 33 | expect_equal(mtc.rel.mle.binom.log(rbind(c('responders'=1, 'sampleSize'=25), c('responders'=3, 'sampleSize'=24)), correction.force=FALSE), 34 | c('mean'=log((3/24)/(1/25)), 'sd'=sqrt(1/3 - 1/24 + 1/1 - 1/25))) 35 | 36 | expect_equal(mtc.rel.mle.binom.log(rbind(c('responders'=0, 'sampleSize'=25), c('responders'=3, 'sampleSize'=24)), correction.force=FALSE), 37 | c('mean'=log((3.5/25)/(0.5/26)), 'sd'=sqrt(1/3.5 - 1/25 + 1/0.5 - 1/26))) 38 | 39 | expect_equal(mtc.rel.mle.binom.log(rbind(c('responders'=1, 'sampleSize'=25), c('responders'=24, 'sampleSize'=24)), correction.force=FALSE), 40 | c('mean'=log((24.5/25)/(1.5/26)), 'sd'=sqrt(1/24.5 - 1/25 + 1/1.5 - 1/26))) 41 | }) 42 | 43 | test_that("mtc.rel.mle (alternative magnitude correction)", { 44 | expect_equal(mtc.rel.mle.binom.log(rbind(c('responders'=0, 'sampleSize'=25), c('responders'=3, 'sampleSize'=25)), correction.magnitude=0.1), 45 | c('mean'=log((3.05/25.1)/(0.05/25.1)), 'sd'=sqrt(1/3.05 - 1/25.1 + 1/0.05 - 1/25.1))) 46 | }) 47 | 48 | test_that("mtc.rel.mle (reciprocal correction)", { 49 | # no correction 50 | expect_equal(mtc.rel.mle.binom.log(rbind(c('responders'=1, 'sampleSize'=25), c('responders'=3, 'sampleSize'=24)), correction.type="reciprocal", correction.force=FALSE), 51 | c('mean'=log((3/24)/(1/25)), 'sd'=sqrt(1/3 - 1/24 + 1/1 - 1/25))) 52 | 53 | # 1:2 group ratio (R = 2), correction for the control is R/(R+1) = 2/3, for the treatment 1/(R+1) = 1/3 54 | expect_equal(mtc.rel.mle.binom.log(rbind(c('responders'=0, 'sampleSize'=50), c('responders'=3, 'sampleSize'=25)), correction.type="reciprocal"), 55 | c('mean'=log(((3+1/3)/(25+2/3))/((0+2/3)/(50+4/3))), 'sd'=sqrt(1/(3+1/3) + 1/(0+2/3) - 1/(25+2/3) - 1/(50+4/3)))) 56 | 57 | # 1:4 group ratio (R = 4), correction for the control is R/(R+1) = 4/5, for the treatment 1/(R+1) = 1/5 58 | expect_equal(mtc.rel.mle.binom.log(rbind(c('responders'=0, 'sampleSize'=100), c('responders'=3, 'sampleSize'=25)), correction.type="reciprocal"), 59 | c('mean'=log((3.2/25.4)/(0.8/101.6)), 'sd'=sqrt(1/3.2 + 1/0.8 - 1/25.4 - 1/101.6))) 60 | 61 | # 1:4 group ratio (R = 4), correction for the control is 0.1 R/(R+1) = 0.4/5, for the treatment 0.1/(R+1) = 0.1/5 62 | expect_equal(mtc.rel.mle.binom.log(rbind(c('responders'=0, 'sampleSize'=100), c('responders'=3, 'sampleSize'=25)), correction.type="reciprocal", correction.magnitude=0.1), 63 | c('mean'=log((3.02/25.04)/(0.08/100.16)), 'sd'=sqrt(1/3.02 + 1/0.08 - 1/25.04 - 1/100.16))) 64 | }) 65 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-ll.poisson.log.R: -------------------------------------------------------------------------------- 1 | context("ll.poisson.log") 2 | 3 | test_that("mtc.arm.mle (default correction)", { 4 | expect_equal(mtc.arm.mle.poisson.log(c('responders'=0, 'exposure'=25)), 5 | c('mean'=log(0.5/25), 'sd'=sqrt(1/25))) 6 | 7 | expect_equal(mtc.arm.mle.poisson.log(c('responders'=12, 'exposure'=25)), 8 | c('mean'=log(12.5/25), 'sd'=sqrt(1/25))) 9 | 10 | expect_equal(mtc.arm.mle.poisson.log(c('responders'=25, 'exposure'=25)), 11 | c('mean'=log(25.5/25), 'sd'=sqrt(1/25))) 12 | }) 13 | 14 | test_that("mtc.arm.mle (no correction)", { 15 | expect_equal(mtc.arm.mle.poisson.log(c('responders'=12, 'exposure'=25), k=0), 16 | c('mean'=log(12/25), 'sd'=sqrt(1/25))) 17 | }) 18 | 19 | test_that("mtc.arm.mle (other correction)", { 20 | expect_equal(mtc.arm.mle.poisson.log(c('responders'=0, 'exposure'=25), k=0.05), 21 | c('mean'=log(0.05/25), 'sd'=sqrt(1/25))) 22 | }) 23 | 24 | test_that("mtc.rel.mle (forced default correction)", { 25 | expect_that(mtc.rel.mle.poisson.log(rbind(c('responders'=0, 'exposure'=25), c('responders'=3, 'exposure'=25))), 26 | equals(c('mean'=log(7), 'sd'=sqrt(2/25)))) 27 | 28 | expect_that(mtc.rel.mle.poisson.log(rbind(c('responders'=0, 'exposure'=25), c('responders'=0, 'exposure'=25))), 29 | equals(c('mean'=0, 'sd'=sqrt(2/25)))) 30 | }) 31 | 32 | test_that("mtc.rel.mle (as-needed default correction)", { 33 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=1, 'exposure'=25), c('responders'=3, 'exposure'=24)), correction.force=FALSE), 34 | c('mean'=log((3/24)/(1/25)), 'sd'=sqrt(1/24 + 1/25))) 35 | 36 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=0, 'exposure'=25), c('responders'=3, 'exposure'=24)), correction.force=FALSE), 37 | c('mean'=log((3.5/24)/(0.5/25)), 'sd'=sqrt(1/24 + 1/25))) 38 | 39 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=1, 'exposure'=25), c('responders'=24, 'exposure'=24)), correction.force=FALSE), 40 | c('mean'=log((24/24)/(1/25)), 'sd'=sqrt(1/24 + 1/25))) 41 | }) 42 | 43 | test_that("mtc.rel.mle (alternative magnitude correction)", { 44 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=0, 'exposure'=25), c('responders'=3, 'exposure'=25)), correction.magnitude=0.1), 45 | c('mean'=log((3.05/25)/(0.05/25)), 'sd'=sqrt(2/25))) 46 | }) 47 | 48 | test_that("mtc.rel.mle (reciprocal correction)", { 49 | # no correction 50 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=1, 'exposure'=25), c('responders'=3, 'exposure'=24)), correction.type="reciprocal", correction.force=FALSE), 51 | c('mean'=log((3/24)/(1/25)), 'sd'=sqrt(1/24 + 1/25))) 52 | 53 | # 1:2 group ratio (R = 2), correction for the control is R/(R+1) = 2/3, for the treatment 1/(R+1) = 1/3 54 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=0, 'exposure'=50), c('responders'=3, 'exposure'=25)), correction.type="reciprocal"), 55 | c('mean'=log(((3+1/3)/25)/((0+2/3)/50)), 'sd'=sqrt(1/25 + 1/50))) 56 | 57 | # 1:4 group ratio (R = 4), correction for the control is R/(R+1) = 4/5, for the treatment 1/(R+1) = 1/5 58 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=0, 'exposure'=100), c('responders'=3, 'exposure'=25)), correction.type="reciprocal"), 59 | c('mean'=log((3.2/25)/(0.8/100)), 'sd'=sqrt(1/25 + 1/100))) 60 | 61 | # 1:4 group ratio (R = 4), correction for the control is 0.1 R/(R+1) = 0.4/5, for the treatment 0.1/(R+1) = 0.1/5 62 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=0, 'exposure'=100), c('responders'=3, 'exposure'=25)), correction.type="reciprocal", correction.magnitude=0.1), 63 | c('mean'=log((3.02/25)/(0.08/100)), 'sd'=sqrt(1/25 + 1/100))) 64 | 65 | # 1:4 group ratio (R = 4), correction for the control is 0.1 R/(R+1) = 0.4/5, for the treatment 0.1/(R+1) = 0.1/5 66 | expect_equal(mtc.rel.mle.poisson.log(rbind(c('responders'=0, 'exposure'=100), c('responders'=0, 'exposure'=25)), correction.type="reciprocal", correction.magnitude=0.1), 67 | c('mean'=0, 'sd'=sqrt(1/25 + 1/100))) 68 | }) 69 | -------------------------------------------------------------------------------- /gemtc/R/data.R: -------------------------------------------------------------------------------- 1 | arm.index.matrix <- function(network) { 2 | studies <- mtc.studies.list(network) 3 | all.studies <- inverse.rle(studies) 4 | n <- max(studies[['lengths']]) 5 | t(sapply(studies[['values']], function(study) { 6 | v <- which(all.studies == study) 7 | length(v) <- n 8 | v 9 | })) 10 | } 11 | 12 | mtc.model.data <- function(model) { 13 | data.ab <- model[['network']][['data.ab']] 14 | data.re <- model[['network']][['data.re']] 15 | 16 | columns.ab <- ll.call('required.columns.ab', model) 17 | if (!(is.null(data.ab) || all(columns.ab %in% colnames(data.ab)))) { 18 | stop(paste( 19 | 'likelihood =', model[['likelihood']], 20 | 'link =', model[['link']], 'requires columns:', paste(columns.ab, collapse=', '), 'on data')) 21 | } 22 | columns.re <- c('m'='diff', 'e'='std.err') 23 | if (!(is.null(data.re) || all(columns.re %in% colnames(data.re)))) { 24 | stop(paste( 25 | 'likelihood =', model[['likelihood']], 26 | 'link =', model[['link']], 'requires columns:', paste(columns.ab, collapse=', '), 'on data.re')) 27 | } 28 | 29 | data <- data.frame( 30 | t=c(data.ab[['treatment']], data.re[['treatment']]) 31 | ) 32 | nrow.ab <- if (!is.null(data.ab)) nrow(data.ab) else 0 33 | nrow.re <- if (!is.null(data.re)) nrow(data.re) else 0 34 | if (nrow.ab > 0) { 35 | for (column in names(columns.ab)) { 36 | data[[column]] <- NA 37 | coldata <- data.ab[[columns.ab[column]]] 38 | if (any(is.na(coldata))) { 39 | stop(paste('data.ab contains NAs in column "', columns.ab[column], '"', sep="")) 40 | } 41 | data[[column]][1:nrow.ab] <- data.ab[[columns.ab[column]]] 42 | } 43 | } 44 | if (nrow.re > 0) { 45 | for (column in names(columns.re)) { 46 | if (!(column %in% colnames(data))) { 47 | data[[column]] <- NA 48 | } 49 | data[[column]][(nrow.ab + 1):(nrow.ab + nrow.re)] <- data.re[[columns.re[column]]] 50 | } 51 | mtc.validate.data.re(data.re) 52 | } 53 | 54 | studies.ab <- rle(as.character(data.ab[['study']]))[['values']] 55 | studies.re <- rle(as.character(data.re[['study']]))[['values']] 56 | studies <- c(studies.ab, studies.re) 57 | study.arms <- c(as.character(data.ab[['study']]), as.character(data.re[['study']])) 58 | na <- sapply(studies, function(study) { sum(study.arms == study) }) 59 | na.re <- if (length(studies.re) > 0 ) na[(length(studies.ab)+1):length(studies)] else c() 60 | s.mat <- arm.index.matrix(model[['network']]) 61 | 62 | model.data <- lapply(data, function(column) { matrix(column[s.mat], nrow=nrow(s.mat)) }) 63 | names(model.data) <- colnames(data) 64 | 65 | ns.a <- length(studies.ab) 66 | ns.r2 <- sum(na.re == 2) 67 | ns.rm <- sum(na.re > 2) 68 | model.data <- c(model.data, list( 69 | na = unname(na), 70 | nt = nrow(model[['network']][['treatments']]), 71 | om.scale = model[['om.scale']])) 72 | 73 | powerAdjust <- model[['powerAdjust']] 74 | if (!is.null(powerAdjust) && !is.na(powerAdjust)) { 75 | studyData <- model[['network']][['studies']] 76 | alpha <- studyData[[powerAdjust]] 77 | names(alpha) <- studyData[['study']] 78 | alpha <- alpha[as.character(studies)] 79 | model.data[['alpha']] <- alpha 80 | 81 | if (model[['likelihood']] != 'normal') { 82 | model.data[['zero']] <- matrix(0, ncol=max(na), nrow=length(studies.ab)) 83 | } 84 | } else { 85 | alpha <- rep(1, length(studies)) 86 | } 87 | 88 | studies.a <- if (ns.a > 0) 1:ns.a else numeric() 89 | studies.a <- studies.a[alpha[studies.a] > 0] 90 | studies.r2 <- if (ns.r2 > 0) ns.a + (1:ns.r2) else numeric() 91 | studies.r2 <- studies.r2[alpha[studies.r2] > 0] 92 | studies.rm <- if (ns.rm > 0) ns.a + ns.r2 + (1:ns.rm) else numeric() 93 | studies.rm <- studies.rm[alpha[studies.rm] > 0] 94 | # conditional assigns necessary until JAGS accepts zero-length vectors 95 | if (length(studies.a) > 0) { 96 | model.data[['studies.a']] <- studies.a 97 | } 98 | if (length(studies.r2) > 0) { 99 | model.data[['studies.r2']] <- studies.r2 100 | } 101 | if (length(studies.rm) > 0) { 102 | model.data[['studies.rm']] <- studies.rm 103 | } 104 | model.data[['studies']] <- c(studies.a, studies.r2, studies.rm) 105 | 106 | model.data 107 | } 108 | -------------------------------------------------------------------------------- /gemtc/tests/testthat/test-unit-allpairs.R: -------------------------------------------------------------------------------- 1 | # Test calculation of all-pairs MLE estimates (needed for priors, starting values) 2 | context("rel.mle.[ab|re]") 3 | 4 | test_that("a single pair returns a one-row matrix", { 5 | data <- data.frame(treatment=c("A", "B"), mean=c(1.0, 2.0), std.err=c(0.5/4, 0.5/4)) 6 | model <- list("likelihood"="normal", "link"="identity") 7 | pairs <- data.frame(t1=data$treatment[1], t2=data$treatment[2]) 8 | expected <- matrix(c('mean'=1.0, 'sd'=sqrt(2*0.125^2)), nrow=1, ncol=2) 9 | colnames(expected) <- c('mean', 'sd') 10 | expect_that(rel.mle.ab(data, model, pairs), equals(expected)) 11 | }) 12 | 13 | test_that("two pairs return a two-row matrix", { 14 | data <- data.frame(treatment=c("A", "B", "C"), mean=c(1.0, 2.0, 2.5), std.err=c(0.5/4, 0.5/4, 1.0/4), stringsAsFactors=T) 15 | model <- list("likelihood"="normal", "link"="identity") 16 | ts <- data$treatment 17 | pairs <- data.frame(t1=coerce.factor(c(ts[1], ts[1]), ts), t2=coerce.factor(c(ts[2], ts[3]), ts)) 18 | expected <- matrix(c(1.0, sqrt(2*0.125^2), 1.5, sqrt(0.125^2 + 0.25^2)), ncol=2, byrow=TRUE) 19 | colnames(expected) <- c('mean', 'sd') 20 | expect_that(rel.mle.ab(data, model, pairs), equals(expected)) 21 | }) 22 | 23 | test_that("calculating pairs for relative effect data transforms the mvnorm", { 24 | data <- read.table(textConnection(" 25 | study treatment diff std.err 26 | s07 A NA 0.50 27 | s07 B -2.3 0.72 28 | s07 D -0.9 0.69"), header=T, stringsAsFactors=T) 29 | ts <- data$treatment 30 | pairs <- data.frame(t1=coerce.factor(c(ts[3], ts[3]), ts), t2=coerce.factor(c(ts[1], ts[2]), ts)) 31 | expected <- matrix(c(0.9, 0.69, -1.4, sqrt(0.72^2+0.69^2-2*0.50^2)), ncol=2, byrow=TRUE) 32 | colnames(expected) <- c('mean', 'sd') 33 | expect_that(rel.mle.re(data, pairs), equals(expected)) 34 | }) 35 | 36 | test_that("calculating pairs for relative effect data handles 1-pair case", { 37 | data <- read.table(textConnection(" 38 | study treatment diff std.err 39 | s07 A NA 0.50 40 | s07 B -2.3 0.72 41 | s07 D -0.9 0.69"), header=T, stringsAsFactors=T) 42 | ts <- data$treatment 43 | pairs <- data.frame(t1=coerce.factor(c(ts[3], ts[3]), ts), t2=coerce.factor(c(ts[1], ts[2]), ts)) 44 | expected <- matrix(c(0.9, 0.69, -1.4, sqrt(0.72^2+0.69^2-2*0.50^2)), ncol=2, byrow=TRUE) 45 | colnames(expected) <- c('mean', 'sd') 46 | expect_that(rel.mle.re(data, pairs), equals(expected)) 47 | }) 48 | 49 | test_that("calculating pairs for relative effect data handles missing treatments", { 50 | data <- read.table(textConnection(" 51 | study treatment diff std.err 52 | s07 A NA 0.50 53 | s07 B -2.3 0.72 54 | s07 D -0.9 0.69 55 | s08 C NA 0.3"), header=T, stringsAsFactors=T) 56 | ts <- data$treatment 57 | pairs <- data.frame(t1=coerce.factor(c(ts[3]), ts), t2=coerce.factor(c(ts[2]), ts)) 58 | expected <- matrix(c(-1.4, sqrt(0.72^2+0.69^2-2*0.50^2)), ncol=2, byrow=TRUE) 59 | colnames(expected) <- c('mean', 'sd') 60 | expect_that(rel.mle.re(data[data$study=="s07",], pairs), equals(expected)) 61 | }) 62 | 63 | test_that("guess.scale handles relative effect data", { 64 | data <- read.table(textConnection(" 65 | study treatment diff std.err 66 | s07 A NA 0.50 67 | s07 B -2.3 0.72 68 | s07 D -0.9 0.69"), header=T, stringsAsFactors=T) 69 | network <- mtc.network(data.re=data) 70 | 71 | model <- list( 72 | network = network, 73 | likelihood = 'normal', 74 | link = 'identity' 75 | ) 76 | expect_that(guess.scale(model), equals(2.3)) 77 | }) 78 | 79 | test_that("guess.scale not confused by unrealized study levels", { 80 | network <- list(treatments=data.frame(id=as.factor(c("A", "B"))), data.ab = data.frame( 81 | study=factor(c("1", "1"), levels=c("1", "2")), treatment=as.factor(c("A", "B")), responders=c(1, 3), sampleSize=c(10, 10))) 82 | expect_that(guess.scale(list(network=network, likelihood='binom', link='logit')), equals(1.083687, tolerance=1e-6)) 83 | 84 | network <- list(treatments=data.frame(id=as.factor(c("A", "B"))), data.re = data.frame( 85 | study=factor(c("1", "1"), levels=c("1", "2")), treatment=as.factor(c("A", "B")), diff=c(NA, 1), std.err=c(NA, 1))) 86 | expect_that(guess.scale(list(network=network, likelihood='binom', link='logit')), equals(1)) 87 | }) 88 | --------------------------------------------------------------------------------