wviechtb / metafor

@@ -99,7 +99,7 @@
Loading
99 99
   if (exact) {
100 100
101 101
      incl <- as.matrix(expand.grid(replicate(x$k, list(c(FALSE,TRUE))), KEEP.OUT.ATTRS=FALSE))
102 -
      incl <- incl[rowSums(incl) >= x$p,]
102 +
      incl <- incl[rowSums(incl) >= x$p,,drop=FALSE]
103 103
104 104
      ### slower, but does not generate rows that need to be filtered out (as above)
105 105
      #incl <- lapply(x$p:x$k, function(m) apply(combn(x$k,m), 2, function(l) 1:x$k %in% l))
@@ -127,32 +127,34 @@
Loading
127 127
128 128
   #########################################################################
129 129
130 +
   outlist <- "beta=beta, k=k, QE=QE, I2=I2, H2=H2, tau2=tau2, coef.na=coef.na"
131 +
130 132
   if (parallel == "no") {
131 133
132 134
      if (inherits(x, "rma.uni"))
133 -
         res <- pbapply::pbapply(incl, 1, .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE)
135 +
         res <- pbapply::pbapply(incl, 1, .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE, outlist=outlist)
134 136
135 137
      if (inherits(x, "rma.mh"))
136 -
         res <- pbapply::pbapply(incl, 1, .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE)
138 +
         res <- pbapply::pbapply(incl, 1, .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE, outlist=outlist)
137 139
138 140
      if (inherits(x, "rma.peto"))
139 -
         res <- pbapply::pbapply(incl, 1, .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE)
141 +
         res <- pbapply::pbapply(incl, 1, .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE, outlist=outlist)
140 142
141 143
   }
142 144
143 145
   if (parallel == "multicore") {
144 146
145 147
      if (inherits(x, "rma.uni"))
146 -
         res <- pbapply::pbapply(incl, 1, .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE, cl=ncpus)
147 -
         #res <- parallel::mclapply(asplit(incl, 1), .profile.rma.uni, obj=x, mc.cores=ncpus, parallel=parallel, subset=TRUE, FE=FE)
148 +
         res <- pbapply::pbapply(incl, 1, .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE, outlist=outlist, cl=ncpus)
149 +
         #res <- parallel::mclapply(asplit(incl, 1), .profile.rma.uni, obj=x, mc.cores=ncpus, parallel=parallel, subset=TRUE, FE=FE, outlist=outlist)
148 150
149 151
      if (inherits(x, "rma.mh"))
150 -
         res <- pbapply::pbapply(incl, 1, .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE, cl=ncpus)
151 -
         #res <- parallel::mclapply(asplit(incl, 1), .profile.rma.mh, obj=x, mc.cores=ncpus, parallel=parallel, subset=TRUE)
152 +
         res <- pbapply::pbapply(incl, 1, .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE, outlist=outlist, cl=ncpus)
153 +
         #res <- parallel::mclapply(asplit(incl, 1), .profile.rma.mh, obj=x, mc.cores=ncpus, parallel=parallel, subset=TRUE, outlist=outlist)
152 154
153 155
      if (inherits(x, "rma.peto"))
154 -
         res <- pbapply::pbapply(incl, 1, .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE, cl=ncpus)
155 -
         #res <- parallel::mclapply(asplit(incl, 1), .profile.rma.peto, obj=x, mc.cores=ncpus, parallel=parallel, subset=TRUE)
156 +
         res <- pbapply::pbapply(incl, 1, .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE, outlist=outlist, cl=ncpus)
157 +
         #res <- parallel::mclapply(asplit(incl, 1), .profile.rma.peto, obj=x, mc.cores=ncpus, parallel=parallel, subset=TRUE, outlist=outlist)
156 158
157 159
   }
158 160
@@ -165,35 +167,38 @@
Loading
165 167
166 168
      if (inherits(x, "rma.uni")) {
167 169
         if (.isTRUE(ddd$LB)) {
168 -
            res <- parallel::parLapplyLB(cl, asplit(incl, 1), .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE)
170 +
            res <- parallel::parLapplyLB(cl, asplit(incl, 1), .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE, outlist=outlist)
169 171
         } else {
170 -
            res <- pbapply::pbapply(incl, 1, .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE, cl=cl)
171 -
            #res <- parallel::parLapply(cl, asplit(incl, 1), .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE)
172 +
            res <- pbapply::pbapply(incl, 1, .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE, outlist=outlist, cl=cl)
173 +
            #res <- parallel::parLapply(cl, asplit(incl, 1), .profile.rma.uni, obj=x, parallel=parallel, subset=TRUE, FE=FE, outlist=outlist)
172 174
         }
173 175
      }
174 176
175 177
      if (inherits(x, "rma.mh")) {
176 178
         if (.isTRUE(ddd$LB)) {
177 -
            res <- parallel::parLapplyLB(cl, asplit(incl, 1), .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE)
179 +
            res <- parallel::parLapplyLB(cl, asplit(incl, 1), .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE, outlist=outlist)
178 180
         } else {
179 -
            res <- pbapply::pbapply(incl, 1, .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE, cl=cl)
180 -
            #res <- parallel::parLapply(cl, asplit(incl, 1), .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE)
181 +
            res <- pbapply::pbapply(incl, 1, .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE, outlist=outlist, cl=cl)
182 +
            #res <- parallel::parLapply(cl, asplit(incl, 1), .profile.rma.mh, obj=x, parallel=parallel, subset=TRUE, outlist=outlist)
181 183
         }
182 184
      }
183 185
184 186
      if (inherits(x, "rma.peto")) {
185 187
         if (.isTRUE(ddd$LB)) {
186 -
            res <- parallel::parLapplyLB(cl, asplit(incl, 1), .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE)
188 +
            res <- parallel::parLapplyLB(cl, asplit(incl, 1), .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE, outlist=outlist)
187 189
         } else {
188 -
            res <- pbapply::pbapply(incl, 1, .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE, cl=cl)
189 -
            #res <- parallel::parLapply(cl, asplit(incl, 1), .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE)
190 +
            res <- pbapply::pbapply(incl, 1, .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE, outlist=outlist, cl=cl)
191 +
            #res <- parallel::parLapply(cl, asplit(incl, 1), .profile.rma.peto, obj=x, parallel=parallel, subset=TRUE, outlist=outlist)
190 192
         }
191 193
      }
192 194
193 195
   }
194 196
195 -
   beta <- do.call("rbind", lapply(res, function(x) t(x$beta)))
196 -
   het  <- do.call("rbind", lapply(res, function(x) x$het))
197 +
   beta <- do.call("rbind", lapply(res, function(x) if (inherits(x, "try-error") || any(x$coef.na)) NA else t(x$beta)))
198 +
   het  <- do.call("rbind", lapply(res, function(x) if (inherits(x, "try-error") || any(x$coef.na)) NA else c(x$k, x$QE, x$I2, x$H2, x$tau2)))
199 +
200 +
   if (all(is.na(het)))
201 +
      stop(mstyle$stop("All model fits failed."))
197 202
198 203
   #########################################################################
199 204
@@ -215,8 +220,8 @@
Loading
215 220
   ### combine het and beta objects and order incl and res by k
216 221
217 222
   res <- data.frame(het, beta)
218 -
   incl <- incl[order(res$k),]
219 -
   res <- res[order(res$k),]
223 +
   incl <- incl[order(res$k),,drop=FALSE]
224 +
   res <- res[order(res$k),,drop=FALSE]
220 225
221 226
   ### fix rownames
222 227

@@ -389,6 +389,7 @@
Loading
389 389
   int.only  <- TRUE
390 390
   btt       <- 1
391 391
   m         <- 1
392 +
   coef.na   <- c(X=FALSE)
392 393
393 394
   method    <- "FE"
394 395
   weighted  <- TRUE
@@ -402,7 +403,7 @@
Loading
402 403
                  I2=I2, H2=H2,
403 404
                  QE=QE, QEp=QEp,
404 405
                  k=k, k.f=k.f, k.yi=k.yi, k.pos=k.pos, k.eff=k.eff, k.all=k.all, p=p, p.eff=p.eff, parms=parms,
405 -
                  int.only=int.only, intercept=intercept,
406 +
                  int.only=int.only, intercept=intercept, coef.na=coef.na,
406 407
                  yi=yi, vi=vi, yi.f=yi.f, vi.f=vi.f, X.f=X.f, ai=ai, bi=bi, ci=ci, di=di, ai.f=ai.f, bi.f=bi.f, ci.f=ci.f, di.f=di.f, ni=ni, ni.f=ni.f,
407 408
                  ids=ids, not.na=not.na, subset=subset, not.na.yivi=not.na.yivi, slab=slab, slab.null=slab.null,
408 409
                  measure=measure, method=method, weighted=weighted,

@@ -763,6 +763,7 @@
Loading
763 763
   int.only  <- TRUE
764 764
   btt       <- 1
765 765
   m         <- 1
766 +
   coef.na   <- c(X=FALSE)
766 767
767 768
   method    <- "FE"
768 769
   weighted  <- TRUE
@@ -776,7 +777,7 @@
Loading
776 777
                  I2=I2, H2=H2,
777 778
                  QE=QE, QEp=QEp, CO=CO, COp=COp, MH=MH, MHp=MHp, BD=BD, BDp=BDp, TA=TA, TAp=TAp,
778 779
                  k=k, k.f=k.f, k.yi=k.yi, k.pos=k.pos, k.eff=k.eff, k.all=k.all, p=p, p.eff=p.eff, parms=parms,
779 -
                  int.only=int.only, intercept=intercept,
780 +
                  int.only=int.only, intercept=intercept, coef.na=coef.na,
780 781
                  yi=yi, vi=vi, yi.f=yi.f, vi.f=vi.f, X.f=X.f,
781 782
                  ai=ai, bi=bi, ci=ci, di=di, ai.f=ai.f, bi.f=bi.f, ci.f=ci.f, di.f=di.f,
782 783
                  x1i=x1i, x2i=x2i, t1i=t1i, t2i=t2i, x1i.f=x1i.f, x2i.f=x2i.f, t1i.f=t1i.f, t2i.f=t2i.f, ni=ni, ni.f=ni.f,

@@ -2,7 +2,7 @@
Loading
2 2
3 3
### for profile(), confint(), and gosh()
4 4
5 -
.profile.rma.uni <- function(val, obj, parallel=FALSE, profile=FALSE, confint=FALSE, subset=FALSE, objective, FE=FALSE, verbose=FALSE) {
5 +
.profile.rma.uni <- function(val, obj, parallel=FALSE, profile=FALSE, confint=FALSE, subset=FALSE, objective, FE=FALSE, verbose=FALSE, outlist=NULL) {
6 6
7 7
   mstyle <- .get.mstyle("crayon" %in% .packages())
8 8
@@ -13,7 +13,9 @@
Loading
13 13
14 14
      ### for profile and confint, fit model with tau2 fixed to 'val'
15 15
16 -
      res <- try(suppressWarnings(rma.uni(obj$yi, obj$vi, weights=obj$weights, mods=obj$X, intercept=FALSE, method=obj$method, weighted=obj$weighted, test=obj$test, level=obj$level, control=obj$control, tau2=val, skipr2=TRUE, outlist="minimal")), silent=TRUE)
16 +
      res <- try(suppressWarnings(rma.uni(obj$yi, obj$vi, weights=obj$weights, mods=obj$X, intercept=FALSE,
17 +
                                          method=obj$method, weighted=obj$weighted, test=obj$test, level=obj$level,
18 +
                                          control=obj$control, tau2=val, skipr2=TRUE, outlist="minimal")), silent=TRUE)
17 19
18 20
   }
19 21
@@ -70,17 +72,14 @@
Loading
70 72
            H2 <- 1
71 73
         }
72 74
         tau2 <- 0
73 -
         sav <- list(beta = est, het = c(k = k, QE = Q, I2 = I2, H2 = H2, tau2 = tau2))
75 +
         sav <- list(beta = est, k = k, QE = Q, I2 = I2, H2 = H2, tau2 = tau2)
74 76
75 77
      } else {
76 78
77 -
         res <- try(suppressWarnings(rma.uni(obj$yi, obj$vi, weights=obj$weights, mods=obj$X, intercept=FALSE, method=obj$method, weighted=obj$weighted, test=obj$test, level=obj$level, control=obj$control, tau2=ifelse(obj$tau2.fix, obj$tau2, NA), subset=val, skipr2=TRUE, outlist="minimal")), silent=TRUE)
78 -
79 -
         if (inherits(res, "try-error") || any(res$coef.na)) {
80 -
            sav <- list(beta = matrix(NA, nrow=nrow(obj$beta), ncol=1), het = rep(NA, 5))
81 -
         } else {
82 -
            sav <- list(beta = res$beta, het = c(res$k, res$QE, res$I2, res$H2, res$tau2))
83 -
         }
79 +
         sav <- try(suppressWarnings(rma.uni(obj$yi, obj$vi, weights=obj$weights, mods=obj$X, intercept=FALSE,
80 +
                                             method=obj$method, weighted=obj$weighted, test=obj$test, level=obj$level,
81 +
                                             control=obj$control, tau2=ifelse(obj$tau2.fix, obj$tau2, NA),
82 +
                                             subset=val, skipr2=TRUE, outlist=outlist)), silent=TRUE)
84 83
85 84
      }
86 85
@@ -123,7 +122,10 @@
Loading
123 122
      if (comp == "phi")
124 123
         phi.arg[phi.pos] <- val
125 124
126 -
      res <- try(suppressWarnings(rma.mv(obj$yi, V=obj$V, W=obj$W, mods=obj$X, random=obj$random, struct=obj$struct, intercept=FALSE, data=obj$mf.r, method=obj$method, test=obj$test, level=obj$level, R=obj$R, Rscale=obj$Rscale, sigma2=sigma2.arg, tau2=tau2.arg, rho=rho.arg, gamma2=gamma2.arg, phi=phi.arg, sparse=obj$sparse, dist=obj$dist, control=obj$control, outlist="minimal")), silent=TRUE)
125 +
      res <- try(suppressWarnings(rma.mv(obj$yi, V=obj$V, W=obj$W, mods=obj$X, random=obj$random, struct=obj$struct, intercept=FALSE,
126 +
                                         data=obj$mf.r, method=obj$method, test=obj$test, level=obj$level, R=obj$R, Rscale=obj$Rscale,
127 +
                                         sigma2=sigma2.arg, tau2=tau2.arg, rho=rho.arg, gamma2=gamma2.arg, phi=phi.arg, sparse=obj$sparse,
128 +
                                         dist=obj$dist, control=obj$control, outlist="minimal")), silent=TRUE)
127 129
128 130
   }
129 131
@@ -161,7 +163,7 @@
Loading
161 163
162 164
}
163 165
164 -
.profile.rma.mh <- function(val, obj, parallel=FALSE, subset=FALSE) {
166 +
.profile.rma.mh <- function(val, obj, parallel=FALSE, subset=FALSE, outlist=NULL) {
165 167
166 168
   if (parallel == "snow")
167 169
      library(metafor)
@@ -171,15 +173,13 @@
Loading
171 173
      ### for subset, fit model to subset as specified by 'val'
172 174
173 175
      if (is.element(obj$measure, c("RR","OR","RD"))) {
174 -
         res <- try(suppressWarnings(rma.mh(ai=obj$ai, bi=obj$bi, ci=obj$ci, di=obj$di, measure=obj$measure, add=obj$add, to=obj$to, drop00=obj$drop00, correct=obj$correct, subset=val, outlist="minimal")), silent=TRUE)
176 +
         sav <- try(suppressWarnings(rma.mh(ai=obj$ai, bi=obj$bi, ci=obj$ci, di=obj$di, measure=obj$measure,
177 +
                                            add=obj$add, to=obj$to, drop00=obj$drop00, correct=obj$correct,
178 +
                                            subset=val, outlist=outlist)), silent=TRUE)
175 179
      } else {
176 -
         res <- try(suppressWarnings(rma.mh(x1i=obj$x1i, x2i=obj$x2i, t1i=obj$t1i, t2i=obj$t2i, measure=obj$measure, add=obj$add, to=obj$to, drop00=obj$drop00, correct=obj$correct, subset=val, outlist="minimal")), silent=TRUE)
177 -
      }
178 -
179 -
      if (inherits(res, "try-error")) {
180 -
         sav <- list(beta = NA, het = rep(NA, 5))
181 -
      } else {
182 -
         sav <- list(beta = res$beta, het = c(res$k, res$QE, res$I2, res$H2, res$tau2))
180 +
         sav <- try(suppressWarnings(rma.mh(x1i=obj$x1i, x2i=obj$x2i, t1i=obj$t1i, t2i=obj$t2i, measure=obj$measure,
181 +
                                            add=obj$add, to=obj$to, drop00=obj$drop00, correct=obj$correct,
182 +
                                            subset=val, outlist=outlist)), silent=TRUE)
183 183
      }
184 184
185 185
   }
@@ -188,7 +188,7 @@
Loading
188 188
189 189
}
190 190
191 -
.profile.rma.peto <- function(val, obj, parallel=FALSE, subset=FALSE) {
191 +
.profile.rma.peto <- function(val, obj, parallel=FALSE, subset=FALSE, outlist=NULL) {
192 192
193 193
   if (parallel == "snow")
194 194
      library(metafor)
@@ -197,13 +197,9 @@
Loading
197 197
198 198
      ### for subset, fit model to subset as specified by 'val'
199 199
200 -
      res <- try(suppressWarnings(rma.peto(ai=obj$ai, bi=obj$bi, ci=obj$ci, di=obj$di, add=obj$add, to=obj$to, drop00=obj$drop00, subset=val, outlist="minimal")), silent=TRUE)
201 -
202 -
      if (inherits(res, "try-error")) {
203 -
         sav <- list(beta = NA, het = rep(NA, 5))
204 -
      } else {
205 -
         sav <- list(beta = res$beta, het = c(res$k, res$QE, res$I2, res$H2, res$tau2))
206 -
      }
200 +
      sav <- try(suppressWarnings(rma.peto(ai=obj$ai, bi=obj$bi, ci=obj$ci, di=obj$di,
201 +
                                           add=obj$add, to=obj$to, drop00=obj$drop00,
202 +
                                           subset=val, outlist=outlist)), silent=TRUE)
207 203
208 204
   }
209 205
Files Coverage
R 70.78%
Project Totals (157 files) 70.78%
Untitled

No yaml found.

Create your codecov.yml to customize your Codecov experience

Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading