From 4619c697776c1033b19391c6aa0e2def3e3ace61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= <38475991+FBartos@users.noreply.github.com> Date: Wed, 20 Nov 2024 09:16:38 +0100 Subject: [PATCH] Release and Data Library Fixes (#257) --- DESCRIPTION | 2 + R/classicalmetaanalysiscommon.R | 72 +- ...ssicalmetaanalysismultilevelmultivariate.R | 30 +- R/data.R | 19 +- data/exampleMaire2019DistanceMatrix.rda | Bin 0 -> 1038 bytes ...icalMetaAnalysisMultilevelMultivariate.qml | 1 + renv.lock | 1511 +++++++++++------ 7 files changed, 1141 insertions(+), 494 deletions(-) create mode 100644 data/exampleMaire2019DistanceMatrix.rda diff --git a/DESCRIPTION b/DESCRIPTION index 1e1cedf3..89fb5b95 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,6 +33,7 @@ Imports: CompQuadForm, sp, dfoptim, + nleqslv, patchwork Remotes: jasp-stats/jaspBase, @@ -40,3 +41,4 @@ Remotes: Depends: R (>= 2.10) LazyData: true +RoxygenNote: 7.3.2 diff --git a/R/classicalmetaanalysiscommon.R b/R/classicalmetaanalysiscommon.R index eaa3c75c..d53b28ef 100644 --- a/R/classicalmetaanalysiscommon.R +++ b/R/classicalmetaanalysiscommon.R @@ -54,6 +54,7 @@ # model summary .maResidualHeterogeneityTable(jaspResults, dataset, options) + .maPooledEffectSizeTestTable(jaspResults, dataset, options) .maModeratorsTable(jaspResults, dataset, options) .maPooledEstimatesTable(jaspResults, dataset, options) @@ -364,6 +365,48 @@ return() } +.maPooledEffectSizeTestTable <- function(jaspResults, dataset, options) { + + modelSummaryContainer <- .maExtractModelSummaryContainer(jaspResults) + + if (!is.null(modelSummaryContainer[["pooledEffectSizeTest"]])) + return() + + fit <- .maExtractFit(jaspResults, options) + + pooledEffectSizeTest <- createJaspTable(gettext("Pooled Effect Size Test")) + pooledEffectSizeTest$position <- 1.1 + pooledEffectSizeTest$dependOn("confidenceIntervals") + modelSummaryContainer[["pooledEffectSizeTest"]] <- pooledEffectSizeTest + + pooledEffectSizeTest$addColumnInfo(name = "est", type = "number", title = gettext("Estimate")) + pooledEffectSizeTest$addColumnInfo(name = "se", type = "number", title = gettext("Standard Error")) + pooledEffectSizeTest$addColumnInfo(name = "stat", type = "number", title = if(.maIsMetaregressionFtest(options)) gettext("t") else gettext("z")) + if (.maIsMetaregressionFtest(options)) + pooledEffectSizeTest$addColumnInfo(name = "df", type = "number", title = gettext("df")) + pooledEffectSizeTest$addColumnInfo(name = "pval", type = "pvalue", title = gettext("p")) + + if (is.null(fit) || jaspBase::isTryError(fit)) + return() + + # do not perform transformation on the estimate (keep est and se on the same scale) + options[["transformEffectSize"]] <- "none" + predictedEffect <- .maComputePooledEffectPlot(fit, options) + + estimates <- data.frame( + est = predictedEffect[["est"]], + se = predictedEffect[["se"]], + stat = predictedEffect[["stat"]], + pval = predictedEffect[["pval"]] + ) + + if (.maIsMetaregressionFtest(options)) + estimates$df <- predictedEffect[["df"]] + + pooledEffectSizeTest$setData(estimates) + + return() +} .maModeratorsTable <- function(jaspResults, dataset, options) { modelSummaryContainer <- .maExtractModelSummaryContainer(jaspResults) @@ -1576,7 +1619,7 @@ if (.mammHasMultipleHeterogeneities(options, canAddOutput = TRUE) && options[["predictionIntervals"]]) predictedEffect <- cbind(predictedEffect, tauLevels) - return(predictedEffect <- apply(predictedEffect, 1, as.list)) + return(apply(predictedEffect, 1, as.list)) } .maComputePooledEffectPlot <- function(fit, options) { @@ -2489,7 +2532,12 @@ rmaInput <- c(rmaInput, .maExtendMetaforCallFromOptions(options)) ### fit the model - fit <- paste0("fit <- rma(\n\t", paste(names(rmaInput), "=", rmaInput, collapse = ",\n\t"), "\n)\n") + if (.maIsMultilevelMultivariate(options)) { + fit <- paste0("fit <- rma.mv(\n\t", paste(names(rmaInput), "=", rmaInput, collapse = ",\n\t"), "\n)\n") + } else { + fit <- paste0("fit <- rma(\n\t", paste(names(rmaInput), "=", rmaInput, collapse = ",\n\t"), "\n)\n") + } + # add clustering if specified if (options[["clustering"]] != "") { @@ -2819,14 +2867,22 @@ .maGetControlOptions <- function(options) { if (.maIsMetaregressionHeterogeneity(options)) { - out <- list( - optimizer = options[["optimizerMethod"]], - iter.max = if (options[["optimizerMaximumIterations"]]) options[["optimizerMaximumIterationsValue"]], - rel.tol = if (options[["optimizerConvergenceRelativeTolerance"]]) options[["optimizerConvergenceRelativeToleranceValue"]] - ) + if (options[["optimizerMethod"]] == "nlminb" && !options[["optimizerMaximumIterations"]] && !options[["optimizerConvergenceRelativeTolerance"]]) { + # allow an empty list for default settings --- this allows manual modification of the control argument through extra input + out <- list() + } else { + out <- list( + optimizer = options[["optimizerMethod"]], + iter.max = if (options[["optimizerMaximumIterations"]]) options[["optimizerMaximumIterationsValue"]], + rel.tol = if (options[["optimizerConvergenceRelativeTolerance"]]) options[["optimizerConvergenceRelativeToleranceValue"]] + ) + } } else { if (.maIsMultilevelMultivariate(options)) { - if (options[["optimizerMethod"]] == "nlminb") { + if (options[["optimizerMethod"]] == "nlminb" && !options[["optimizerMaximumEvaluations"]] && !options[["optimizerMaximumIterations"]] && !options[["optimizerConvergenceRelativeTolerance"]]) { + # allow an empty list for default settings --- this allows manual modification of the control argument through extra input + out <- list() + } else if (options[["optimizerMethod"]] == "nlminb") { out <- list( optimizer = options[["optimizerMethod"]], eval.max = if (options[["optimizerMaximumEvaluations"]]) options[["optimizerMaximumEvaluationsValue"]], diff --git a/R/classicalmetaanalysismultilevelmultivariate.R b/R/classicalmetaanalysismultilevelmultivariate.R index dbcc0f54..4f006dc1 100644 --- a/R/classicalmetaanalysismultilevelmultivariate.R +++ b/R/classicalmetaanalysismultilevelmultivariate.R @@ -181,7 +181,12 @@ ClassicalMetaAnalysisMultilevelMultivariate <- function(jaspResults, dataset = N if (distanceMatrixFileName != "" && tempValueInner != "") { # try regular csv loading - distanceMatrix <- try(as.matrix(read.csv(file = distanceMatrixFileName, row.names = 1))) + if (tolower(gsub(" ", "", distanceMatrixFileName)) == "examplemaire2019distancematrix") { + # allow to load example data for data library + distanceMatrix <- .mammGetExampleMaire2019DistanceMatrix() + }else{ + distanceMatrix <- try(as.matrix(read.csv(file = distanceMatrixFileName, row.names = 1))) + } if (inherits(distanceMatrix, "try-error")) .quitAnalysis(gettextf("Error reading the distance matrix file: %1$s", distanceMatrix)) @@ -340,13 +345,14 @@ ClassicalMetaAnalysisMultilevelMultivariate <- function(jaspResults, dataset = N } .mammRandomEstimatesTable <- function(jaspResults, dataset, options) { - if (!is.null(jaspResults[["randomEstimatesContainer"]])) - return() - - randomEstimatesContainer <- createJaspContainer(title = gettext("Random Effects / Model Stucture Summary")) - randomEstimatesContainer$dependOn(.maDependencies) - randomEstimatesContainer$position <- 2 - jaspResults[["randomEstimatesContainer"]] <- randomEstimatesContainer + if (!is.null(jaspResults[["randomEstimatesContainer"]])) { + randomEstimatesContainer <- jaspResults[["randomEstimatesContainer"]] + } else { + randomEstimatesContainer <- createJaspContainer(title = gettext("Random Effects / Model Stucture Summary")) + randomEstimatesContainer$dependOn(.maDependencies) + randomEstimatesContainer$position <- 2 + jaspResults[["randomEstimatesContainer"]] <- randomEstimatesContainer + } fit <- .maExtractFit(jaspResults, options) @@ -355,7 +361,7 @@ ClassicalMetaAnalysisMultilevelMultivariate <- function(jaspResults, dataset = N return() ### create table for nested random effects - if (fit[["withS"]]) { + if (fit[["withS"]] && is.null(randomEstimatesContainer[["containerS"]])) { containerS <- createJaspContainer(title = gettext("Simple / Nested Summary")) containerS$position <- 1 @@ -390,7 +396,7 @@ ClassicalMetaAnalysisMultilevelMultivariate <- function(jaspResults, dataset = N } ### create summary for the remaining types - if (fit[["withG"]]) { + if (fit[["withG"]] && is.null(randomEstimatesContainer[["containerG"]])) { # create jasp containers containerG <- createJaspContainer(title = .mammGetRandomEstimatesTitle(fit[["struct"]][1])) @@ -400,7 +406,7 @@ ClassicalMetaAnalysisMultilevelMultivariate <- function(jaspResults, dataset = N } - if (fit[["withH"]]) { + if (fit[["withH"]] && is.null(randomEstimatesContainer[["containerH"]])) { containerH <- createJaspContainer(title = .mammGetRandomEstimatesTitle(fit[["struct"]][2])) containerH$position <- 3 @@ -410,7 +416,7 @@ ClassicalMetaAnalysisMultilevelMultivariate <- function(jaspResults, dataset = N } ### create random structure inclusion summary - if (options[["randomEffectsTestInclusion"]]) { + if (options[["randomEffectsTestInclusion"]] && is.null(randomEstimatesContainer[["tableInclusion"]])) { tableInclusion <- createJaspTable(title = gettext("Inclusion Test")) tableInclusion$position <- 4 diff --git a/R/data.R b/R/data.R index b3b99ba1..e4b22814 100644 --- a/R/data.R +++ b/R/data.R @@ -5,7 +5,24 @@ #' (vignette at https://cran.r-project.org/web/packages/RoBMA/vignettes/Tutorial.html) #' #' -#' @format An RDS file +#' @format An RData file #' #' @return An object of class RoBMA. "exampleRobmaLui2015" + + +#' @title Maire 2019 distance matrix +#' +#' @description Distance matrix from Maire et al. (2019) for the example +#' multilevel/multivariate meta-analysis. See dat.maire2019 in the metadat +#' package. +#' +#' @format An Rdata file +#' +#' @return A distance matrix +"exampleMaire2019DistanceMatrix" + +.mammGetExampleMaire2019DistanceMatrix <- function() { + data("exampleMaire2019DistanceMatrix") + return(exampleMaire2019DistanceMatrix) +} diff --git a/data/exampleMaire2019DistanceMatrix.rda b/data/exampleMaire2019DistanceMatrix.rda new file mode 100644 index 0000000000000000000000000000000000000000..4e61cfd5c1d289ec4d594a798392141103385d39 GIT binary patch literal 1038 zcmV+p1o8VqT4*^jL0KkKSsGcG?Engt|NsC0_?t-df90-n+EDNJ-%tJC=;7kwAOHX$ z3tHXCWC2hE@e~8V00x>uCZ?yUw8>J1ox8fmAb(WmJRC#ZU8CXCd2M%48% zCJ~6!AZj!q6GCJF8UO$Q000dD&@=!5000d%1Q-HgFeVcTrU{6^697hrOafp400dwr z000nR3539yOeUBnBLGYR8W}JNfB*myfS3RP3W_B)Hi-k&dWL`i0B8UJ0B8UJ0009) zplP9zkm~HAmsot+*J;C`1Q6^%Y#clX2RfA636LCu;$FQmg6cT{48b(@X3j+GFBdt; z9r}nsYDFmwG#~_m3jhpd2GoFKGWB4#A=W!!>%Ji&MC;svANF!tAQnh=Mlj%K3h=O=B1pbO$tZ{haqg5rhyy|d0A*aL zdPJ50Oryb=%Z8K0{lg`ZoshJxmYE48f#0=JfOX0sz#t_#OOur)gQP&3Pz?|EFvX%B zM^92kDiUd1Sh7RvP!SLgnL&6*EX^apKygI;5Q9wh&DD)8N&g9${yCOjt9CgiB!z=Mc@8Ok)@=xWd_JMliSY$l0()n-^mxw-*?fgtkdDShZpjOJtHJ zFl9=yRZ56WES8Zik_l-NTLrN#LeUn4wnS`g7;q9jw46H8RA|v7Ye^;%N-0Vzl}xH> zM#^NT`^3SO8Y+C%GU5N2%Bgl+*5h%y-EOO6iX&SksI-K(QQsae6N z9nR&&NzREl2?nj~kW_