From 09384c5a6257686ab8303c7a70b61d2cbe9618a7 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 26 May 2021 13:24:18 +0200 Subject: [PATCH 01/38] fixes: https://github.com/jasp-stats/jasp-test-release/issues/1208 and fixes: https://github.com/jasp-stats/jasp-test-release/issues/1207 --- R/MixedModelsCommon.R | 11 +++++++++-- inst/qml/common/MixedModelsPlots.qml | 12 ++++++------ 2 files changed, 15 insertions(+), 8 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 12f058ba..726b7c77 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -1187,8 +1187,15 @@ "theme_bw" = ggplot2::theme_bw() + ggplot2::theme(legend.position = "bottom"), "theme_light" = ggplot2::theme_light() + ggplot2::theme(legend.position = "bottom"), "theme_minimal" = ggplot2::theme_minimal() + ggplot2::theme(legend.position = "bottom"), - "theme_apa" = jaspGraphs::themeApaRaw() + ggplot2::theme(legend.position = "bottom"), - "theme_pubr" = jaspGraphs::themePubrRaw() + "theme_pubr" = jaspGraphs::themePubrRaw(legend = options$plotLegendPosition), + "theme_apa" = jaspGraphs::themeApaRaw(legend.pos = switch( + options$plotLegendPosition, + "none" = "none", + "botom" = "bottommiddle", + "right" = "bottomright", + "top" = "topmiddle", + "left" = "bottomleft" + )) ) p <- p + ggplot2::theme( diff --git a/inst/qml/common/MixedModelsPlots.qml b/inst/qml/common/MixedModelsPlots.qml index bec92c5b..cd63555b 100644 --- a/inst/qml/common/MixedModelsPlots.qml +++ b/inst/qml/common/MixedModelsPlots.qml @@ -216,12 +216,12 @@ Section label: qsTr("Theme") values: [ - { label: "JASP", value: "JASP"}, - { label: qsTr("Black White"), value: "theme_bw"}, - { label: qsTr("Light"), value: "theme_light"}, - { label: qsTr("Minimal"), value: "theme_minimal"}, - { label: "APA", value: "jtools::theme_apa"}, - { label: "pubr", value: "ggpubr::theme_pubr"} + { label: "JASP", value: "JASP"}, + { label: qsTr("White background"), value: "theme_bw"}, + { label: qsTr("Light"), value: "theme_light"}, + { label: qsTr("Minimal") , value: "theme_minimal"}, + { label: "APA", value: "theme_apa"}, + { label: "pubr", value: "theme_pubr"} ] } From dbdacebffa8194f6344607a7cb04fdf59a8eff1f Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 26 May 2021 13:31:41 +0200 Subject: [PATCH 02/38] fixes: https://github.com/jasp-stats/jasp-test-release/issues/1210 --- inst/qml/common/MixedModelsPlots.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/common/MixedModelsPlots.qml b/inst/qml/common/MixedModelsPlots.qml index cd63555b..c1e6a53e 100644 --- a/inst/qml/common/MixedModelsPlots.qml +++ b/inst/qml/common/MixedModelsPlots.qml @@ -242,7 +242,7 @@ Section DropDown { name: "plotsBackgroundColor" - label: qsTr("Color background data") + label: qsTr("Border color") enabled:plotsGeom.currentValue != "geom_jitter" values: [ From a5d785e93f74a0c36e402e3e238c2e3e68c2c60d Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Thu, 27 May 2021 13:40:00 +0200 Subject: [PATCH 03/38] fixes: https://forum.cogsci.nl/discussion/comment/23440#Comment_23440 --- R/MixedModelsCommon.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 726b7c77..fa848f76 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -652,13 +652,13 @@ added_re <- jaspResults[["mmModel"]]$object$added_re for (i in seq_along(removed_me)) - ANOVAsummary$addFootnote(.mmMessageOmmitedTerms1(removed_me[[i]], names(removed_me)[i]), symbol = gettext("Warning:")) + ANOVAsummary$addFootnote(.mmMessageOmmitedTerms1(removed_me[[i]], names(removed_me)[i]), symbol = gettext("Note:")) for (i in seq_along(removed_te)) - ANOVAsummary$addFootnote(.mmMessageOmmitedTerms2(removed_te[[i]], names(removed_te)[i]), symbol = gettext("Warning:")) + ANOVAsummary$addFootnote(.mmMessageOmmitedTerms2(removed_te[[i]], names(removed_te)[i]), symbol = gettext("Note:")) for (i in seq_along(added_re)) - ANOVAsummary$addFootnote(.mmMessageAddedTerms(added_re[[i]], names(added_re)[i]), symbol = gettext("Warning:")) + ANOVAsummary$addFootnote(.mmMessageAddedTerms(added_re[[i]], names(added_re)[i]), symbol = gettext("Note:")) @@ -2700,18 +2700,18 @@ if (length(removed_me) > 0) { for (j in 1:length(removed_me)) { temp_table$addFootnote(.mmMessageOmmitedTerms1(removed_me[[j]], names(removed_me)[j]), - symbol = gettext("Warning:")) + symbol = gettext("Note:")) } } if (length(removed_te) > 0) { for (j in 1:length(removed_te)) { temp_table$addFootnote(.mmMessageOmmitedTerms2(removed_te[[j]], names(removed_te)[j]), - symbol = gettext("Warning:")) + symbol = gettext("Note:")) } } if (length(added_re) > 0) { for (i in 1:length(added_re)) { - temp_table$addFootnote(.mmMessageAddedTerms(added_re[[i]], names(added_re)[i]), symbol = gettext("Warning:")) + temp_table$addFootnote(.mmMessageAddedTerms(added_re[[i]], names(added_re)[i]), symbol = gettext("Note:")) } } if (jaspResults[["n_missing"]]$object != 0) { From ff6fdfa3f64997e0d6fd6ecf7a7bab9e7a094764 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 1 Jun 2021 10:02:42 +0200 Subject: [PATCH 04/38] fixes: https://github.com/jasp-stats/jasp-test-release/issues/1260 by reducing the scaling rate --- R/MixedModelsCommon.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index fa848f76..2d73ce7d 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -1002,7 +1002,7 @@ # automatic size specification will somewhat work unless there is more than 2 variables in panel height <- 350 - width <- 450 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, .v(x)])) / 2)) + width <- 150 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, .v(x)])) / 2)) if (length(options$plotsPanel) > 0) { width <- @@ -1016,7 +1016,8 @@ } else if (options$plotLegendPosition %in% c("left", "right")) { width <- width + 100 } - + width <- width + 150 + plots <- createJaspPlot(title = gettext("Plot"), width = width, height = height) plots$position <- 5 From 5afcbd2af265c559ec8e07b6e5a501af18fa330a Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 1 Jun 2021 10:18:59 +0200 Subject: [PATCH 05/38] fixes: https://github.com/jasp-stats/jasp-test-release/issues/1326 I can't believe that I figured this QML thingy on my own :) --- inst/qml/MixedModelsGLMM.qml | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/inst/qml/MixedModelsGLMM.qml b/inst/qml/MixedModelsGLMM.qml index 062a58e8..677f1c9e 100644 --- a/inst/qml/MixedModelsGLMM.qml +++ b/inst/qml/MixedModelsGLMM.qml @@ -92,12 +92,23 @@ Form { property var familyMap: { "binomial": ["logit", "probit", "cauchit", "cloglog", "log"], + "binomial_agg": ["logit", "probit", "cauchit", "cloglog", "log"], "gaussian": ["identity", "log", "inverse"], "Gamma": ["identity", "log", "inverse"], "inverse.gaussian": ["identity", "log", "inverse"], "poisson": ["identity", "log", "sqrt"] } + property var familyDefault: + { + "binomial": "logit", + "binomial_agg": "logit", + "gaussian": "identity", + "Gamma": "log", + "inverse.gaussian": "log", + "poisson": "log" + } + onCurrentValueChanged: { if (!familyMap[currentValue].includes(link.value)) @@ -124,7 +135,7 @@ Form { label: qsTr("Logit") value: "logit" visible: family.familyMap[family.currentValue].includes(value) - checked: true + checked: family.familyDefault[family.currentValue] == "logit" } RadioButton @@ -132,6 +143,7 @@ Form { label: qsTr("Probit") value: "probit" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "probit" } RadioButton @@ -139,6 +151,7 @@ Form { label: qsTr("Cauchit") value: "cauchit" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "cauchit" } RadioButton @@ -146,6 +159,7 @@ Form { label: qsTr("Complementary LogLog") value: "cloglog" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "cloglog" } RadioButton @@ -153,6 +167,7 @@ Form { label: qsTr("Identity") value: "identity" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "identity" } RadioButton @@ -160,6 +175,7 @@ Form { label: qsTr("Log") value: "log" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "log" } RadioButton @@ -167,6 +183,7 @@ Form { label: qsTr("Sqrt") value: "sqrt" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "sqrt" } RadioButton @@ -174,6 +191,7 @@ Form { label: qsTr("Inverse") value: "inverse" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "inverse" } } } From 5b4593ac267e479457707e074f613b6379c82cce Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 1 Jun 2021 13:45:18 +0200 Subject: [PATCH 06/38] adding fancy interaction symbols --- R/MixedModelsCommon.R | 78 +++++++++---------------------------------- 1 file changed, 16 insertions(+), 62 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 2d73ce7d..2a738f88 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -594,10 +594,7 @@ if (rownames(model$anova_table)[i] == "(Intercept)") { effect_name <- gettext("Intercept") } else{ - effect_name <- - paste(.unv(unlist(strsplit( - rownames(model$anova_table)[i], ":" - ))), collapse = " * ") + effect_name <- jaspBase::gsubInteractionSymbol(rownames(model$anova_table)[i]) } temp_row <- list(effect = effect_name, @@ -798,12 +795,7 @@ if (names(temp_StdDev)[i] == "(Intercept)") { var_name <- gettext("Intercept") } else{ - var_name <- - paste(.unv(unlist(strsplit( - names(temp_StdDev)[i], ":" - ))), collapse = ":") - var_name <- - .mmVariableNames(var_name, options$fixedVariables) + var_name <- .mmVariableNames(names(temp_StdDev)[i], options$fixedVariables) } temp_row <- list( @@ -834,12 +826,7 @@ if (rownames(temp_Corr)[i] == "(Intercept)") { var_name <- gettext("Intercept") } else{ - var_name <- - paste(.unv(unlist(strsplit( - rownames(temp_Corr)[i], ":" - ))), collapse = ":") - var_name <- - .mmVariableNames(var_name, options$fixedVariables) + var_name <- .mmVariableNames(rownames(temp_Corr)[i], options$fixedVariables) } REcor$addColumnInfo(name = paste0("v", i), title = var_name, @@ -851,12 +838,7 @@ if (rownames(temp_Corr)[i] == "(Intercept)") { var_name <- gettext("Intercept") } else{ - var_name <- - paste(.unv(unlist(strsplit( - rownames(temp_Corr)[i], ":" - ))), collapse = ":") - var_name <- - .mmVariableNames(var_name, options$fixedVariables) + var_name <- .mmVariableNames(rownames(temp_Corr)[i], options$fixedVariables) } temp_row <- list(variable = var_name) @@ -947,12 +929,7 @@ if (rownames(FE_coef)[i] == "(Intercept)") { effect_name <- gettext("Intercept") } else{ - effect_name <- - paste(.unv(unlist(strsplit( - rownames(FE_coef)[i], ":" - ))), collapse = ":") - effect_name <- - .mmVariableNames(effect_name, options$fixedVariables) + effect_name <- .mmVariableNames(rownames(FE_coef)[i], options$fixedVariables) } if (type == "LMM") { @@ -2340,12 +2317,7 @@ if (names(temp_StdDev)[i] == "(Intercept)") { var_name <- gettext("Intercept") } else{ - var_name <- - paste(.unv(unlist(strsplit( - names(temp_StdDev)[i], ":" - ))), collapse = ":") - var_name <- - .mmVariableNames(var_name, options$fixedVariables) + var_name <- .mmVariableNames(names(temp_StdDev)[i], options$fixedVariables) } temp_row <- list( @@ -2376,12 +2348,7 @@ if (rownames(temp_Corr)[i] == "(Intercept)") { var_name <- gettext("Intercept") } else{ - var_name <- - paste(.unv(unlist(strsplit( - rownames(temp_Corr)[i], ":" - ))), collapse = ":") - var_name <- - .mmVariableNames(var_name, options$fixedVariables) + var_name <- .mmVariableNames(rownames(temp_Corr)[i], options$fixedVariables) } REcor$addColumnInfo(name = paste0("v", i), title = var_name, @@ -2393,12 +2360,7 @@ if (rownames(temp_Corr)[i] == "(Intercept)") { var_name <- gettext("Intercept") } else{ - var_name <- - paste(.unv(unlist(strsplit( - rownames(temp_Corr)[i], ":" - ))), collapse = ":") - var_name <- - .mmVariableNames(var_name, options$fixedVariables) + var_name <- .mmVariableNames(rownames(temp_Corr)[i], options$fixedVariables) } temp_row <- list(variable = var_name) @@ -2495,12 +2457,7 @@ if (rownames(fe_summary)[i] == "(Intercept)") { effect_name <- "Intercept" } else{ - effect_name <- - paste(.unv(unlist(strsplit( - rownames(fe_summary)[i], ":" - ))), collapse = ":") - effect_name <- - .mmVariableNames(effect_name, options$fixedVariables) + effect_name <- .mmVariableNames(rownames(fe_summary)[i], options$fixedVariables) } temp_row <- list( @@ -2559,10 +2516,7 @@ var_name <- gettext("Intercept") table_name <- var_name } else{ - var_name <- - paste(.unv(unlist(strsplit( - names(model_summary)[i], ":" - ))), collapse = "*") + var_name <- jaspBase::gsubInteractionSymbol(names(model_summary)[i]) if (options$show == "deviation") { table_name <- gettextf("%s (differences from intercept)",var_name) @@ -2644,15 +2598,15 @@ ) if (var_name != "Intercept" && nrow(temp_summary) > 1) { - var_name <- + var_name <- paste(.unv(unlist(strsplit( as.character(temp_summary$Variable[j]), "," - ))), collapse = ":") + ))), collapse = jaspBase::interactionSymbol) var_name <- gsub(" ", "", var_name, fixed = TRUE) - if (grepl(":", names(model_summary)[i], fixed = T)) { + if (grepl(jaspBase::interactionSymbol, names(model_summary)[i], fixed = T)) { for (n in unlist(strsplit(.unv(names( model_summary - )[i]), ":"))) { + )[i]), jaspBase::interactionSymbol))) { var_name <- gsub(n, "", var_name, fixed = TRUE) } } else{ @@ -2850,7 +2804,7 @@ ) } } - var_name <- gsub(":", ") * ", var_name, fixed = TRUE) + var_name <- gsub(":", paste0(")", jaspBase::interactionSymbol), var_name, fixed = TRUE) var_name <- paste0(var_name, ")") var_name <- gsub(" ()", "", var_name, fixed = TRUE) return(var_name) @@ -2865,7 +2819,7 @@ for(cft in coefs_trend){ if(cft %in% strsplit(par, ":")[[1]] && !grepl(.unv(cft), coefs_name)){ - coefs_name <- paste0(coefs_name, ":", .unv(cft)) + coefs_name <- paste0(coefs_name, jaspBase::interactionSymbol, .unv(cft)) } } From ded218c24bdf61a0a59c7b371de258e56a83becd Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 1 Jun 2021 13:53:19 +0200 Subject: [PATCH 07/38] fixes: https://github.com/jasp-stats/jasp-test-release/issues/1327 --- R/MixedModelsCommon.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 2a738f88..f2d94b82 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -1146,6 +1146,11 @@ plots$setError(p$message) return() } + + if (options$plotsGeom == "geom_violin" && (length(options$plotsAgregatedOver) == 1 && length(unique(dataset[, .v(options$plotsAgregatedOver)])) < 3)) { + plots$setError(gettext("Violin geom requires that the random effects grouping factors has at least 3 levels.")) + return() + } # fix the axis p <- .mmFixPlotAxis(p) From 47b910dade4767556ea1496b306bd3b7f81070df Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 1 Jun 2021 15:27:59 +0200 Subject: [PATCH 08/38] should fix: https://github.com/jasp-stats/jasp-test-release/issues/1329 --- R/MixedModelsCommon.R | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index f2d94b82..6ad7ef82 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -2125,7 +2125,7 @@ model_formula <- .mmModelFormula(options, dataset) if (type == "BLMM") { - model <- stanova::stanova( + model <- tryCatch(stanova::stanova( formula = as.formula(model_formula$model_formula), check_contrasts = "contr.bayes", data = dataset, @@ -2136,7 +2136,7 @@ control = list(max_treedepth = options$max_treedepth), seed = .getSeedJASP(options), model_fun = "lmer" - ) + ), error = function(e) e ) } else if (type == "BGLMM") { # needs to be evaluated in the global environment @@ -2154,7 +2154,7 @@ if (options$family == "binomial_agg") { glmm_weight <<- dataset[, .v(options$dependentVariableAggregation)] - model <- stanova::stanova( + model <- tryCatch(stanova::stanova( formula = as.formula(model_formula$model_formula), check_contrasts = "contr.bayes", data = dataset, @@ -2167,10 +2167,10 @@ family = eval(call("binomial", glmm_link)), seed = .getSeedJASP(options), model_fun = "glmer" - ) + ), error = function(e) e ) } else{ - model <- stanova::stanova( + model <- tryCatch(stanova::stanova( formula = as.formula(model_formula$model_formula), check_contrasts = "contr.bayes", data = dataset, @@ -2182,12 +2182,18 @@ family = glmm_family, seed = .getSeedJASP(options), model_fun = "glmer" - ) + ), error = function(e) e ) } } + if (inherits(model, "error")) { + if (model$message == "Dropping columns failed to produce full column rank design matrix") + .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. The most likely reason for this issue is a factor / combination of factors leading to more levels than are estimable.")) + else + .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model$message)) + } object <- list( model = model, From 8a328616a7baffa7e9e56c7e85c0e9981f387f95 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 1 Jun 2021 15:37:12 +0200 Subject: [PATCH 09/38] fixes: https://github.com/jasp-stats/jasp-test-release/issues/1331 --- R/MixedModelsCommon.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 6ad7ef82..92e0a0a8 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -975,6 +975,10 @@ ggplot2::scale_x_discrete(breaks = xTicks) } .mmPlot <- function(jaspResults, dataset, options, type = "LMM") { + + if (!is.null(jaspResults[["plots"]])) + return() + model <- jaspResults[["mmModel"]]$object$model # automatic size specification will somewhat work unless there is more than 2 variables in panel From a1fab86b195ced3dc60d7a539f6a90561f200d42 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 1 Jun 2021 15:48:34 +0200 Subject: [PATCH 10/38] fixes: https://github.com/jasp-stats/jasp-test-release/issues/1330 --- inst/qml/common/MixedModelsBOptions.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/common/MixedModelsBOptions.qml b/inst/qml/common/MixedModelsBOptions.qml index 7d254387..72b9c493 100644 --- a/inst/qml/common/MixedModelsBOptions.qml +++ b/inst/qml/common/MixedModelsBOptions.qml @@ -42,7 +42,7 @@ Section name: "iteration" label: qsTr("Iterations") defaultValue: 4000 - min: parseInt(warmup.value) + 2 + min: parseInt(warmup.value) + 100 } IntegerField From 382f9e5d7fbbcb26c06babc6313b57f37b4ad3e3 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 1 Jun 2021 16:33:10 +0200 Subject: [PATCH 11/38] fixing unit tests (hopefully) --- tests/testthat/test-mixedmodelsglmm.R | 672 +++++++++++++------------- 1 file changed, 337 insertions(+), 335 deletions(-) diff --git a/tests/testthat/test-mixedmodelsglmm.R b/tests/testthat/test-mixedmodelsglmm.R index b39bedf9..7658510d 100644 --- a/tests/testthat/test-mixedmodelsglmm.R +++ b/tests/testthat/test-mixedmodelsglmm.R @@ -6,19 +6,19 @@ context("Generalized Linear Mixed Models") skip_on_os("mac") # problems with precision outside of windows skip_on_os("linux") # problems with precision outside of windows options <- analysisOptions("MixedModelsGLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("1", "2", "3", "4", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", "6"), name = "cA", values = c("1", "2", "1", "2", "1", "2" - )), list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", - "6"), name = "y_beta", values = c("-1", "-1", "0", "0", "1", - "1")), list(isContrast = TRUE, levels = c("1", "2", "3", "4", - "5", "6"), name = "Contrast 1", values = c("0", "1", "-1", "0", - "0", "0")), list(isContrast = TRUE, levels = c("1", "2", "3", - "4", "5", "6"), name = "Contrast 2", values = c("1", "-1", "0", + )), list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", + "6"), name = "y_beta", values = c("-1", "-1", "0", "0", "1", + "1")), list(isContrast = TRUE, levels = c("1", "2", "3", "4", + "5", "6"), name = "Contrast 1", values = c("0", "1", "-1", "0", + "0", "0")), list(isContrast = TRUE, levels = c("1", "2", "3", + "4", "5", "6"), name = "Contrast 2", values = c("1", "-1", "0", "0", "0", "0"))) options$bootstrap_samples <- 500 options$dependentVariable <- "JaspColumn_.5._Encoded" options$fitStats <- TRUE - options$fixedEffects <- list(list(components = "JaspColumn_.1._Encoded"), list(components = "JaspColumn_.7._Encoded"), + options$fixedEffects <- list(list(components = "JaspColumn_.1._Encoded"), list(components = "JaspColumn_.7._Encoded"), list(components = c("JaspColumn_.1._Encoded", "JaspColumn_.7._Encoded" ))) options$fixedVariables <- c("JaspColumn_.1._Encoded", "JaspColumn_.7._Encoded") @@ -60,238 +60,239 @@ context("Generalized Linear Mixed Models") options$test_intercept <- FALSE options$trendsCompare <- TRUE options$trendsContrast <- TRUE - options$trendsContrasts <- list(list(isContrast = FALSE, levels = c("1", "2"), name = "cA", - values = c("1", "2")), list(isContrast = TRUE, levels = c("1", + options$trendsContrasts <- list(list(isContrast = FALSE, levels = c("1", "2"), name = "cA", + values = c("1", "2")), list(isContrast = TRUE, levels = c("1", "2"), name = "Contrast 1", values = c("-1", "1"))) options$trendsTrend <- list(list(variable = "JaspColumn_.7._Encoded")) options$trendsVariables <- list(list(variable = "JaspColumn_.1._Encoded")) options$type <- "3" + options$link <- "logit" set.seed(1) - dataset <- structure(list(JaspColumn_.0._Encoded = c(1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L), JaspColumn_.1._Encoded = c(1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), JaspColumn_.2._Encoded = c(1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), JaspColumn_.3._Encoded = c(1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, - 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, - 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, - 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L), JaspColumn_.4._Encoded = c(-0.653989689, - 0.597847379, 0.53124944, -0.919283666, 1.549214002, -0.964337181, - 0.758624407, -0.633353539, 0.093434858, 0.081944247, 1.251310302, - 1.399815493, -0.942716455, -0.495601118, 0.917930091, 0.344838602, - -1.226474961, -1.405114801, 0.686194991, 0.017571144, -0.337816215, - 0.384985065, 1.430491376, 1.866825203, 0.752814251, 1.31909783, - 0.447452196, -1.346206879, 0.479402493, -0.848513454, 0.850545592, - -3.037579176, 0.545769791, -1.182557897, -0.128004891, 1.11267647, - 0.616535768, -0.669227302, 0.076114909, 0.816454623, 0.422781459, - -0.094856662, -0.374461304, 0.691431944, -1.528712893, 1.05380469, - -0.545337415, -0.026770503, -2.189233221, -0.616004017, 1.150339483, - -0.133211268, 0.252652295, 1.399980471, -0.513151105, 1.117392323, - -0.610869543, 0.331300534, -0.992903801, -0.895568118, 0.623585941, - 1.05882918, -1.58627026, 0.947877674, 2.033833295, 0.179956552, - 1.573438425, -1.694333909, 1.079726669, 1.508240792, 0.90600351, - -0.290763172, -0.496024515, 1.946237186, -0.893948592, 0.830769682, - 0.440062416, -0.57837005, 1.790515054, 0.137924932, 0.055424081, - 0.547806104, -0.748529992, 1.71335853, 1.808028443, 0.017313744, - 0.988861738, -1.43975293, 0.338108584, -0.365015598, 1.86933575, - 1.699421632, 0.308476418, 1.556020356, -0.952816041, 1.874185874, - 1.104225239, -1.318714635, 1.431532182, 0.756206118, 1.892566353, - -0.933657521, 1.277498726, 0.407372551, 1.021542579, 0.74476069, - 0.571588797, -0.762850791, -2.287992665, -0.596915582, 2.920177191, - -0.853565433, -0.771818751, 0.492465518, -0.455610621, 2.667902824, - 1.953870427, 0.14233637, -1.188999386, -0.185194402, 2.751932451, - 0.1714291, 0.495442662, 0.007490023, -1.381723611, -0.360288418, - 1.228175718, 1.270669023, -0.317481349, -1.121300988, 0.248833912, - -0.936079972, -0.019929997, -0.752375481, 1.745747293, 0.005492604, - 0.407922866, 0.061474844, 0.69299688, 0.597159811, 2.949895836, - -0.24811046, 0.034494308, -0.78621074, 0.614844377, 1.095323201, - 0.672793259, 0.057114702, 0.072950494, 0.346984663, -0.452874548, - -0.114694466, 0.536167379, 2.672375374, 0.618138653, 2.749195306, - 2.199564155, -1.821705402, 0.662389551, -0.086448818, 2.350030519, - 1.42969294, -0.082903446, 1.526255915, -0.77415644, 1.646198365, - 0.550819959, -1.912875322, -0.170004512, -0.153966373, 3.216473665, - -2.384187974, 0.730941972, -0.065087507, 1.330153598, 1.27618167, - 1.956183459, 0.436215424, -1.232486611, -0.455381093, 0.83128861, - 0.152153259, -0.45491991, -0.256058166, -0.193076508, -0.334064589, - 0.215860632, -1.749746886, 0.358765965, 0.211328495, -0.112055855, - 0.945593904, 0.532860661, 0.01631963, -0.695297425, -0.182978288, - 1.940983578, -1.052570114, 1.265312559, -0.21744826, 2.122842478, - 1.291844321, -0.694666126, 2.001880096, 0.977066134, 1.383692522, - -0.085431624, -1.152918968, -1.621837649, 0.647353218, 1.079628054, - -0.220121984, -0.562039994, 2.441868908, 0.688842095, 0.572532136, - 1.049670153, -1.439036257, 0.673783789, 0.810812932, -0.557921732, - -0.055039468, 1.065618622, -0.653057442, -0.537812988, 0.818735764, - 0.874036767, -0.264722867, -1.083081897, 0.132684797, 1.282776406, - 0.980202012, 0.912757975, 0.395195197, -1.294487302, -0.149088612, - 1.042843997, -1.213788746, -1.842337004, -0.087241521, 1.759125287, - -0.65217472, -0.468828649, -1.128895132, 0.355130761, -1.13143679, - -0.231067871, -1.353450121, -1.710583197, 0.186715205, -0.543962675, - 0.292958499, -0.4283386, 2.670479768, 2.379591267, 1.278406268, - 2.298737024, -0.737706867, 1.468454399, 0.055981228, 0.149251786, - -0.332347905, -0.191862331, -0.012294677, 0.139243256, -1.123574851, - -0.034383926, -0.512343287, 0.812126437, 0.486944352, 0.595358492, - 1.224605923, 0.863959031, -1.789032311, 0.489475508, 2.019401428, - 2.492383813, 0.177655849, -0.587024392, 0.299497534, 1.602179556, - -1.502343948, -1.37596223, 0.74894869, 0.664588217, 1.321486377, - 1.888462109, -0.903168893, -3.201437624, -0.535609031, 0.554010178, - -0.547718747, 1.542488798, 1.851156869, 0.154379085, 0.617288371, - 1.273637679, -1.466949312, -0.150368723, -0.256217966), JaspColumn_.5._Encoded = c(1L, - 0L, 1L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, - 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, - 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, - 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 1L, - 1L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, - 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 0L, 0L, 1L, - 0L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, - 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, - 0L, 1L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, - 0L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, - 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, - 0L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, - 0L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, - 1L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 1L, - 0L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, - 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, - 0L, 1L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 0L, - 0L, 0L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 0L, - 0L, 1L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L), JaspColumn_.6._Encoded = c(2L, - 2L, 4L, 3L, 8L, 0L, 2L, 1L, 1L, 1L, 6L, 4L, 0L, 1L, 2L, 1L, 0L, - 0L, 4L, 1L, 0L, 1L, 3L, 10L, 3L, 1L, 1L, 1L, 2L, 1L, 2L, 0L, - 2L, 0L, 3L, 4L, 2L, 1L, 0L, 2L, 1L, 1L, 0L, 2L, 0L, 1L, 0L, 1L, - 0L, 0L, 5L, 1L, 2L, 3L, 1L, 3L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 4L, - 4L, 2L, 6L, 0L, 4L, 6L, 7L, 1L, 2L, 12L, 0L, 2L, 1L, 1L, 6L, - 2L, 1L, 0L, 0L, 12L, 2L, 0L, 2L, 1L, 1L, 2L, 8L, 5L, 2L, 3L, - 0L, 7L, 1L, 0L, 2L, 3L, 7L, 0L, 4L, 2L, 4L, 3L, 3L, 0L, 0L, 2L, - 11L, 1L, 0L, 3L, 0L, 12L, 5L, 2L, 1L, 0L, 19L, 2L, 1L, 1L, 0L, - 0L, 4L, 1L, 0L, 0L, 5L, 1L, 0L, 1L, 4L, 0L, 1L, 2L, 1L, 0L, 16L, - 1L, 0L, 0L, 1L, 2L, 3L, 4L, 1L, 0L, 2L, 0L, 1L, 12L, 0L, 18L, - 7L, 0L, 2L, 0L, 11L, 5L, 1L, 5L, 0L, 7L, 4L, 0L, 1L, 0L, 23L, - 0L, 2L, 1L, 1L, 6L, 11L, 1L, 0L, 0L, 1L, 0L, 1L, 2L, 1L, 0L, - 2L, 0L, 1L, 1L, 1L, 3L, 2L, 0L, 0L, 2L, 5L, 0L, 5L, 2L, 8L, 4L, - 1L, 10L, 3L, 4L, 0L, 0L, 0L, 1L, 2L, 0L, 0L, 7L, 2L, 1L, 3L, - 0L, 1L, 2L, 0L, 1L, 6L, 0L, 1L, 3L, 2L, 0L, 0L, 1L, 2L, 3L, 4L, - 2L, 1L, 1L, 2L, 1L, 0L, 1L, 4L, 0L, 0L, 0L, 3L, 0L, 0L, 1L, 0L, - 0L, 0L, 0L, 0L, 18L, 10L, 4L, 12L, 0L, 9L, 1L, 1L, 1L, 0L, 3L, - 3L, 0L, 0L, 0L, 4L, 1L, 1L, 4L, 1L, 0L, 4L, 5L, 14L, 2L, 1L, - 1L, 3L, 0L, 0L, 2L, 2L, 5L, 9L, 0L, 0L, 2L, 1L, 0L, 3L, 6L, 0L, - 4L, 6L, 0L, 1L, 1L), JaspColumn_.7._Encoded = c(0.427219425, - 0.220688309, 0.570053273, 0.231100824, 0.131067892, 1, 0.076567255, - 0.405903343, 0.474725634, 0.990018262, 0.192843674, 0.224774893, - 1, 0.740614383, 0.851823829, 0.653432541, 1, 1, 0.624686075, - 0.607677759, 1, 0.105184005, 0.178594546, 0.002517108, 0.769499354, - 0.543466466, 0.904824708, 0.597340464, 0.102275177, 0.939954609, - 0.644957841, 1, 0.092147577, 1, 0.052178635, 0.108955976, 0.103881947, - 0.307079922, 1, 0.640638174, 0.998201291, 0.358593487, 1, 0.098677587, - 1, 0.625249783, 1, 0.94040242, 1, 1, 0.108139376, 0.01932307, - 0.068532055, 0.319257561, 0.317226161, 0.042847799, 1, 0.907828255, - 1, 1, 1, 0.817368982, 1, 0.120666731, 0.211511707, 0.157775565, - 0.160599299, 1, 0.223432249, 0.071663969, 0.152479944, 0.4318303, - 0.064199554, 0.084701885, 1, 0.214182802, 0.250437733, 0.64748267, - 0.221051177, 0.8792932, 0.102889819, 1, 1, 0.004530114, 0.056033505, - 1, 0.107350229, 0.341537754, 0.560227328, 0.56788941, 0.029397749, - 0.128741443, 0.340319883, 0.438422074, 1, 0.363424137, 0.64064305, - 1, 0.669024544, 0.097899144, 0.184498989, 1, 0.626521215, 0.646898637, - 0.263503489, 0.147692887, 0.131565273, 1, 1, 0.132856326, 0.045526628, - 0.585667955, 1, 0.549235367, 1, 0.020705723, 0.029918293, 0.456543362, - 0.856084292, 1, 0.033240023, 0.000931051, 0.141747406, 0.691832666, - 1, 1, 0.119549448, 0.459920161, 1, 1, 0.63650842, 0.885468904, - 1, 0.66929208, 0.086900934, 1, 0.00297873, 0.387909833, 0.16488008, - 1, 0.154010162, 0.688411372, 1, 1, 0.374140598, 0.489588998, - 0.656373572, 0.253907352, 0.341392293, 1, 0.341498251, 1, 0.039745196, - 0.049899045, 1, 0.004291585, 0.064142592, 1, 0.162245865, 1, - 9.52e-05, 0.334425874, 0.55930246, 0.023006289, 1, 0.092510628, - 0.179388773, 1, 0.298066521, 1, 0.020858126, 1, 0.219817914, - 0.381100323, 0.383832334, 0.031687818, 0.021982156, 0.100909454, - 1, 1, 0.90886201, 1, 0.133518321, 0.321278177, 0.977561022, 1, - 0.377386837, 1, 0.924968583, 0.22384265, 0.001476047, 0.141017063, - 0.079471224, 1, 1, 0.003846134, 0.056555377, 1, 0.120304732, - 0.289193756, 0.021411919, 0.003588727, 0.815915327, 0.186839249, - 0.124749619, 0.215773542, 1, 1, 1, 0.09331221, 0.227188488, 1, - 1, 0.304550487, 0.242236769, 0.915177329, 0.038263021, 1, 0.690036211, - 0.115890253, 1, 0.377763011, 0.214936317, 1, 0.409689095, 0.016033388, - 0.696195914, 1, 1, 0.579652169, 0.111762879, 0.288249519, 0.685298051, - 0.029751715, 0.34902306, 0.740039564, 0.160866749, 0.934899752, - 1, 0.089958756, 0.101130973, 1, 1, 1, 0.000367582, 1, 1, 0.501846786, - 1, 1, 1, 1, 1, 0.012013178, 0.003237151, 0.37217903, 0.009178291, - 1, 0.091345794, 0.743160189, 0.983801698, 0.74850986, 1, 0.152319066, - 0.47288842, 1, 1, 1, 0.006951365, 0.522907566, 0.477519199, 0.077229532, - 0.344051985, 1, 0.268246943, 0.222762224, 0.013367555, 0.157375875, - 0.794346784, 0.403181111, 0.097897052, 1, 1, 0.243050875, 0.188878481, - 0.067540856, 0.169211418, 1, 1, 0.052260709, 0.052824504, 1, - 0.12313927, 0.085084118, 1, 0.018040391, 0.055642594, 1, 0.901317881, + dataset <- structure(list(JaspColumn_.0._Encoded = c(1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L), JaspColumn_.1._Encoded = c(1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), JaspColumn_.2._Encoded = c(1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), JaspColumn_.3._Encoded = c(1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, + 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, + 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, + 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L), JaspColumn_.4._Encoded = c(-0.653989689, + 0.597847379, 0.53124944, -0.919283666, 1.549214002, -0.964337181, + 0.758624407, -0.633353539, 0.093434858, 0.081944247, 1.251310302, + 1.399815493, -0.942716455, -0.495601118, 0.917930091, 0.344838602, + -1.226474961, -1.405114801, 0.686194991, 0.017571144, -0.337816215, + 0.384985065, 1.430491376, 1.866825203, 0.752814251, 1.31909783, + 0.447452196, -1.346206879, 0.479402493, -0.848513454, 0.850545592, + -3.037579176, 0.545769791, -1.182557897, -0.128004891, 1.11267647, + 0.616535768, -0.669227302, 0.076114909, 0.816454623, 0.422781459, + -0.094856662, -0.374461304, 0.691431944, -1.528712893, 1.05380469, + -0.545337415, -0.026770503, -2.189233221, -0.616004017, 1.150339483, + -0.133211268, 0.252652295, 1.399980471, -0.513151105, 1.117392323, + -0.610869543, 0.331300534, -0.992903801, -0.895568118, 0.623585941, + 1.05882918, -1.58627026, 0.947877674, 2.033833295, 0.179956552, + 1.573438425, -1.694333909, 1.079726669, 1.508240792, 0.90600351, + -0.290763172, -0.496024515, 1.946237186, -0.893948592, 0.830769682, + 0.440062416, -0.57837005, 1.790515054, 0.137924932, 0.055424081, + 0.547806104, -0.748529992, 1.71335853, 1.808028443, 0.017313744, + 0.988861738, -1.43975293, 0.338108584, -0.365015598, 1.86933575, + 1.699421632, 0.308476418, 1.556020356, -0.952816041, 1.874185874, + 1.104225239, -1.318714635, 1.431532182, 0.756206118, 1.892566353, + -0.933657521, 1.277498726, 0.407372551, 1.021542579, 0.74476069, + 0.571588797, -0.762850791, -2.287992665, -0.596915582, 2.920177191, + -0.853565433, -0.771818751, 0.492465518, -0.455610621, 2.667902824, + 1.953870427, 0.14233637, -1.188999386, -0.185194402, 2.751932451, + 0.1714291, 0.495442662, 0.007490023, -1.381723611, -0.360288418, + 1.228175718, 1.270669023, -0.317481349, -1.121300988, 0.248833912, + -0.936079972, -0.019929997, -0.752375481, 1.745747293, 0.005492604, + 0.407922866, 0.061474844, 0.69299688, 0.597159811, 2.949895836, + -0.24811046, 0.034494308, -0.78621074, 0.614844377, 1.095323201, + 0.672793259, 0.057114702, 0.072950494, 0.346984663, -0.452874548, + -0.114694466, 0.536167379, 2.672375374, 0.618138653, 2.749195306, + 2.199564155, -1.821705402, 0.662389551, -0.086448818, 2.350030519, + 1.42969294, -0.082903446, 1.526255915, -0.77415644, 1.646198365, + 0.550819959, -1.912875322, -0.170004512, -0.153966373, 3.216473665, + -2.384187974, 0.730941972, -0.065087507, 1.330153598, 1.27618167, + 1.956183459, 0.436215424, -1.232486611, -0.455381093, 0.83128861, + 0.152153259, -0.45491991, -0.256058166, -0.193076508, -0.334064589, + 0.215860632, -1.749746886, 0.358765965, 0.211328495, -0.112055855, + 0.945593904, 0.532860661, 0.01631963, -0.695297425, -0.182978288, + 1.940983578, -1.052570114, 1.265312559, -0.21744826, 2.122842478, + 1.291844321, -0.694666126, 2.001880096, 0.977066134, 1.383692522, + -0.085431624, -1.152918968, -1.621837649, 0.647353218, 1.079628054, + -0.220121984, -0.562039994, 2.441868908, 0.688842095, 0.572532136, + 1.049670153, -1.439036257, 0.673783789, 0.810812932, -0.557921732, + -0.055039468, 1.065618622, -0.653057442, -0.537812988, 0.818735764, + 0.874036767, -0.264722867, -1.083081897, 0.132684797, 1.282776406, + 0.980202012, 0.912757975, 0.395195197, -1.294487302, -0.149088612, + 1.042843997, -1.213788746, -1.842337004, -0.087241521, 1.759125287, + -0.65217472, -0.468828649, -1.128895132, 0.355130761, -1.13143679, + -0.231067871, -1.353450121, -1.710583197, 0.186715205, -0.543962675, + 0.292958499, -0.4283386, 2.670479768, 2.379591267, 1.278406268, + 2.298737024, -0.737706867, 1.468454399, 0.055981228, 0.149251786, + -0.332347905, -0.191862331, -0.012294677, 0.139243256, -1.123574851, + -0.034383926, -0.512343287, 0.812126437, 0.486944352, 0.595358492, + 1.224605923, 0.863959031, -1.789032311, 0.489475508, 2.019401428, + 2.492383813, 0.177655849, -0.587024392, 0.299497534, 1.602179556, + -1.502343948, -1.37596223, 0.74894869, 0.664588217, 1.321486377, + 1.888462109, -0.903168893, -3.201437624, -0.535609031, 0.554010178, + -0.547718747, 1.542488798, 1.851156869, 0.154379085, 0.617288371, + 1.273637679, -1.466949312, -0.150368723, -0.256217966), JaspColumn_.5._Encoded = c(1L, + 0L, 1L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, + 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, + 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, + 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 1L, + 1L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, + 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 0L, 0L, 1L, + 0L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, + 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, + 0L, 1L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, + 0L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, + 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, + 0L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, + 0L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, + 1L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 1L, + 0L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, + 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, + 0L, 1L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 0L, + 0L, 0L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 0L, + 0L, 1L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L), JaspColumn_.6._Encoded = c(2L, + 2L, 4L, 3L, 8L, 0L, 2L, 1L, 1L, 1L, 6L, 4L, 0L, 1L, 2L, 1L, 0L, + 0L, 4L, 1L, 0L, 1L, 3L, 10L, 3L, 1L, 1L, 1L, 2L, 1L, 2L, 0L, + 2L, 0L, 3L, 4L, 2L, 1L, 0L, 2L, 1L, 1L, 0L, 2L, 0L, 1L, 0L, 1L, + 0L, 0L, 5L, 1L, 2L, 3L, 1L, 3L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 4L, + 4L, 2L, 6L, 0L, 4L, 6L, 7L, 1L, 2L, 12L, 0L, 2L, 1L, 1L, 6L, + 2L, 1L, 0L, 0L, 12L, 2L, 0L, 2L, 1L, 1L, 2L, 8L, 5L, 2L, 3L, + 0L, 7L, 1L, 0L, 2L, 3L, 7L, 0L, 4L, 2L, 4L, 3L, 3L, 0L, 0L, 2L, + 11L, 1L, 0L, 3L, 0L, 12L, 5L, 2L, 1L, 0L, 19L, 2L, 1L, 1L, 0L, + 0L, 4L, 1L, 0L, 0L, 5L, 1L, 0L, 1L, 4L, 0L, 1L, 2L, 1L, 0L, 16L, + 1L, 0L, 0L, 1L, 2L, 3L, 4L, 1L, 0L, 2L, 0L, 1L, 12L, 0L, 18L, + 7L, 0L, 2L, 0L, 11L, 5L, 1L, 5L, 0L, 7L, 4L, 0L, 1L, 0L, 23L, + 0L, 2L, 1L, 1L, 6L, 11L, 1L, 0L, 0L, 1L, 0L, 1L, 2L, 1L, 0L, + 2L, 0L, 1L, 1L, 1L, 3L, 2L, 0L, 0L, 2L, 5L, 0L, 5L, 2L, 8L, 4L, + 1L, 10L, 3L, 4L, 0L, 0L, 0L, 1L, 2L, 0L, 0L, 7L, 2L, 1L, 3L, + 0L, 1L, 2L, 0L, 1L, 6L, 0L, 1L, 3L, 2L, 0L, 0L, 1L, 2L, 3L, 4L, + 2L, 1L, 1L, 2L, 1L, 0L, 1L, 4L, 0L, 0L, 0L, 3L, 0L, 0L, 1L, 0L, + 0L, 0L, 0L, 0L, 18L, 10L, 4L, 12L, 0L, 9L, 1L, 1L, 1L, 0L, 3L, + 3L, 0L, 0L, 0L, 4L, 1L, 1L, 4L, 1L, 0L, 4L, 5L, 14L, 2L, 1L, + 1L, 3L, 0L, 0L, 2L, 2L, 5L, 9L, 0L, 0L, 2L, 1L, 0L, 3L, 6L, 0L, + 4L, 6L, 0L, 1L, 1L), JaspColumn_.7._Encoded = c(0.427219425, + 0.220688309, 0.570053273, 0.231100824, 0.131067892, 1, 0.076567255, + 0.405903343, 0.474725634, 0.990018262, 0.192843674, 0.224774893, + 1, 0.740614383, 0.851823829, 0.653432541, 1, 1, 0.624686075, + 0.607677759, 1, 0.105184005, 0.178594546, 0.002517108, 0.769499354, + 0.543466466, 0.904824708, 0.597340464, 0.102275177, 0.939954609, + 0.644957841, 1, 0.092147577, 1, 0.052178635, 0.108955976, 0.103881947, + 0.307079922, 1, 0.640638174, 0.998201291, 0.358593487, 1, 0.098677587, + 1, 0.625249783, 1, 0.94040242, 1, 1, 0.108139376, 0.01932307, + 0.068532055, 0.319257561, 0.317226161, 0.042847799, 1, 0.907828255, + 1, 1, 1, 0.817368982, 1, 0.120666731, 0.211511707, 0.157775565, + 0.160599299, 1, 0.223432249, 0.071663969, 0.152479944, 0.4318303, + 0.064199554, 0.084701885, 1, 0.214182802, 0.250437733, 0.64748267, + 0.221051177, 0.8792932, 0.102889819, 1, 1, 0.004530114, 0.056033505, + 1, 0.107350229, 0.341537754, 0.560227328, 0.56788941, 0.029397749, + 0.128741443, 0.340319883, 0.438422074, 1, 0.363424137, 0.64064305, + 1, 0.669024544, 0.097899144, 0.184498989, 1, 0.626521215, 0.646898637, + 0.263503489, 0.147692887, 0.131565273, 1, 1, 0.132856326, 0.045526628, + 0.585667955, 1, 0.549235367, 1, 0.020705723, 0.029918293, 0.456543362, + 0.856084292, 1, 0.033240023, 0.000931051, 0.141747406, 0.691832666, + 1, 1, 0.119549448, 0.459920161, 1, 1, 0.63650842, 0.885468904, + 1, 0.66929208, 0.086900934, 1, 0.00297873, 0.387909833, 0.16488008, + 1, 0.154010162, 0.688411372, 1, 1, 0.374140598, 0.489588998, + 0.656373572, 0.253907352, 0.341392293, 1, 0.341498251, 1, 0.039745196, + 0.049899045, 1, 0.004291585, 0.064142592, 1, 0.162245865, 1, + 9.52e-05, 0.334425874, 0.55930246, 0.023006289, 1, 0.092510628, + 0.179388773, 1, 0.298066521, 1, 0.020858126, 1, 0.219817914, + 0.381100323, 0.383832334, 0.031687818, 0.021982156, 0.100909454, + 1, 1, 0.90886201, 1, 0.133518321, 0.321278177, 0.977561022, 1, + 0.377386837, 1, 0.924968583, 0.22384265, 0.001476047, 0.141017063, + 0.079471224, 1, 1, 0.003846134, 0.056555377, 1, 0.120304732, + 0.289193756, 0.021411919, 0.003588727, 0.815915327, 0.186839249, + 0.124749619, 0.215773542, 1, 1, 1, 0.09331221, 0.227188488, 1, + 1, 0.304550487, 0.242236769, 0.915177329, 0.038263021, 1, 0.690036211, + 0.115890253, 1, 0.377763011, 0.214936317, 1, 0.409689095, 0.016033388, + 0.696195914, 1, 1, 0.579652169, 0.111762879, 0.288249519, 0.685298051, + 0.029751715, 0.34902306, 0.740039564, 0.160866749, 0.934899752, + 1, 0.089958756, 0.101130973, 1, 1, 1, 0.000367582, 1, 1, 0.501846786, + 1, 1, 1, 1, 1, 0.012013178, 0.003237151, 0.37217903, 0.009178291, + 1, 0.091345794, 0.743160189, 0.983801698, 0.74850986, 1, 0.152319066, + 0.47288842, 1, 1, 1, 0.006951365, 0.522907566, 0.477519199, 0.077229532, + 0.344051985, 1, 0.268246943, 0.222762224, 0.013367555, 0.157375875, + 0.794346784, 0.403181111, 0.097897052, 1, 1, 0.243050875, 0.188878481, + 0.067540856, 0.169211418, 1, 1, 0.052260709, 0.052824504, 1, + 0.12313927, 0.085084118, 1, 0.018040391, 0.055642594, 1, 0.901317881, 0.859124256)), class = "data.frame", row.names = c(NA, -300L)) results <- runAnalysis("MixedModelsGLMM", dataset, options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -300,7 +301,7 @@ context("Generalized Linear Mixed Models") 1, "JaspColumn_.1._Encoded * JaspColumn_.7._Encoded", 0.528941241360197, 0.396425180671656)) }) - + test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -315,14 +316,14 @@ context("Generalized Linear Mixed Models") 0.427990253837139, 2, 0.921221811083906, 0.379752258678516, 0.249903469453633, 6, 0.073130329025205, 0.52944773101734)) }) - + test_that("Estimated Means and Confidence Intervals table results match", { table <- results[["results"]][["EstimatesTable"]][["data"]] jaspTools::expect_equal_tables(table, list(1, 0.361876751924427, 0.480762130159797, 0.601866619537568, 2, 0.423592336486101, 0.538669561398906, 0.649767899022927)) }) - + test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -333,27 +334,27 @@ context("Generalized Linear Mixed Models") 0.43017430669552, 0.528658632555254, 0.682756807631676, 0.630054950587302, "JaspColumn_.1._Encoded * JaspColumn_.7._Encoded")) }) - + test_that("JaspColumn_.0._Encoded: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE1"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "Intercept", -0.860597215248448, 1, "JaspColumn_.1._Encoded" )) }) - + test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES1"]][["data"]] jaspTools::expect_equal_tables(table, list(1, 1)) }) - + test_that("JaspColumn_.0._Encoded: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0.889188580238109, 0.790656331225863, "Intercept", 0.470404764148096, 0.221280642133226, "JaspColumn_.1._Encoded")) }) - + test_that("Contrasts table results match", { table <- results[["results"]][["contrasts_Means"]][["data"]] jaspTools::expect_equal_tables(table, @@ -362,33 +363,33 @@ context("Generalized Linear Mixed Models") "", -0.0135731311127926, 0.8756555048687, 0.0867409355278232, -0.156478956910014)) }) - + test_that("Contrasts table results match", { table <- results[["results"]][["contrasts_Trends"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", "", 0.430174306695523, 0.528658632555254, 0.68275680763168, 0.630054950587302)) }) - + test_that("Sample sizes table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitSizes"]][["data"]] jaspTools::expect_equal_tables(table, list(10, 300)) }) - + test_that("Fit statistics table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitStats"]][["data"]] jaspTools::expect_equal_tables(table, list(385.217480459902, 411.143957782495, 351.863795191825, 7, -185.608740229951 )) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "plot-glmm-1", dir="MixedModelsGLMM") }) - + test_that("Estimated Trends table results match", { table <- results[["results"]][["trendsSummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -402,19 +403,19 @@ context("Generalized Linear Mixed Models") ### binomial + probit, type II with LRT, no random slopes, custom options { options <- analysisOptions("MixedModelsGLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3", "4", "5", - "6", "7"), name = "contNormal", values = c("-1.11", "0", "1.11", - "-1.11", "0", "1.11")), list(isContrast = FALSE, levels = c("2", - "3", "4", "5", "6", "7"), name = "facGender", values = c("f", - "f", "f", "m", "m", "m")), list(isContrast = TRUE, levels = c("2", - "3", "4", "5", "6", "7"), name = "Contrast 1", values = c("1", - "-1", "0", "0", "0", "0")), list(isContrast = TRUE, levels = c("2", - "3", "4", "5", "6", "7"), name = "Contrast 2", values = c("0", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3", "4", "5", + "6", "7"), name = "contNormal", values = c("-1.11", "0", "1.11", + "-1.11", "0", "1.11")), list(isContrast = FALSE, levels = c("2", + "3", "4", "5", "6", "7"), name = "facGender", values = c("f", + "f", "f", "m", "m", "m")), list(isContrast = TRUE, levels = c("2", + "3", "4", "5", "6", "7"), name = "Contrast 1", values = c("1", + "-1", "0", "0", "0", "0")), list(isContrast = TRUE, levels = c("2", + "3", "4", "5", "6", "7"), name = "Contrast 2", values = c("0", "1", "-1", "0", "0", "0"))) options$bootstrap_samples <- 500 options$dependentVariable <- "contBinom" options$fitStats <- TRUE - options$fixedEffects <- list(list(components = "contNormal"), list(components = "facGender"), + options$fixedEffects <- list(list(components = "contNormal"), list(components = "facGender"), list(components = c("contNormal", "facGender"))) options$fixedVariables <- c("contNormal", "facGender") options$link <- "probit" @@ -448,8 +449,8 @@ context("Generalized Linear Mixed Models") options$plotsTrace <- list() options$plotsX <- list(list(variable = "facGender")) options$pvalVS <- FALSE - options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = FALSE, - value = "contNormal"), list(randomSlopes = FALSE, value = "facGender"), + options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = FALSE, + value = "contNormal"), list(randomSlopes = FALSE, value = "facGender"), list(randomSlopes = FALSE, value = c("contNormal", "facGender" ))), value = "facFive")) options$randomVariables <- "facFive" @@ -458,14 +459,14 @@ context("Generalized Linear Mixed Models") options$showFE <- TRUE options$showRE <- TRUE options$test_intercept <- FALSE - options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", + options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", values = list())) options$trendsTrend <- list() options$type <- "2" set.seed(1) results <- runAnalysis("MixedModelsGLMM", "debug", options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -473,7 +474,7 @@ context("Generalized Linear Mixed Models") 0.284327625868667, 1.14628764586072, 1, "contNormal * facGender", 0.334577761935427, 0.931098042304626)) }) - + test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -491,7 +492,7 @@ context("Generalized Linear Mixed Models") "m", -0.787241229561193, 6, 0.166455730892536, 0.235443926648938, -1.3836823807154, 0.135682003660025)) }) - + test_that("Estimated Means and Confidence Intervals table results match", { table <- results[["results"]][["EstimatesTable"]][["data"]] jaspTools::expect_equal_tables(table, @@ -499,7 +500,7 @@ context("Generalized Linear Mixed Models") "m", 0.232409248646226, 0.356852521999701, 0.49886949493473 )) }) - + test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -510,19 +511,19 @@ context("Generalized Linear Mixed Models") 0.338594418466376, 0.130299610691309, -0.956946184432264, "contNormal * facGender (1)" )) }) - + test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES1"]][["data"]] jaspTools::expect_equal_tables(table, list(1, 1)) }) - + test_that("facFive: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0, 0, "Intercept")) }) - + test_that("Contrasts table results match", { table <- results[["results"]][["contrasts_Means"]][["data"]] jaspTools::expect_equal_tables(table, @@ -531,20 +532,20 @@ context("Generalized Linear Mixed Models") "", 0.25187564641617, 0.294980047829034, 0.24050936605887, 1.04725920051911)) }) - + test_that("Sample sizes table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitSizes"]][["data"]] jaspTools::expect_equal_tables(table, list(5, 100)) }) - + test_that("Fit statistics table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitStats"]][["data"]] jaspTools::expect_equal_tables(table, list(143.384651734201, 156.410502664141, 133.384651734201, 5, -66.6923258671005 )) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] @@ -555,16 +556,16 @@ context("Generalized Linear Mixed Models") ### gamma + log, parametric bootsrap, no correlation { options <- analysisOptions("MixedModelsGLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", - values = c("f", "m")), list(isContrast = TRUE, levels = c("2", - "3"), name = "Contrast 1", values = c("1", "0")), list(isContrast = TRUE, - levels = c("2", "3"), name = "Contrast 2", values = c("0", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", + values = c("f", "m")), list(isContrast = TRUE, levels = c("2", + "3"), name = "Contrast 1", values = c("1", "0")), list(isContrast = TRUE, + levels = c("2", "3"), name = "Contrast 2", values = c("0", "0"))) options$bootstrap_samples <- 10 options$dependentVariable <- "contGamma" options$family <- "Gamma" options$fitStats <- FALSE - options$fixedEffects <- list(list(components = "facGender"), list(components = "contBinom"), + options$fixedEffects <- list(list(components = "facGender"), list(components = "contBinom"), list(components = c("facGender", "contBinom"))) options$fixedVariables <- c("facGender", "contBinom") options$link <- "log" @@ -599,8 +600,8 @@ context("Generalized Linear Mixed Models") options$plotsX <- list(list(variable = "facGender")) options$pvalVS <- FALSE options$randomEffects <- list(list(correlations = FALSE, randomComponents = list(list( - randomSlopes = TRUE, value = "facGender"), list(randomSlopes = FALSE, - value = "contBinom"), list(randomSlopes = FALSE, value = c("facGender", + randomSlopes = TRUE, value = "facGender"), list(randomSlopes = FALSE, + value = "contBinom"), list(randomSlopes = FALSE, value = c("facGender", "contBinom"))), value = "facFive")) options$randomVariables <- "facFive" options$seed <- 1 @@ -608,14 +609,14 @@ context("Generalized Linear Mixed Models") options$showFE <- TRUE options$showRE <- TRUE options$test_intercept <- FALSE - options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", + options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", values = list())) options$trendsTrend <- list() options$type <- "2" set.seed(1) results <- runAnalysis("MixedModelsGLMM", "debug", options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -624,7 +625,7 @@ context("Generalized Linear Mixed Models") 1, "facGender * contBinom", 0.547514203815074, 0.272727272727273, 0.361789256200893)) }) - + test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -633,14 +634,14 @@ context("Generalized Linear Mixed Models") "m", 0.413131329216369, 2, 1.12785900324191e-05, 0.169934425822602, 4.39108603186226, 1.07926203790796)) }) - + test_that("Estimated Means and Confidence Intervals table results match", { table <- results[["results"]][["EstimatesTable"]][["data"]] jaspTools::expect_equal_tables(table, list("f", 1.45433668005698, 1.79935874673052, 2.22623271752231, "m", 1.51154352272584, 2.1089636876888, 2.94250729080506)) }) - + test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -651,39 +652,39 @@ context("Generalized Linear Mixed Models") 0.547831413604434, 0.145501717060467, -0.601012871015956, "facGender (1) * contBinom" )) }) - + test_that("facFive.1: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE2"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "facGender (f)", 0.820565738951668, 1, "facGender (m)")) }) - + test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES2"]][["data"]] jaspTools::expect_equal_tables(table, list(0.698321361072845, 0.835656245757097)) }) - + test_that("facFive: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0.0625128879590991, 0.00390786116098688, "Intercept")) }) - + test_that("facFive.1: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE2"]][["data"]] jaspTools::expect_equal_tables(table, list(0.0273978028639619, 0.00075063960177252, "facGender (f)", 0.22325212826067, 0.0498415127729185, "facGender (m)")) }) - + test_that("Contrasts table results match", { table <- results[["results"]][["contrasts_Means"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", "", 0.587430349612986, 6.35907081922447e-08, 0.108614466701096, 5.408398783834)) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] @@ -694,8 +695,8 @@ context("Generalized Linear Mixed Models") ### poisson + log, type II parametric bootsrap { options <- analysisOptions("MixedModelsGLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", - values = c("f", "m")), list(isContrast = TRUE, levels = c("2", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", + values = c("f", "m")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 1", values = c("0", "0"))) options$bootstrap_samples <- 10 options$dependentVariable <- "facFifty" @@ -729,7 +730,7 @@ context("Generalized Linear Mixed Models") options$plotsTrace <- list() options$plotsX <- list(list(variable = "facGender")) options$pvalVS <- FALSE - options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = TRUE, + options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = TRUE, value = "facGender")), value = "facFive")) options$randomVariables <- "facFive" options$seed <- 1 @@ -742,15 +743,15 @@ context("Generalized Linear Mixed Models") options$type <- "2" set.seed(1) results <- runAnalysis("MixedModelsGLMM", "debug", options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "facGender", 0.323811589802939, 0.363636363636364, 0.973488924968706 )) }) - + test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -758,7 +759,7 @@ context("Generalized Linear Mixed Models") 23.882309468471, "m", 21.3136490705777, 1.38654373724911, 26.7605375156136 )) }) - + test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -766,27 +767,27 @@ context("Generalized Linear Mixed Models") 0.0606687532825319, 0.299679366705061, 0.0584972634725293, 1.0371212203973, "facGender (1)")) }) - + test_that("facFive: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE1"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "Intercept", 0.413199610716051, 1, "facGender (1)")) }) - + test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES1"]][["data"]] jaspTools::expect_equal_tables(table, list(1, 1)) }) - + test_that("facFive: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0.0442623696713281, 0.00195915736892131, "Intercept", 0.122872211562862, 0.0150975803743487, "facGender (1)")) }) - - + + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] @@ -797,15 +798,15 @@ context("Generalized Linear Mixed Models") ### aggregated binomial { options <- jaspTools::analysisOptions("MixedModelsGLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "cA", - values = c("1", "2")), list(isContrast = TRUE, levels = c("2", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "cA", + values = c("1", "2")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 1", values = c("-1", "1"))) options$bootstrap_samples <- 500 options$dependentVariable <- "binom_mean" options$dependentVariableAggregation <- "rep" options$family <- "binomial_agg" options$fitStats <- TRUE - options$fixedEffects <- list(list(components = "cA"), list(components = "cB"), list(components = c("cA", + options$fixedEffects <- list(list(components = "cA"), list(components = "cB"), list(components = c("cA", "cB"))) options$fixedVariables <- c("cA", "cB") options$marginalMeans <- list(list(variable = "cA")) @@ -841,36 +842,37 @@ context("Generalized Linear Mixed Models") options$showFE <- TRUE options$showRE <- TRUE options$test_intercept <- FALSE - options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", + options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", values = list())) options$trendsTrend <- list() options$type <- "3" + options$link <- "logit" set.seed(1) - dataset <- structure(list(id = c(1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L), cA = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L), cB = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L), binom_mean = c(0.6, 1, 0.6, 0.8, 0.8, 0.6, 0.2, 0.2, - 0.4, 0.6, 0.6, 0.6, 0, 0.6, 0.8, 1, 1, 0.4, 0.8, 0.6, 0.6, 0.6, - 0.2, 0.8, 0.6, 1, 0.8, 0.2, 0.4, 0.6, 0.2, 0.8, 0.2, 0.6, 0.4, - 0.8, 0.6, 0.6, 0.8, 0.4, 0, 0.4, 0.4, 0, 0.8, 0.8, 0.4, 0.4, - 0.2, 0.6, 0.4, 0.4, 0.4, 0.4, 0.8, 0.2, 0.8, 0.2, 0.6, 0.2), - rep = c(5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + dataset <- structure(list(id = c(1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L), cA = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L), cB = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L), binom_mean = c(0.6, 1, 0.6, 0.8, 0.8, 0.6, 0.2, 0.2, + 0.4, 0.6, 0.6, 0.6, 0, 0.6, 0.8, 1, 1, 0.4, 0.8, 0.6, 0.6, 0.6, + 0.2, 0.8, 0.6, 1, 0.8, 0.2, 0.4, 0.6, 0.2, 0.8, 0.2, 0.6, 0.4, + 0.8, 0.6, 0.6, 0.8, 0.4, 0, 0.4, 0.4, 0, 0.8, 0.8, 0.4, 0.4, + 0.2, 0.6, 0.4, 0.4, 0.4, 0.4, 0.8, 0.2, 0.8, 0.2, 0.6, 0.2), + rep = c(5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L)), class = "data.frame", row.names = c(NA, -60L)) results <- runAnalysis("MixedModelsGLMM", dataset, options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -878,7 +880,7 @@ context("Generalized Linear Mixed Models") 0.499316216168296, 1, "cA * cB", 0.859034817019825, 0.0315428035947605 )) }) - + # rounding due to problems on MacOS test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] @@ -887,7 +889,7 @@ context("Generalized Linear Mixed Models") 0.629899750093515, 2, 0.543534580013736, 0.424298904623603, 2, 0.0607273848025058, 0.657981320465884), round, 3, simplify = F)) }) - + # rounding due to problems on MacOS test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] @@ -898,46 +900,46 @@ context("Generalized Linear Mixed Models") 0.470404674525666, -0.704883931025144, "cB", -0.0531391637884625, 0.858923106746129, 0.298962625751381, -0.177745173514275, "cA * cB")), round, 3, simplify = F)) }) - + test_that("id: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE1"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "Intercept", -0.717602519023855, 1, "cA")) }) - + test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES1"]][["data"]] jaspTools::expect_equal_tables(table, list(1, 1)) }) - + test_that("id: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0.672274843452683, 0.45195346513933, "Intercept", 0.386000767561186, 0.148996592557825, "cA")) }) - + test_that("Contrasts table results match", { table <- results[["results"]][["contrasts_Means"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", "", 0.021975532292953, 0.74419933094708, 0.0673481619405325, 0.326297432027278)) }) - + test_that("Sample sizes table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitSizes"]][["data"]] jaspTools::expect_equal_tables(table, list(10, 60)) }) - + test_that("Fit statistics table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitStats"]][["data"]] jaspTools::expect_equal_tables(table, list(202.867152034655, 217.52756397021, 64.2564473172443, 7, -94.4335760173276 )) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] From 36d14e89849b6ec7d108f29f6c037ea43031d520 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 2 Jun 2021 07:21:13 +0200 Subject: [PATCH 12/38] fixes: https://github.com/jasp-stats/jasp-test-release/issues/1323 --- R/MixedModelsCommon.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 92e0a0a8..ed3c58b5 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -556,6 +556,11 @@ gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.") ) + else if (model$message == "PIRLS loop resulted in NaN value") + ANOVAsummary$setError( + gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data or an overly complex model structure. Try removing some of the predictors.") + ) + else if (model$message == "cannot find valid starting values: please specify some") # currently no solution to this, it seems to be a problem with synthetic data only. # I will try silving it once someone actually has problem with real data. From 251194ef79a50dcf385d033d2ac8e35527b0e2ae Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Sat, 12 Jun 2021 08:38:49 +0200 Subject: [PATCH 13/38] additional re-formatting.... --- R/MixedModelsCommon.R | 7249 ++++++++++++++++++++++++++++++----------- 1 file changed, 5269 insertions(+), 1980 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index ed3c58b5..8fec863c 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -20,36 +20,36 @@ # TODO: Add 3rd level random effects grouping factors ;) (not that difficult actually) .mmRunAnalysis <- function(jaspResults, dataset, options, type){ - + if (.mmReady(options, type)) dataset <- .mmReadData(jaspResults, dataset, options, type) if (.mmReady(options, type)) .mmCheckData(dataset, options, type) - + # fit the model if (.mmReady(options, type)){ if(type %in% c("LMM", "GLMM")).mmFitModel(jaspResults, dataset, options, type) if(type %in% c("BLMM", "BGLMM")).mmFitModelB(jaspResults, dataset, options, type) } - - + + # create (default) summary tables if(type %in% c("LMM", "GLMM")).mmSummaryAnova(jaspResults, dataset, options, type) if(type %in% c("BLMM", "BGLMM")).mmSummaryStanova(jaspResults, dataset, options, type) - + if (!is.null(jaspResults[["mmModel"]]) && !jaspResults[[ifelse(type %in% c("LMM", "GLMM"), "ANOVAsummary", "STANOVAsummary")]]$getError()) { - - + + # show fit statistics if (options$fitStats) { if(type %in% c("LMM", "GLMM")).mmFitStats(jaspResults, options, type) if(type %in% c("BLMM", "BGLMM")).mmFitStatsB(jaspResults, options, type) } - - + + # show fixed / random effects summary if (options$showFE){ if(type %in% c("LMM", "GLMM")).mmSummaryFE(jaspResults, options, type) @@ -60,19 +60,19 @@ if(type %in% c("BLMM", "BGLMM")).mmSummaryREB(jaspResults, options, type) } - + # sampling diagnostics if(type %in% c("BLMM", "BGLMM")){ if (length(options$samplingVariable1) != 0) .mmDiagnostics(jaspResults, options, dataset, type) } - - + + # create plots if (length(options$plotsX)) .mmPlot(jaspResults, dataset, options, type) - - + + # marginal means if (length(options$marginalMeans) > 0) .mmMarginalMeans(jaspResults, dataset, options, type) @@ -80,8 +80,8 @@ options$marginalMeansContrast && !is.null(jaspResults[["EMMresults"]])) .mmContrasts(jaspResults, options, type, what = "Means") - - + + # trends if (length(options$trendsTrend) > 0 && length(options$trendsVariables) > 0) @@ -92,7 +92,7 @@ !is.null(jaspResults[["EMTresults"]])) .mmContrasts(jaspResults, options, type, what = "Trends") } - + return() } @@ -124,7 +124,7 @@ options$randomVariables ) ) - } + } } } @@ -138,34 +138,34 @@ if(length(options$randomVariables) != 0) options$randomVariables )) dataset <- dataset[,used_variables] - + # omit NAs/NaN/Infs and store the number of omitted observations all_rows <- nrow(dataset) dataset <- na.omit(dataset) - + # store the number of missing values into a jaspState object n_missing <- createJaspState() n_missing$object <- all_rows - nrow(dataset) jaspResults[["n_missing"]] <- n_missing - + return(dataset) } .mmCheckData <- function(dataset, options, type = "LMM") { - + if(nrow(dataset) < length(options$fixedEffects)).quitAnalysis("The dataset contains fewer observations than predictors (after excluding NAs/NaN/Inf).") - + check_variables <- 1:ncol(dataset) if(type %in% c("GLMM", "BGLMM")) if(options$dependentVariableAggregation != "") check_variables <- check_variables[-which(.v(options$dependentVariableAggregation) == colnames(dataset))] - - + + .hasErrors( dataset, type = 'infinity', exitAnalysisIfErrors = TRUE ) - + # the aggregation variable for binomial can have zero variance and can be without factor levels .hasErrors( dataset[,check_variables], @@ -184,21 +184,21 @@ for(var in unlist(options$randomVariables)) { if(length(unique(dataset[,.v(var)])) == nrow(dataset)) - .quitAnalysis(gettextf("The random effects grouping factor '%s' must have fewer levels than the overall number of observations.",var)) - } - + .quitAnalysis(gettextf("The random effects grouping factor '%s' must have fewer levels than the overall number of observations.",var)) + } + # check hack-able options if (type %in% c("BLMM", "BGLMM")) { if (options$iteration - 1 <= options$warmup) { .quitAnalysis(gettext("The number of iterations must be at least 2 iterations higher than the burnin")) } } - + # check families if (type %in% c("GLMM","BGLMM")) { family_text <- .mmMessageGLMMtype(options$family, options$link) family_text <- substr(family_text, 1, nchar(family_text) - 1) - + if (options$family %in% c("Gamma", "inverse.gaussian")) { if (any(dataset[, .v(options$dependentVariable)] <= 0)) .quitAnalysis(gettextf("%s requires that the dependent variable is positive.",family_text)) @@ -249,158 +249,158 @@ } .mmModelFormula <- function(options, dataset) { # fixed effects - fe_terms <- + feTerms <- sapply(options[["fixedEffects"]], function(x) paste(.v(unlist(x)), collapse = "*")) # simplify the terms - fe_terms <- .mmSimplifyTerms(fe_terms) + feTerms <- .mmSimplifyTerms(feTerms) # create the FE formula - fixed_effects <- paste0(fe_terms, collapse = "+") - - if (fixed_effects == "") - fixed_effects <- 1 - + fixedEffects <- paste0(feTerms, collapse = "+") + + if (fixedEffects == "") + fixedEffects <- 1 + # random effects - random_effects <- NULL - removed_me <- list() - removed_te <- list() - added_re <- list() - for (temp_re in options[["randomEffects"]]) { + randomEffects <- NULL + removedMe <- list() + removedTe <- list() + addedRe <- list() + for (tempRe in options[["randomEffects"]]) { # unlist selected random effects - temp_vars <- sapply(temp_re$randomComponents, function(x) { + tempVars <- sapply(tempRe$randomComponents, function(x) { if (x$randomSlopes) { return(.v(unlist(x$value))) } else{ return(NA) } }) - temp_vars_rem <- sapply(temp_re$randomComponents, function(x) { + tempVarsRem <- sapply(tempRe$randomComponents, function(x) { if (x$randomSlopes) { return(NA) } else{ return(.v(unlist(x$value))) } }) - temp_vars <- temp_vars[!is.na(temp_vars)] - temp_vars <- - sapply(temp_vars, function(x) + tempVars <- tempVars[!is.na(tempVars)] + tempVars <- + sapply(tempVars, function(x) paste(unlist(x), collapse = "*")) - temp_vars_rem <- temp_vars_rem[!is.na(temp_vars_rem)] - temp_vars_rem <- - sapply(temp_vars_rem, function(x) + tempVarsRem <- tempVarsRem[!is.na(tempVarsRem)] + tempVarsRem <- + sapply(tempVarsRem, function(x) paste(unlist(x), collapse = "*")) ### test sensibility of random slopes # main effect check #1 # - remove main effects that have only one level of selected variable for the random effect grouping factor (eg only between subject variables) # - and associated interactions - me_to_remove <- NULL - for (me in temp_vars[!grepl("\\*", temp_vars)]) { - temp_table <- table(dataset[, c(.v(temp_re$value), me)]) - if (all(apply(temp_table, 1, function(x) + meToRemove <- NULL + for (me in tempVars[!grepl("\\*", tempVars)]) { + tempTable <- table(dataset[, c(.v(tempRe$value), me)]) + if (all(apply(tempTable, 1, function(x) sum(x > 0)) <= 1)) { - me_to_remove <- c(me_to_remove, me) + meToRemove <- c(meToRemove, me) } } - if (!is.null(me_to_remove)) { - temp_vars <- - temp_vars[!temp_vars %in% unique(as.vector(sapply(me_to_remove, function(x) - temp_vars[grepl(x, temp_vars, fixed = TRUE)])))] + if (!is.null(meToRemove)) { + tempVars <- + tempVars[!tempVars %in% unique(as.vector(sapply(meToRemove, function(x) + tempVars[grepl(x, tempVars, fixed = TRUE)])))] } - temp_vars <- na.omit(temp_vars) + tempVars <- na.omit(tempVars) # terms check #2 # - remove terms that have at maximum one measure across the level of variables (targeted at interactions of between subject variables) - te_to_remove <- NULL - for (te in temp_vars) { - temp_terms <- unlist(strsplit(te, "\\*")) - if (any(sapply(temp_terms, function(x) + teToRemove <- NULL + for (te in tempVars) { + tempTerms <- unlist(strsplit(te, "\\*")) + if (any(sapply(tempTerms, function(x) typeof(dataset[, .v(x)]) == "double"))) next - temp_table <- - table(dataset[, c(.v(temp_re$value), temp_terms)]) - if (all(temp_table <= 1)) { - te_to_remove <- c(te_to_remove, te) + tempTable <- + table(dataset[, c(.v(tempRe$value), tempTerms)]) + if (all(tempTable <= 1)) { + teToRemove <- c(teToRemove, te) } } - if (!is.null(te_to_remove)) { - te_to_remove <- - unique(as.vector(sapply(te_to_remove, function(x) - temp_vars[grepl(x, temp_vars, fixed = TRUE)]))) - temp_vars <- temp_vars[!temp_vars %in% te_to_remove] + if (!is.null(teToRemove)) { + teToRemove <- + unique(as.vector(sapply(teToRemove, function(x) + tempVars[grepl(x, tempVars, fixed = TRUE)]))) + tempVars <- tempVars[!tempVars %in% teToRemove] } - + # simplify the formula - re_added <- .mmAddedRETerms(temp_vars, temp_vars_rem) - re_terms <- .mmSimplifyTerms(temp_vars) - re_terms <- paste0(re_terms, collapse = "+") - - new_re <- + reAdded <- .mmAddedRETerms(tempVars, tempVarsRem) + reTerms <- .mmSimplifyTerms(tempVars) + reTerms <- paste0(reTerms, collapse = "+") + + newRe <- paste0( "(", - ifelse(re_terms == "", 1, re_terms), - ifelse(temp_re$correlation || - re_terms == "", "|", "||"), - .v(temp_re$value), + ifelse(reTerms == "", 1, reTerms), + ifelse(tempRe$correlation || + reTerms == "", "|", "||"), + .v(tempRe$value), ")" ) - - random_effects <- c(random_effects, new_re) - removed_me[[temp_re$value]] <- .unv(me_to_remove) - removed_te[[temp_re$value]] <- .unv(te_to_remove) - added_re[[temp_re$value]] <- re_added - } - random_effects <- paste0(random_effects, collapse = "+") - - model_formula <- + + randomEffects <- c(randomEffects, newRe) + removedMe[[tempRe$value]] <- .unv(meToRemove) + removedTe[[tempRe$value]] <- .unv(teToRemove) + addedRe[[tempRe$value]] <- reAdded + } + randomEffects <- paste0(randomEffects, collapse = "+") + + modelFormula <- paste0(.v(options$dependentVariable), "~", - fixed_effects, + fixedEffects, "+", - random_effects) - + randomEffects) + return( list( - model_formula = model_formula, - removed_me = removed_me, - removed_te = removed_te, - added_re = added_re + modelFormula = modelFormula, + removedMe = removedMe, + removedTe = removedTe, + addedRe = addedRe ) ) } .mmSimplifyTerms <- function(terms) { if (length(terms) > 1) { - split_terms <- sapply(terms, strsplit, "\\*") - split_terms <- - sapply(split_terms, function(x) + splitTerms <- sapply(terms, strsplit, "\\*") + splitTerms <- + sapply(splitTerms, function(x) trimws(x, which = c("both"))) - - terms_to_remove <- rep(NA, length(split_terms)) + + termsToRemove <- rep(NA, length(splitTerms)) for (i in 1:length(terms)) { - terms_to_remove[i] <- - any(sapply(split_terms[-i], function(x) - all(split_terms[[i]] %in% x))) + termsToRemove[i] <- + any(sapply(splitTerms[-i], function(x) + all(splitTerms[[i]] %in% x))) } - terms <- terms[!terms_to_remove] + terms <- terms[!termsToRemove] } return(terms) } .mmAddedRETerms <- function(terms, removed) { added <- NULL if (length(terms) > 1 && length(removed) >= 1) { - split_terms <- sapply(terms, strsplit, "\\*") - split_terms <- - sapply(split_terms, function(x) + splitTerms <- sapply(terms, strsplit, "\\*") + splitTerms <- + sapply(splitTerms, function(x) trimws(x, which = c("both"))) - - split_removed <- sapply(removed, strsplit, "\\*") - split_removed <- - sapply(split_removed, function(x) + + splitRemoved <- sapply(removed, strsplit, "\\*") + splitRemoved <- + sapply(splitRemoved, function(x) trimws(x, which = c("both"))) - - terms_to_remove <- rep(NA, length(split_terms)) + + termsToRemove <- rep(NA, length(splitTerms)) for (i in 1:length(removed)) { - if (any(sapply(split_terms, function(x) - all(split_removed[[i]] %in% x)))) { - added <- c(added, paste0(.unv(split_removed[[i]]), collapse = "*")) + if (any(sapply(splitTerms, function(x) + all(splitRemoved[[i]] %in% x)))) { + added <- c(added, paste0(.unv(splitRemoved[[i]]), collapse = "*")) } } } @@ -415,25 +415,25 @@ jaspResults[["mmModel"]] <- mmModel if (options$method == "PB") { - seed_dependencies <- c("seed", "setSeed") + seedDependencies <- c("seed", "setSeed") .setSeedJASP(options) } else{ - seed_dependencies <- NULL + seedDependencies <- NULL } if (type == "LMM") { - dependencies <- c(.mmDependenciesLMM, seed_dependencies) + dependencies <- c(.mmDependenciesLMM, seedDependencies) } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM, seed_dependencies) + dependencies <- c(.mmDependenciesGLMM, seedDependencies) } mmModel$dependOn(dependencies) - model_formula <- .mmModelFormula(options, dataset) + modelFormula <- .mmModelFormula(options, dataset) if (type == "LMM") { model <- tryCatch( afex::mixed( - formula = as.formula(model_formula$model_formula), + formula = as.formula(modelFormula$modelFormula), data = dataset, type = options$type, method = options$method, @@ -449,15 +449,15 @@ ) } else if (type == "GLMM") { # needs to be avaluated in the global environment - glmm_family <<- options$family - glmm_link <<- options$link + glmmFamily <<- options$family + glmmLink <<- options$link # I wish there was a better way to do this if (options$family == "binomial_agg") { - glmm_weight <<- dataset[, .v(options$dependentVariableAggregation)] + glmmWeight <<- dataset[, .v(options$dependentVariableAggregation)] model <- tryCatch( afex::mixed( - formula = as.formula(model_formula$model_formula), + formula = as.formula(modelFormula$modelFormula), data = dataset, type = options$type, method = options$method, @@ -467,8 +467,8 @@ FALSE, args_test = list(nsim = options$bootstrap_samples), check_contrasts = TRUE, - family = eval(call("binomial", glmm_link)), - weights = glmm_weight + family = eval(call("binomial", glmmLink)), + weights = glmmWeight ), error = function(e) return(e) @@ -476,7 +476,7 @@ } else{ model <- tryCatch( afex::mixed( - formula = as.formula(model_formula$model_formula), + formula = as.formula(modelFormula$modelFormula), data = dataset, type = options$type, method = options$method, @@ -487,7 +487,7 @@ args_test = list(nsim = options$bootstrap_samples), check_contrasts = TRUE, #start = start, - family = eval(call(glmm_family, glmm_link)) + family = eval(call(glmmFamily, glmmLink)) ), error = function(e) return(e) @@ -498,9 +498,9 @@ object <- list( model = model, - removed_me = model_formula$removed_me, - removed_te = model_formula$removed_te, - added_re = model_formula$added_re + removedMe = modelFormula$removedMe, + removedTe = modelFormula$removedTe, + addedRe = modelFormula$addedRe ) mmModel$object <- object @@ -508,185 +508,186 @@ return() } .mmSummaryAnova <- function(jaspResults, dataset, options, type = "LMM") { - if (!is.null(jaspResults[["ANOVAsummary"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - ANOVAsummary <- createJaspTable(title = gettext("ANOVA Summary")) - #defining columns first to give the user something nice to look at - ANOVAsummary$addColumnInfo(name = "effect", title = gettext("Effect"), type = "string") - if (options$method %in% c("S", "KR")) { - ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "string") - ANOVAsummary$addColumnInfo(name = "stat", title = gettext("F"), type = "number") - } else if - (options$method %in% c("PB", "LRT")) { - ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "integer") - ANOVAsummary$addColumnInfo(name = "stat", title = gettext("ChiSq"), type = "number") - } - ANOVAsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") - if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBoot", title = gettext("p (bootstrap)"), type = "pvalue") - if (options$pvalVS) { - ANOVAsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") - if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBootVS", title = gettext("VS-MPR (bootstrap)"), type = "number") + if (!is.null(jaspResults[["ANOVAsummary"]])) + return() - ANOVAsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = c("pvalVS", "pvalBootVS")) - } + model <- jaspResults[["mmModel"]]$object$model - jaspResults[["ANOVAsummary"]] <- ANOVAsummary - - ANOVAsummary$position <- 1 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- .mmDependenciesGLMM - } - if (options$method == "PB") { - seed_dependencies <- c("seed", "setSeed") - } else{ - seed_dependencies <- NULL - } - ANOVAsummary$dependOn(c(dependencies, seed_dependencies, "pvalVS")) - - # some error managment for GLMMS - and oh boy, they can fail really easily - if (type %in% c("LMM", "GLMM") && !is.null(model)) { - if (any(attr(model, "class") %in% c("std::runtime_error", "C++Error", "error"))) { - if (model$message == "(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate") - ANOVAsummary$setError( - gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.") - ) + ANOVAsummary <- createJaspTable(title = gettext("ANOVA Summary")) + #defining columns first to give the user something nice to look at + ANOVAsummary$addColumnInfo(name = "effect", title = gettext("Effect"), type = "string") + if (options$method %in% c("S", "KR")) { + ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "string") + ANOVAsummary$addColumnInfo(name = "stat", title = gettext("F"), type = "number") + } else if + (options$method %in% c("PB", "LRT")) { + ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "integer") + ANOVAsummary$addColumnInfo(name = "stat", title = gettext("ChiSq"), type = "number") + } + ANOVAsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") + if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBoot", title = gettext("p (bootstrap)"), type = "pvalue") + if (options$pvalVS) { + ANOVAsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") + if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBootVS", title = gettext("VS-MPR (bootstrap)"), type = "number") - else if (model$message == "PIRLS loop resulted in NaN value") - ANOVAsummary$setError( - gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data or an overly complex model structure. Try removing some of the predictors.") - ) + ANOVAsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = c("pvalVS", "pvalBootVS")) + } + + jaspResults[["ANOVAsummary"]] <- ANOVAsummary + + ANOVAsummary$position <- 1 + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- .mmDependenciesGLMM + } + if (options$method == "PB") { + seedDependencies <- c("seed", "setSeed") + } else{ + seedDependencies <- NULL + } + ANOVAsummary$dependOn(c(dependencies, seedDependencies, "pvalVS")) - else if (model$message == "cannot find valid starting values: please specify some") - # currently no solution to this, it seems to be a problem with synthetic data only. - # I will try silving it once someone actually has problem with real data. - ANOVAsummary$setError(gettext("The optimizer failed to find a solution due to invalid starting values. (JASP currently does not support specifying different starting values.)")) + # some error managment for GLMMS - and oh boy, they can fail really easily + if (type %in% c("LMM", "GLMM") && !is.null(model)) { + if (any(attr(model, "class") %in% c("std::runtime_error", "C++Error", "error"))) { + if (model$message == "(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate") + ANOVAsummary$setError( + gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.") + ) - else if (model$message == "Downdated VtV is not positive definite") - ANOVAsummary$setError(gettext("The optimizer failed to find a solution. Probably due to scaling issues quasi-separation in the data. Try rescaling or removing some of the predictors.")) + else if (model$message == "PIRLS loop resulted in NaN value") + ANOVAsummary$setError( + gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data or an overly complex model structure. Try removing some of the predictors.") + ) - else - ANOVAsummary$setError(.unv(model$message)) + else if (model$message == "cannot find valid starting values: please specify some") + # currently no solution to this, it seems to be a problem with synthetic data only. + # I will try silving it once someone actually has problem with real data. + ANOVAsummary$setError(gettext("The optimizer failed to find a solution due to invalid starting values. (JASP currently does not support specifying different starting values.)")) - - return() - } - - } + else if (model$message == "Downdated VtV is not positive definite") + ANOVAsummary$setError(gettext("The optimizer failed to find a solution. Probably due to scaling issues quasi-separation in the data. Try rescaling or removing some of the predictors.")) + + + else + ANOVAsummary$setError(.unv(model$message)) - if (is.null(model)) { - if (options$dependentVariable != "" && - length(options$fixedVariables) > 0 && - length(options$randomVariables) == 0) { - ANOVAsummary$addFootnote(.mmMessageMissingRE) - } - if (type == "GLMM") { - if (options$family == "binomial_agg" && - options$dependentVariableAggregation == "") { - ANOVAsummary$addFootnote(.mmMessageMissingAgg) - } - } return() } - - - for (i in 1:nrow(model$anova_table)) { - if (rownames(model$anova_table)[i] == "(Intercept)") { - effect_name <- gettext("Intercept") - } else{ - effect_name <- jaspBase::gsubInteractionSymbol(rownames(model$anova_table)[i]) - } - - temp_row <- list(effect = effect_name, - df = afex::nice(model)$df[i]) - - if (options$method %in% c("S", "KR")) { - temp_row$stat = model$anova_table$`F`[i] - temp_row$pval = model$anova_table$`Pr(>F)`[i] - } else if (options$method == "PB") { - temp_row$stat = model$anova_table$Chisq[i] - temp_row$pval = model$anova_table$`Pr(>Chisq)`[i] - temp_row$pvalBoot = model$anova_table$`Pr(>PB)`[i] - } else if (options$method == "LRT") { - temp_row$stat = model$anova_table$Chisq[i] - temp_row$pval = model$anova_table$`Pr(>Chisq)`[i] - } - if (options$pvalVS) { - temp_row$pvalVS <- VovkSellkeMPR(temp_row$pval) - if (options$method == "PB") { - temp_row$pvalBootVS <- - VovkSellkeMPR(temp_row$pvalBoot) - } - } - - ANOVAsummary$addRows(temp_row) - } - - # add message about (lack of) random effect grouping factors - ANOVAsummary$addFootnote(.mmMessageREgrouping(options$randomVariables)) - - # add warning messages - # deal with type II multiple models stuff - if (is.list(model$full_model)) { - if (lme4::isSingular(model$full_model[[length(model$full_model)]])) { - ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) - } else if (!is.null(model$full_model[[length(model$full_model)]]@optinfo$conv$lme4$messages)) { - ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) + + } + + + if (is.null(model)) { + if (options$dependentVariable != "" && + length(options$fixedVariables) > 0 && + length(options$randomVariables) == 0) { + ANOVAsummary$addFootnote(.mmMessageMissingRE) + } + if (type == "GLMM") { + if (options$family == "binomial_agg" && + options$dependentVariableAggregation == "") { + ANOVAsummary$addFootnote(.mmMessageMissingAgg) } + } + return() + } + + + for (i in 1:nrow(model$anova_table)) { + if (rownames(model$anova_table)[i] == "(Intercept)") { + effectName <- gettext("Intercept") } else{ - if (lme4::isSingular(model$full_model)) { - ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) - } else if (!is.null(model$full_model@optinfo$conv$lme4$messages)) { - ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) + effectName <- jaspBase::gsubInteractionSymbol(rownames(model$anova_table)[i]) + } + + tempRow <- list(effect = effectName, + df = afex::nice(model)$df[i]) + + if (options$method %in% c("S", "KR")) { + tempRow$stat = model$anova_table$`F`[i] + tempRow$pval = model$anova_table$`Pr(>F)`[i] + } else if (options$method == "PB") { + tempRow$stat = model$anova_table$Chisq[i] + tempRow$pval = model$anova_table$`Pr(>Chisq)`[i] + tempRow$pvalBoot = model$anova_table$`Pr(>PB)`[i] + } else if (options$method == "LRT") { + tempRow$stat = model$anova_table$Chisq[i] + tempRow$pval = model$anova_table$`Pr(>Chisq)`[i] + } + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) + if (options$method == "PB") { + tempRow$pvalBootVS <- + VovkSellkeMPR(tempRow$pvalBoot) } } - if (jaspResults[["n_missing"]]$object != 0) { - ANOVAsummary$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) - } - - removed_me <- jaspResults[["mmModel"]]$object$removed_me - removed_te <- jaspResults[["mmModel"]]$object$removed_te - added_re <- jaspResults[["mmModel"]]$object$added_re - - for (i in seq_along(removed_me)) - ANOVAsummary$addFootnote(.mmMessageOmmitedTerms1(removed_me[[i]], names(removed_me)[i]), symbol = gettext("Note:")) - - for (i in seq_along(removed_te)) - ANOVAsummary$addFootnote(.mmMessageOmmitedTerms2(removed_te[[i]], names(removed_te)[i]), symbol = gettext("Note:")) - - for (i in seq_along(added_re)) - ANOVAsummary$addFootnote(.mmMessageAddedTerms(added_re[[i]], names(added_re)[i]), symbol = gettext("Note:")) - - - - ANOVAsummary$addFootnote(.mmMessageANOVAtype(ifelse(options$type == 3, gettext("III"), gettext("II")))) - if (type == "GLMM") - ANOVAsummary$addFootnote(.mmMessageGLMMtype(options$family, options$link)) - - ANOVAsummary$addFootnote(.mmMessageTermTest(options$method)) - - - return() + + ANOVAsummary$addRows(tempRow) + } + + # add message about (lack of) random effect grouping factors + ANOVAsummary$addFootnote(.mmMessageREgrouping(options$randomVariables)) + + # add warning messages + # deal with type II multiple models stuff + if (is.list(model$full_model)) { + if (lme4::isSingular(model$full_model[[length(model$full_model)]])) { + ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) + } else if (!is.null(model$full_model[[length(model$full_model)]]@optinfo$conv$lme4$messages)) { + ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) + } + } else{ + if (lme4::isSingular(model$full_model)) { + ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) + } else if (!is.null(model$full_model@optinfo$conv$lme4$messages)) { + ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) + } + } + if (jaspResults[["n_missing"]]$object != 0) { + ANOVAsummary$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) } + + removedMe <- jaspResults[["mmModel"]]$object$removedMe + removedTe <- jaspResults[["mmModel"]]$object$removedTe + addedRe <- jaspResults[["mmModel"]]$object$addedRe + + for (i in seq_along(removedMe)) + ANOVAsummary$addFootnote(.mmMessageOmmitedTerms1(removedMe[[i]], names(removedMe)[i]), symbol = gettext("Note:")) + + for (i in seq_along(removedTe)) + ANOVAsummary$addFootnote(.mmMessageOmmitedTerms2(removedTe[[i]], names(removedTe)[i]), symbol = gettext("Note:")) + + for (i in seq_along(addedRe)) + ANOVAsummary$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) + + + + ANOVAsummary$addFootnote(.mmMessageANOVAtype(ifelse(options$type == 3, gettext("III"), gettext("II")))) + if (type == "GLMM") + ANOVAsummary$addFootnote(.mmMessageGLMMtype(options$family, options$link)) + + ANOVAsummary$addFootnote(.mmMessageTermTest(options$method)) + + + return() +} .mmFitStats <- function(jaspResults, options, type = "LMM") { if (!is.null(jaspResults[["fitStats"]])) return() - + model <- jaspResults[["mmModel"]]$object$model if (is.list(model$full_model)) { full_model <- model$full_model[[length(model$full_model)]] } else{ full_model <- model$full_model } - + fitSummary <- createJaspContainer("Model summary") fitSummary$position <- 2 - + if (type == "LMM") { dependencies <- .mmDependenciesLMM } else if (type == "GLMM") { @@ -697,8 +698,8 @@ fitSummary$dependOn(c(dependencies, "fitStats")) jaspResults[["fitSummary"]] <- fitSummary - - + + ### fit statistics fitStats <- createJaspTable(title = gettext("Fit statistics")) fitStats$position <- 1 @@ -712,9 +713,9 @@ fitStats$addColumnInfo(name = "aic", title = gettext("AIC"), type = "number") fitStats$addColumnInfo(name = "bic", title = gettext("BIC"), type = "number") jaspResults[["fitSummary"]][["fitStats"]] <- fitStats - - - temp_row <- list( + + + tempRow <- list( loglik = logLik(full_model), df = attr(logLik(full_model) , "df"), aic = AIC(full_model), @@ -722,54 +723,53 @@ ) if (!lme4::isREML(full_model)) - temp_row$deviance <- deviance(full_model, REML = FALSE) + tempRow$deviance <- deviance(full_model, REML = FALSE) if (lme4::isREML(full_model)) - temp_row$devianceREML <- lme4::REMLcrit(full_model) - - fitStats$addRows(temp_row) + tempRow$devianceREML <- lme4::REMLcrit(full_model) + + fitStats$addRows(tempRow) fitStats$addFootnote(.mmMessageFitType(lme4::isREML(full_model))) - - + + ### sample sizes fitSizes <- createJaspTable(title = gettext("Sample sizes")) fitSizes$position <- 2 - + fitSizes$addColumnInfo(name = "observations", title = gettext("Observations"), type = "integer") - temp_row <- list( + tempRow <- list( observations = nrow(full_model@frame) ) for (thisName in names(full_model@flist)) { fitSizes$addColumnInfo(name = thisName, title = .unv(thisName), type = "integer", overtitle = gettext("Levels of RE grouping factors")) - temp_row[[thisName]] <- length(levels(full_model@flist[[thisName]])) + tempRow[[thisName]] <- length(levels(full_model@flist[[thisName]])) } - fitSizes$addRows(temp_row) + fitSizes$addRows(tempRow) jaspResults[["fitSummary"]][["fitSizes"]] <- fitSizes - + return() } .mmSummaryRE <- function(jaspResults, options, type = "LMM") { if (!is.null(jaspResults[["REsummary"]])) return() - + model <- jaspResults[["mmModel"]]$object$model - - REsummary <- - createJaspContainer(title = gettext("Variance/Correlation Estimates")) - + + REsummary <- createJaspContainer(title = gettext("Variance/Correlation Estimates")) + REsummary$position <- 4 - + if (type == "LMM") { dependencies <- .mmDependenciesLMM } else if (type == "GLMM") { dependencies <- .mmDependenciesGLMM } if (options$method == "PB") { - seed_dependencies <- c("seed", "setSeed") + seedDependencies <- c("seed", "setSeed") } else{ - seed_dependencies <- NULL + seedDependencies <- NULL } - REsummary$dependOn(c(dependencies, seed_dependencies, "showRE")) - + REsummary$dependOn(c(dependencies, seedDependencies, "showRE")) + # deal with SS type II stuff if (is.list(model$full_model)) { VarCorr <- @@ -779,12 +779,11 @@ } # go over each random effect grouping factor for (gi in 1:length(VarCorr)) { - temp_VarCorr <- VarCorr[[gi]] - + tempVarCorr <- VarCorr[[gi]] + # add variance summary - REvar <- - createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) - + REvar <- createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) + REvar$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") @@ -794,1290 +793,4580 @@ REvar$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") - - temp_StdDev <- attr(temp_VarCorr, "stddev") - for (i in 1:length(temp_StdDev)) { - if (names(temp_StdDev)[i] == "(Intercept)") { - var_name <- gettext("Intercept") + + tempStdDev <- attr(tempVarCorr, "stddev") + for (i in 1:length(tempStdDev)) { + if (names(tempStdDev)[i] == "(Intercept)") { + varName <- gettext("Intercept") } else{ - var_name <- .mmVariableNames(names(temp_StdDev)[i], options$fixedVariables) + varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) } - - temp_row <- list( - variable = var_name, - std = temp_StdDev[i], - var = temp_StdDev[i]^2 + + tempRow <- list( + variable = varName, + std = tempStdDev[i], + var = tempStdDev[i]^2 ) - - REvar$addRows(temp_row) + + REvar$addRows(tempRow) } - + REvar$addFootnote(.mmMessageInterpretability) - + REsummary[[paste0("VE", gi)]] <- REvar - - + + # add correlation summary - if (length(temp_StdDev) > 1) { - temp_Corr <- attr(temp_VarCorr, "correlation") + if (length(tempStdDev) > 1) { + tempCorr <- attr(tempVarCorr, "correlation") REcor <- createJaspTable(title = gettextf("%s: Correlation Estimates",.unv(names(VarCorr)[gi]))) - + # add columns REcor$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") - for (i in 1:nrow(temp_Corr)) { - if (rownames(temp_Corr)[i] == "(Intercept)") { - var_name <- gettext("Intercept") + for (i in 1:nrow(tempCorr)) { + if (rownames(tempCorr)[i] == "(Intercept)") { + varName <- gettext("Intercept") } else{ - var_name <- .mmVariableNames(rownames(temp_Corr)[i], options$fixedVariables) + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) } REcor$addColumnInfo(name = paste0("v", i), - title = var_name, + title = varName, type = "number") } - + # fill rows - for (i in 1:nrow(temp_Corr)) { - if (rownames(temp_Corr)[i] == "(Intercept)") { - var_name <- gettext("Intercept") + for (i in 1:nrow(tempCorr)) { + if (rownames(tempCorr)[i] == "(Intercept)") { + varName <- gettext("Intercept") } else{ - var_name <- .mmVariableNames(rownames(temp_Corr)[i], options$fixedVariables) + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) } - - temp_row <- list(variable = var_name) + + tempRow <- list(variable = varName) for (j in 1:i) { - temp_row[paste0("v", j)] <- temp_Corr[i, j] + tempRow[paste0("v", j)] <- tempCorr[i, j] } - REcor$addRows(temp_row) + REcor$addRows(tempRow) } - + REcor$addFootnote(.mmMessageInterpretability) - + REsummary[[paste0("CE", gi)]] <- REcor - + } - + } - + # add residual variance summary REres <- createJaspTable(title = gettext("Residual Variance Estimates")) - + REres$addColumnInfo(name = "std", title = gettext("Std. Deviation"), type = "number") REres$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") - + if (is.list(model$full_model)) { - temp_row <- + tempRow <- list(std = sigma(model$full_model[[length(model$full_model)]]), var = sqrt(sigma(model$full_model[[length(model$full_model)]]))) } else{ - temp_row <- list(std = sigma(model$full_model), - var = sigma(model$full_model)^2) + tempRow <- list(std = sigma(model$full_model), + var = sigma(model$full_model)^2) } - - REres$addRows(temp_row) + + REres$addRows(tempRow) REsummary[[paste0("RES", gi)]] <- REres - - + + jaspResults[["REsummary"]] <- REsummary return() } .mmSummaryFE <- function(jaspResults, options, type = "LMM") { if (!is.null(jaspResults[["FEsummary"]])) return() - + model <- jaspResults[["mmModel"]]$object$model - + if (is.list(model$full_model)) { - FE_coef <- + FEcoef <- summary(model$full_model[[length(model$full_model)]])$coeff } else{ - FE_coef <- summary(model$full_model)$coeff + FEcoef <- summary(model$full_model)$coeff } - + FEsummary <- createJaspTable(title = gettext("Fixed Effects Estimates")) - + FEsummary$position <- 3 if (type == "LMM") dependencies <- .mmDependenciesLMM else if (type == "GLMM") dependencies <- .mmDependenciesGLMM if(options$method == "PB"){ - seed_dependencies <- c("seed", "setSeed") + seedDependencies <- c("seed", "setSeed") }else{ - seed_dependencies <- NULL + seedDependencies <- NULL } - - FEsummary$dependOn(c(dependencies, seed_dependencies, "showFE", "pvalVS")) - - FEsummary$addColumnInfo(name = "term", title = gettext("Term"), type = "string") - FEsummary$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") - FEsummary$addColumnInfo(name = "se", title = gettext("SE"), type = "number") + + FEsummary$dependOn(c(dependencies, seedDependencies, "showFE", "pvalVS")) + + FEsummary$addColumnInfo(name = "term", title = gettext("Term"), type = "string") + FEsummary$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") + FEsummary$addColumnInfo(name = "se", title = gettext("SE"), type = "number") if (type == "LMM") FEsummary$addColumnInfo(name = "df", title = gettext("df"), type = "number") - FEsummary$addColumnInfo(name = "stat", title = gettext("t"), type = "number") - if (ncol(FE_coef) >= 4) FEsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") + FEsummary$addColumnInfo(name = "stat", title = gettext("t"), type = "number") + if (ncol(FEcoef) >= 4) FEsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") if (options$pvalVS) { - FEsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") + FEsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") FEsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") } - + jaspResults[["FEsummary"]] <- FEsummary - for (i in 1:nrow(FE_coef)) { - if (rownames(FE_coef)[i] == "(Intercept)") { - effect_name <- gettext("Intercept") + for (i in 1:nrow(FEcoef)) { + if (rownames(FEcoef)[i] == "(Intercept)") { + effectName <- gettext("Intercept") } else{ - effect_name <- .mmVariableNames(rownames(FE_coef)[i], options$fixedVariables) + effectName <- .mmVariableNames(rownames(FEcoef)[i], options$fixedVariables) } - + if (type == "LMM") { - temp_row <- list( - term = effect_name, - estimate = FE_coef[i, 1], - se = FE_coef[i, 2], - df = FE_coef[i, 3], - stat = FE_coef[i, 4], - pval = FE_coef[i, 5] + tempRow <- list( + term = effectName, + estimate = FEcoef[i, 1], + se = FEcoef[i, 2], + df = FEcoef[i, 3], + stat = FEcoef[i, 4], + pval = FEcoef[i, 5] ) } else if (type == "GLMM") { - temp_row <- list( - term = effect_name, - estimate = FE_coef[i, 1], - se = FE_coef[i, 2], - stat = FE_coef[i, 3] + tempRow <- list( + term = effectName, + estimate = FEcoef[i, 1], + se = FEcoef[i, 2], + stat = FEcoef[i, 3] ) - if (ncol(FE_coef) >= 4) { - temp_row$pval <- FE_coef[i, 4] + if (ncol(FEcoef) >= 4) { + tempRow$pval <- FEcoef[i, 4] } } - + if (options$pvalVS) { - temp_row$pvalVS <- VovkSellkeMPR(temp_row$pval) + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) } - - FEsummary$addRows(temp_row) + + FEsummary$addRows(tempRow) } - + # add warning messages FEsummary$addFootnote(.mmMessageInterpretability) - + } .mmFixPlotAxis <- function(p){ - + yTicks <- jaspGraphs::getPrettyAxisBreaks(ggplot2::layer_scales(p)$y$range$range) yRange <- range(yTicks) xTicks <- ggplot2::layer_scales(p)$x$range$range - + p + ggplot2::scale_y_continuous(breaks = yTicks, limits = yRange) + ggplot2::scale_x_discrete(breaks = xTicks) } .mmPlot <- function(jaspResults, dataset, options, type = "LMM") { - if (!is.null(jaspResults[["plots"]])) - return() + if (!is.null(jaspResults[["plots"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + # automatic size specification will somewhat work unless there is more than 2 variables in panel + height <- 350 + width <- 150 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, .v(x)])) / 2)) + + if (length(options$plotsPanel) > 0) { + width <- + width * length(unique(dataset[, .v(unlist(options$plotsPanel)[1])])) + } else if (length(options$plotsPanel) > 1) { + height <- + height * length(unique(dataset[, .v(unlist(options$plotsPanel)[2])])) + } + if (options$plotLegendPosition %in% c("bottom", "top")) { + height <- height + 50 + } else if (options$plotLegendPosition %in% c("left", "right")) { + width <- width + 100 + } + width <- width + 150 + + plots <- createJaspPlot(title = gettext("Plot"), width = width, height = height) + + plots$position <- 5 + switch(type, + LMM = dependencies <- .mmDependenciesLMM, + GLMM = dependencies <- .mmDependenciesGLMM, + BLMM = dependencies <- .mmDependenciesBLMM, + BGLMM = dependencies <- .mmDependenciesBGLMM + ) + + plots$dependOn( + c( + dependencies, + "plotsX", + "plotsTrace", + "plotsPanel", + "plotsAgregatedOver", + "plotsGeom", + "plotsTrace", + "plotsPanel", + "plotsTheme", + "plotsCIwidth", + "plotsCImethod", + "plotAlpha", + "plotJitterWidth", + "plotJitterHeight", + "plotGeomWidth", + "plotDodge", + "plotsBackgroundColor", + "plotRelativeSize", + "plotRelativeSizeText", + "plotLegendPosition", + "plotsMappingColor", + "plotsMappingShape", + "plotsMappingLineType", + "plotsMappingFill", + "seed", + "setSeed" + ) + ) + + jaspResults[["plots"]] <- plots + plots$status <- "running" + + # stop with message if there is no random effects grouping factor selected + if (length(options$plotsAgregatedOver) == 0) { + plots$setError( + gettext("At least one random effects grouping factor needs to be selected in field 'Background data show'.") + ) + return() + } + if (all( + !c( + options$plotsMappingColor, + options$plotsMappingShape, + options$plotsMappingLineType, + options$plotsMappingFill + ) + )) { + plots$setError( + gettext("Factor levels need to be distinguished by at least one feature. Please, check one of the 'Distinguish factor levels' options.") + ) + return() + } + + # select geom + if (options$plotsGeom %in% c("geom_jitter", "geom_violin", "geom_boxplot", "geom_count")) { + geom_package <- "ggplot2" + } else if (options$plotsGeom == "geom_beeswarm") { + geom_package <- "ggbeeswarm" + } else if (options$plotsGeom == "geom_boxjitter") { + geom_package <- "ggpol" + } + + # select mapping + mapping <- + c("color", "shape", "linetype", "fill")[c( + options$plotsMappingColor, + options$plotsMappingShape, + options$plotsMappingLineType, + options$plotsMappingFill + )] + if (length(mapping) == 0) + mapping <- "" + + # specify data_arg + if (options$plotsGeom == "geom_jitter") { + data_arg <- list( + position = + ggplot2::position_jitterdodge( + jitter.width = options$plotJitterWidth, + jitter.height = options$plotJitterHeight, + dodge.width = options$plotDodge + ) + ) + } else if (options$plotsGeom == "geom_violin") { + data_arg <- list(width = options$plotGeomWidth) + } else if (options$plotsGeom == "geom_boxplot") { + data_arg <- list(width = options$plotGeomWidth) + } else if (options$plotsGeom == "geom_count") { + data_arg <- list() + } else if (options$plotsGeom == "geom_beeswarm") { + data_arg <- list(dodge.width = options$plotDodge) + } else if (options$plotsGeom == "geom_boxjitter") { + data_arg <- list( + width = options$plotGeomWidth, + jitter.width = options$plotJitterWidth, + jitter.height = options$plotJitterHeight, + outlier.intersect = TRUE + ) + } + if (options$plotsBackgroundColor != "none" && options$plotsGeom != "geom_jitter" && "color" %in% mapping) + data_arg$color <- options$plotsBackgroundColor + + # fixing afex issues with bootstrap and LRT type II SS - hopefully removeable in the future + if (type %in% c("LMM", "GLMM")) + if (options$method %in% c("LRT", "PB") && options$type == 2) + model <- model$full_model[[length(model$full_model)]] + + .setSeedJASP(options) + p <- tryCatch( + afex::afex_plot( + model, + dv = .v(options$dependentVariable), + x = .v(unlist(options$plotsX)), + trace = if (length(options$plotsTrace) != 0) .v(unlist(options$plotsTrace)), + panel = if (length(options$plotsPanel) != 0) .v(unlist(options$plotsPanel)), + id = .v(options$plotsAgregatedOver), + data_geom = getFromNamespace(options$plotsGeom, geom_package), + mapping = mapping, + error = options$plotsCImethod, + error_level = options$plotsCIwidth, + data_alpha = options$plotAlpha, + data_arg = if (length(data_arg) != 0) data_arg, + error_arg = list( + width = 0, + size = .5 * options$plotRelativeSize + ), + point_arg = list(size = 1.5 * options$plotRelativeSize), + line_arg = list(size = .5 * options$plotRelativeSize), + legend_title = paste(.unv(unlist(options$plotsTrace)), collapse = "\n"), + dodge = options$plotDodge + ), + error = function(e) + e + ) + + if (any(class(p) %in% c("simpleError", "error"))) { + plots$setError(p$message) + return() + } + + if (options$plotsGeom == "geom_violin" && (length(options$plotsAgregatedOver) == 1 && length(unique(dataset[, .v(options$plotsAgregatedOver)])) < 3)) { + plots$setError(gettext("Violin geom requires that the random effects grouping factors has at least 3 levels.")) + return() + } + + # fix the axis + p <- .mmFixPlotAxis(p) - model <- jaspResults[["mmModel"]]$object$model - - # automatic size specification will somewhat work unless there is more than 2 variables in panel - height <- 350 - width <- 150 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, .v(x)])) / 2)) - - if (length(options$plotsPanel) > 0) { - width <- - width * length(unique(dataset[, .v(unlist(options$plotsPanel)[1])])) - } else if (length(options$plotsPanel) > 1) { - height <- - height * length(unique(dataset[, .v(unlist(options$plotsPanel)[2])])) - } - if (options$plotLegendPosition %in% c("bottom", "top")) { - height <- height + 50 - } else if (options$plotLegendPosition %in% c("left", "right")) { - width <- width + 100 - } - width <- width + 150 - - plots <- createJaspPlot(title = gettext("Plot"), width = width, height = height) - - plots$position <- 5 - switch(type, - LMM = dependencies <- .mmDependenciesLMM, - GLMM = dependencies <- .mmDependenciesGLMM, - BLMM = dependencies <- .mmDependenciesBLMM, - BGLMM = dependencies <- .mmDependenciesBGLMM + # fix names of the variables + p <- p + ggplot2::labs(x = unlist(options$plotsX), y = options$dependentVariable) + + # add theme + if (options$plotsTheme == "JASP") { + + p <- jaspGraphs::themeJasp(p, legend.position = options$plotLegendPosition) + + } else if (options$plotsTheme != "JASP") { + + p <- p + switch( + options$plotsTheme, + "theme_bw" = ggplot2::theme_bw() + ggplot2::theme(legend.position = "bottom"), + "theme_light" = ggplot2::theme_light() + ggplot2::theme(legend.position = "bottom"), + "theme_minimal" = ggplot2::theme_minimal() + ggplot2::theme(legend.position = "bottom"), + "theme_pubr" = jaspGraphs::themePubrRaw(legend = options$plotLegendPosition), + "theme_apa" = jaspGraphs::themeApaRaw(legend.pos = switch( + options$plotLegendPosition, + "none" = "none", + "botom" = "bottommiddle", + "right" = "bottomright", + "top" = "topmiddle", + "left" = "bottomleft" + )) ) - plots$dependOn( + p <- p + ggplot2::theme( + legend.text = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), + legend.title = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), + axis.text = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), + axis.title = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), + legend.position = options$plotLegendPosition + ) + + } + + + plots$plotObject <- p + + if (options$plotsEstimatesTable) { + plotData <- afex::afex_plot( + model, + x = .v(unlist(options$plotsX)), + dv = .v(options$dependentVariable), + trace = if (length(options$plotsTrace) != 0) + .v(unlist(options$plotsTrace)), + panel = if (length(options$plotsPanel) != 0) + .v(unlist(options$plotsPanel)), + id = .v(options$plotsAgregatedOver), + data_geom = getFromNamespace(options$plotsGeom, geom_package), + error = options$plotsCImethod, + error_level = options$plotsCIwidth, + return = "data" + )$means + + + EstimatesTable <- + createJaspTable(title = gettext("Estimated Means and Confidence Intervals")) + EstimatesTable$position <- 5 + EstimatesTable$dependOn( c( dependencies, "plotsX", "plotsTrace", "plotsPanel", "plotsAgregatedOver", - "plotsGeom", - "plotsTrace", - "plotsPanel", - "plotsTheme", "plotsCIwidth", "plotsCImethod", - "plotAlpha", - "plotJitterWidth", - "plotJitterHeight", - "plotGeomWidth", - "plotDodge", - "plotsBackgroundColor", - "plotRelativeSize", - "plotRelativeSizeText", - "plotLegendPosition", - "plotsMappingColor", - "plotsMappingShape", - "plotsMappingLineType", - "plotsMappingFill", "seed", - "setSeed" + "setSeed", + "plotsEstimatesTable" ) ) - jaspResults[["plots"]] <- plots - plots$status <- "running" - # stop with message if there is no random effects grouping factor selected - if (length(options$plotsAgregatedOver) == 0) { - plots$setError( - gettext("At least one random effects grouping factor needs to be selected in field 'Background data show'.") - ) - return() + for (v in attr(plotData, "pri.vars")) { + EstimatesTable$addColumnInfo(name = v, + title = .unv(v), + type = "string") } - if (all( - !c( - options$plotsMappingColor, - options$plotsMappingShape, - options$plotsMappingLineType, - options$plotsMappingFill - ) - )) { - plots$setError( - gettext("Factor levels need to be distinguished by at least one feature. Please, check one of the 'Distinguish factor levels' options.") - ) - return() + + for (v in options$marginalMeans) { + } - - # select geom - if (options$plotsGeom %in% c("geom_jitter", "geom_violin", "geom_boxplot", "geom_count")) { - geom_package <- "ggplot2" - } else if (options$plotsGeom == "geom_beeswarm") { - geom_package <- "ggbeeswarm" - } else if (options$plotsGeom == "geom_boxjitter") { - geom_package <- "ggpol" - } - - # select mapping - mapping <- - c("color", "shape", "linetype", "fill")[c( - options$plotsMappingColor, - options$plotsMappingShape, - options$plotsMappingLineType, - options$plotsMappingFill - )] - if (length(mapping) == 0) - mapping <- "" - - # specify data_arg - if (options$plotsGeom == "geom_jitter") { - data_arg <- list( - position = - ggplot2::position_jitterdodge( - jitter.width = options$plotJitterWidth, - jitter.height = options$plotJitterHeight, - dodge.width = options$plotDodge - ) + + EstimatesTable$addColumnInfo(name = "mean", + title = gettext("Mean"), + type = "number") + if (options$plotsCImethod != "none") { + EstimatesTable$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) ) - } else if (options$plotsGeom == "geom_violin") { - data_arg <- list(width = options$plotGeomWidth) - } else if (options$plotsGeom == "geom_boxplot") { - data_arg <- list(width = options$plotGeomWidth) - } else if (options$plotsGeom == "geom_count") { - data_arg <- list() - } else if (options$plotsGeom == "geom_beeswarm") { - data_arg <- list(dodge.width = options$plotDodge) - } else if (options$plotsGeom == "geom_boxjitter") { - data_arg <- list( - width = options$plotGeomWidth, - jitter.width = options$plotJitterWidth, - jitter.height = options$plotJitterHeight, - outlier.intersect = TRUE + EstimatesTable$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) ) } - if (options$plotsBackgroundColor != "none" && options$plotsGeom != "geom_jitter" && "color" %in% mapping) - data_arg$color <- options$plotsBackgroundColor - - # fixing afex issues with bootstrap and LRT type II SS - hopefully removeable in the future - if (type %in% c("LMM", "GLMM")) - if (options$method %in% c("LRT", "PB") && options$type == 2) - model <- model$full_model[[length(model$full_model)]] - - .setSeedJASP(options) - p <- tryCatch( - afex::afex_plot( - model, - dv = .v(options$dependentVariable), - x = .v(unlist(options$plotsX)), - trace = if (length(options$plotsTrace) != 0) .v(unlist(options$plotsTrace)), - panel = if (length(options$plotsPanel) != 0) .v(unlist(options$plotsPanel)), - id = .v(options$plotsAgregatedOver), - data_geom = getFromNamespace(options$plotsGeom, geom_package), - mapping = mapping, - error = options$plotsCImethod, - error_level = options$plotsCIwidth, - data_alpha = options$plotAlpha, - data_arg = if (length(data_arg) != 0) data_arg, - error_arg = list( - width = 0, - size = .5 * options$plotRelativeSize - ), - point_arg = list(size = 1.5 * options$plotRelativeSize), - line_arg = list(size = .5 * options$plotRelativeSize), - legend_title = paste(.unv(unlist(options$plotsTrace)), collapse = "\n"), - dodge = options$plotDodge - ), - error = function(e) - e - ) - - if (any(class(p) %in% c("simpleError", "error"))) { - plots$setError(p$message) - return() + + jaspResults[["EstimatesTable"]] <- EstimatesTable + + for (i in 1:nrow(plotData)) { + tempRow <- list() + for (v in attr(plotData, "pri.vars")) { + tempRow[v] <- as.character(plotData[i, v]) + } + + tempRow$mean <- plotData[i, "y"] + if (options$plotsCImethod != "none") { + tempRow$lowerCI <- plotData[i, "lower"] + tempRow$upperCI <- plotData[i, "upper"] + } + + EstimatesTable$addRows(tempRow) } - if (options$plotsGeom == "geom_violin" && (length(options$plotsAgregatedOver) == 1 && length(unique(dataset[, .v(options$plotsAgregatedOver)])) < 3)) { - plots$setError(gettext("Violin geom requires that the random effects grouping factors has at least 3 levels.")) - return() + + } + + return() +} +.mmMarginalMeans <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["EMMresults"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + # deal with continuous predictors + at <- NULL + for (var in unlist(options$marginalMeans)) { + if (typeof(dataset[, .v(var)]) == "double") { + at[[.v(var)]] <- + c( + mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$marginalMeansSD * + sd(dataset[, .v(var)], na.rm = TRUE) + ) } - - # fix the axis - p <- .mmFixPlotAxis(p) - - # fix names of the variables - p <- p + ggplot2::labs(x = unlist(options$plotsX), y = options$dependentVariable) - - # add theme - if (options$plotsTheme == "JASP") { - - p <- jaspGraphs::themeJasp(p, legend.position = options$plotLegendPosition) - - } else if (options$plotsTheme != "JASP") { - - p <- p + switch( - options$plotsTheme, - "theme_bw" = ggplot2::theme_bw() + ggplot2::theme(legend.position = "bottom"), - "theme_light" = ggplot2::theme_light() + ggplot2::theme(legend.position = "bottom"), - "theme_minimal" = ggplot2::theme_minimal() + ggplot2::theme(legend.position = "bottom"), - "theme_pubr" = jaspGraphs::themePubrRaw(legend = options$plotLegendPosition), - "theme_apa" = jaspGraphs::themeApaRaw(legend.pos = switch( - options$plotLegendPosition, - "none" = "none", - "botom" = "bottommiddle", - "right" = "bottomright", - "top" = "topmiddle", - "left" = "bottomleft" - )) + } + + # compute the results + if (type == "LMM") { + emmeans::emm_options(pbkrtest.limit = if (options$marginalMeansOverride) + Inf, + mmrTest.limit = if (options$marginalMeansOverride) + Inf) + } + emm <- emmeans::emmeans( + object = model, + specs = .v(unlist(options$marginalMeans)), + at = at, + options = list(level = options$marginalMeansCIwidth), + lmer.df = if (type == "LMM") + options$marginalMeansDf + else if (type == "GLMM" && + options$family == "gaussian" && + options$link == "identity") + "asymptotic", + type = if (type %in% c("GLMM", "BGLMM")) + if (options$marginalMeansResponse) + "response" + ) + + emmTable <- as.data.frame(emm) + if (type %in% c("LMM", "GLMM")) { + if (options$marginalMeansCompare) { + emmTest <- + as.data.frame(emmeans::test(emm, null = options$marginalMeansCompareTo)) + } + } + + EMMsummary <- createJaspTable(title = gettext("Estimated Marginal Means")) + EMMresults <- createJaspState() + + EMMsummary$position <- 7 + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") + } else if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") + } + if (type %in% c("LMM", "GLMM")) { + dependenciesAdd <- + c( + "marginalMeans", + "marginalMeansSD", + "marginalMeansCompare", + "marginalMeansCompareTo", + "marginalMeansCIwidth", + "pvalVS", + "marginalMeansContrast" ) - - p <- p + ggplot2::theme( - legend.text = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), - legend.title = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), - axis.text = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), - axis.title = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), - legend.position = options$plotLegendPosition + } else{ + dependenciesAdd <- + c( + "marginalMeans", + "marginalMeansSD", + "marginalMeansCIwidth", + "marginalMeansContrast" ) + } + if (type == "LMM") { + dependenciesAdd <- + c(dependenciesAdd, + "marginalMeansOverride", + "marginalMeansDf") + } + EMMsummary$dependOn(c(dependencies, dependenciesAdd)) + EMMresults$dependOn(c(dependencies, dependenciesAdd)) + if (options$marginalMeansContrast) { + EMMsummary$addColumnInfo(name = "number", + title = gettext("Row"), + type = "integer") + } + for (v in unlist(options$marginalMeans)) { + if (typeof(dataset[, .v(v)]) == "double") { + EMMsummary$addColumnInfo(name = .v(v), + title = .unv(v), + type = "number") + } else{ + EMMsummary$addColumnInfo(name = .v(v), + title = .unv(v), + type = "string") } - - - plots$plotObject <- p - - if (options$plotsEstimatesTable) { - plot_data <- afex::afex_plot( - model, - x = .v(unlist(options$plotsX)), - dv = .v(options$dependentVariable), - trace = if (length(options$plotsTrace) != 0) - .v(unlist(options$plotsTrace)), - panel = if (length(options$plotsPanel) != 0) - .v(unlist(options$plotsPanel)), - id = .v(options$plotsAgregatedOver), - data_geom = getFromNamespace(options$plotsGeom, geom_package), - error = options$plotsCImethod, - error_level = options$plotsCIwidth, - return = "data" - )$means - - - EstimatesTable <- - createJaspTable(title = gettext("Estimated Means and Confidence Intervals")) - EstimatesTable$position <- 5 - EstimatesTable$dependOn( - c( - dependencies, - "plotsX", - "plotsTrace", - "plotsPanel", - "plotsAgregatedOver", - "plotsCIwidth", - "plotsCImethod", - "seed", - "setSeed", - "plotsEstimatesTable" - ) + } + + if (type %in% c("LMM", "GLMM")) { + EMMsummary$addColumnInfo(name = "estimate", + title = gettext("Estimate"), + type = "number") + EMMsummary$addColumnInfo(name = "se", + title = gettext("SE"), + type = "number") + if(type == "LMM"){ + if(options$marginalMeansDf != "asymptotic"){ + EMMsummary$addColumnInfo(name = "df", + title = gettext("df"), + type = "number") + } + } + EMMsummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) + ) + EMMsummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) + ) + if (options$marginalMeansCompare) { + EMMsummary$addColumnInfo( + name = "stat", + title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), + type = "number" ) - - - for (v in attr(plot_data, "pri.vars")) { - EstimatesTable$addColumnInfo(name = v, - title = .unv(v), - type = "string") - } - - for (v in options$marginalMeans) { - - } - - EstimatesTable$addColumnInfo(name = "mean", - title = gettext("Mean"), - type = "number") - if (options$plotsCImethod != "none") { - EstimatesTable$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) - ) - EstimatesTable$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) - ) + EMMsummary$addColumnInfo(name = "pval", + title = gettext("p"), + type = "pvalue") + EMMsummary$addFootnote(.mmMessageTestNull(options$marginalMeansCompareTo), + symbol = "\u2020", colNames = "pval") + + if (options$pvalVS) { + EMMsummary$addColumnInfo(name = "pvalVS", + title = gettext("VS-MPR"), + type = "number") + EMMsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") + } + } + } else if (type %in% c("BLMM", "BGLMM")) { + EMMsummary$addColumnInfo(name = "estimate", + title = gettext("Median"), + type = "number") + EMMsummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) + ) + EMMsummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) + ) + } + + jaspResults[["EMMsummary"]] <- EMMsummary + + for (i in 1:nrow(emmTable)) { + tempRow <- list() + + if (options$marginalMeansContrast) { + tempRow$number <- i + } + + for (v in unlist(options$marginalMeans)) { + if (typeof(dataset[, .v(v)]) == "double") { + tempRow[.v(v)] <- emmTable[i, .v(v)] + } else{ + tempRow[.v(v)] <- as.character(emmTable[i, .v(v)]) } + } - jaspResults[["EstimatesTable"]] <- EstimatesTable - - for (i in 1:nrow(plot_data)) { - temp_row <- list() - for (v in attr(plot_data, "pri.vars")) { - temp_row[v] <- as.character(plot_data[i, v]) + if (type %in% c("LMM", "GLMM")) { + # the estimate is before SE (names change for GLMM) + tempRow$estimate <- + emmTable[i, grep("SE", colnames(emmTable)) - 1] + tempRow$se <- emmTable[i, "SE"] + if(type == "LMM"){ + if(options$marginalMeansDf != "asymptotic"){ + tempRow$df <- emmTable[i, "df"] } - - temp_row$mean <- plot_data[i, "y"] - if (options$plotsCImethod != "none") { - temp_row$lowerCI <- plot_data[i, "lower"] - temp_row$upperCI <- plot_data[i, "upper"] + } + if (options$marginalMeansCompare) { + tempRow$stat <- emmTest[i, grep("ratio", colnames(emmTest))] + tempRow$pval <- emmTest[i, "p.value"] + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) } - - EstimatesTable$addRows(temp_row) } - + } else if (type %in% c("BLMM", "BGLMM")) { + tempRow$estimate <- emmTable[i, ncol(emmTable) - 2] + } + + tempRow$lowerCI <- emmTable[i, ncol(emmTable) - 1] + tempRow$upperCI <- emmTable[i, ncol(emmTable)] + + + EMMsummary$addRows(tempRow) + } + + if (length(emm@misc$avgd.over) != 0) { + EMMsummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) + } + # add warning message + if (type == "LMM") { + if (options$marginalMeansDf != attr(emm@dffun, "mesg")) { + EMMsummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) } - + } + if (type %in% c("GLMM","BGLMM")) { + EMMsummary$addFootnote( + ifelse( + options$marginalMeansResponse, + .mmMessageResponse, + .mmMessageNotResponse + ) + ) + } + + + + + object <- list(emm = emm, + emmTable = emmTable) + EMMresults$object <- object + jaspResults[["EMMresults"]] <- EMMresults + + return() +} +.mmTrends <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["contrasts_Trends"]])) return() + + model <- jaspResults[["mmModel"]]$object$model + + # deal with continuous predictors + at <- NULL + for (var in unlist(options$trendsVariables)) { + if (typeof(dataset[, .v(var)]) == "double") { + at[[.v(var)]] <- + c( + mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$trendsSD * + sd(dataset[, .v(var)], na.rm = TRUE) + ) + } } -.mmMarginalMeans <- function(jaspResults, dataset, options, type = "LMM") { - if (!is.null(jaspResults[["EMMresults"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - # deal with continuous predictors - at <- NULL - for (var in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(var)]) == "double") { - at[[.v(var)]] <- - c( - mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$marginalMeansSD * - sd(dataset[, .v(var)], na.rm = TRUE) - ) + + # compute the results + if (type %in% c("LMM")) { + emmeans::emm_options(pbkrtest.limit = if (options$trendsOverride) + Inf, + mmrTest.limit = if (options$trendsOverride) + Inf) + } + + # TODO: deal with the emtrends scoping problems + trendsCI <<- options$trendsCIwidth + trendsAt <<- at + trendsType <<- if (type == "LMM" || (type == "GLMM" && + options$family == "gaussian" && + options$link == "identity")) + "LMM" + else + type + trendsDataset <<- dataset + trendsModel <<- model + trendsDf <<- + if (type == "LMM") + options$trendsDf + else if (type == "GLMM" && + options$family == "gaussian" && + options$link == "identity") + "asymptotic" + + emm <- emmeans::emtrends( + object = trendsModel, + data = trendsDataset, + specs = .v(unlist(options$trendsVariables)), + var = .v(unlist(options$trendsTrend)), + at = trendsAt, + options = list(level = trendsCI), + lmer.df = if (trendsType == "LMM") + trendsDf + ) + emmTable <- as.data.frame(emm) + if (type %in% c("LMM", "GLMM")) { + if (options$trendsCompare) { + emmTest <- + as.data.frame(emmeans::test(emm, null = options$trendsCompareTo)) + } + } + + trendsSummary <- createJaspTable(title = gettext("Estimated Trends")) + EMTresults <- createJaspState() + + trendsSummary$position <- 9 + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- c(.mmDependenciesGLMM) + } else if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- c(.mmDependenciesBGLMM) + } + if (type %in% c("LMM", "GLMM")) { + dependenciesAdd <- + c( + "trendsVariables", + "trendsTrend", + "trendsSD", + "trendsCompare", + "trendsCompareTo", + "trendsCIwidth", + "pvalVS", + "trendsContrast" + ) + } else{ + dependenciesAdd <- + c( + "trendsVariables", + "trendsTrend", + "trendsSD", + "trendsCIwidth", + "trendsContrast" + ) + } + if (type == "LMM") { + dependenciesAdd <- + c(dependenciesAdd, "trendsDf", "trendsOverride") + } + trendsSummary$dependOn(c(dependencies, dependenciesAdd)) + EMTresults$dependOn(c(dependencies, dependenciesAdd)) + + if (options$trendsContrast) { + trendsSummary$addColumnInfo(name = "number", + title = gettext("Row"), + type = "integer") + } + + trendsVarNames <- colnames(emmTable)[1:(grep(".trend", colnames(emmTable), fixed = TRUE) - 1)] + + for (v in trendsVarNames) { + if (typeof(dataset[, .v(v)]) == "double") { + trendsSummary$addColumnInfo(name = v, + title = .unv(v), + type = "number") + } else{ + trendsSummary$addColumnInfo(name = v, + title = .unv(v), + type = "string") + } + } + trendsSummary$addColumnInfo( + name = "slope", + title = gettextf("%s (slope)",unlist(options$trendsTrend)), + type = "number" + ) + if (type %in% c("LMM", "GLMM")) { + trendsSummary$addColumnInfo(name = "se", + title = gettext("SE"), + type = "number") + if(type == "LMM"){ + if(options$trendsDf != "asymptotic"){ + trendsSummary$addColumnInfo(name = "df", + title = gettext("df"), + type = "number") } } - - # compute the results - if (type == "LMM") { - emmeans::emm_options(pbkrtest.limit = if (options$marginalMeansOverride) - Inf, - mmrTest.limit = if (options$marginalMeansOverride) - Inf) - } - emm <- emmeans::emmeans( - object = model, - specs = .v(unlist(options$marginalMeans)), - at = at, - options = list(level = options$marginalMeansCIwidth), - lmer.df = if (type == "LMM") - options$marginalMeansDf - else if (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity") - "asymptotic", - type = if (type %in% c("GLMM", "BGLMM")) - if (options$marginalMeansResponse) - "response" + trendsSummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) + ) + trendsSummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) + ) + if (options$trendsCompare) { + trendsSummary$addColumnInfo( + name = "stat", + title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), + type = "number" + ) + trendsSummary$addColumnInfo(name = "pval", + title = gettext("p"), + type = "pvalue") + trendsSummary$addFootnote(.mmMessageTestNull(options$trendsCompareTo), symbol = "\u2020", colNames = "pval") + + if (options$pvalVS) { + trendsSummary$addColumnInfo(name = "pvalVS", + title = gettext("VS-MPR"), + type = "number") + trendsSummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") + } + } + } else if (type %in% c("BLMM", "BGLMM")) { + trendsSummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) + ) + trendsSummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) ) - - emm_table <- as.data.frame(emm) + } + + jaspResults[["trendsSummary"]] <- trendsSummary + + + for (i in 1:nrow(emmTable)) { + tempRow <- list() + + if (options$trendsContrast) { + tempRow$number <- i + } + + for (vi in 1:length(trendsVarNames)) { + if (typeof(dataset[, .v(trendsVarNames[vi])]) == "double") { + tempRow[trendsVarNames[vi]] <- emmTable[i, vi] + } else{ + tempRow[trendsVarNames[vi]] <- + as.character(emmTable[i, vi]) + } + } + tempRow$slope <- emmTable[i, length(trendsVarNames) + 1] + if (type %in% c("LMM", "GLMM")) { - if (options$marginalMeansCompare) { - emm_test <- - as.data.frame(emmeans::test(emm, null = options$marginalMeansCompareTo)) + # the estimate is before SE (names change for GLMM) + tempRow$se <- emmTable[i, "SE"] + if(type == "LMM"){ + if(options$trendsDf != "asymptotic"){ + tempRow$df <- emmTable[i, "df"] + } + } + + if (options$trendsCompare) { + tempRow$stat <- emmTest[i, grep("ratio", colnames(emmTest))] + tempRow$pval <- emmTest[i, "p.value"] + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) + } } } - - EMMsummary <- createJaspTable(title = gettext("Estimated Marginal Means")) - EMMresults <- createJaspState() - - EMMsummary$position <- 7 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") + + tempRow$lowerCI <- emmTable[i, ncol(emmTable) - 1] + tempRow$upperCI <- emmTable[i, ncol(emmTable)] + + + trendsSummary$addRows(tempRow) + } + + + if (length(emm@misc$avgd.over) != 0) { + trendsSummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) + } + # add warning message + if (type == "LMM") { + if (options$trendsDf != attr(emm@dffun, "mesg")) { + # TODO: for GLMM + trendsSummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) } + } + if (type == "GLMM") { + trendsSummary$addFootnote(.mmMessageNotResponse) + } + + + + + object <- list(emm = emm, + emmTable = emmTable) + EMTresults$object <- object + + jaspResults[["EMTresults"]] <- EMTresults + + return() +} +.mmContrasts <- function(jaspResults, options, type = "LMM", what = "Means") { + if (what == "Means") { + if (!is.null(jaspResults[["contrasts_Means"]])) + return() + emm <- jaspResults[["EMMresults"]]$object$emm + emmTable <- jaspResults[["EMMresults"]]$object$emmTable + } else if (what == "Trends") { + if (!is.null(jaspResults[["contrasts_Trends"]])) + return() + emm <- jaspResults[["EMTresults"]]$object$emm + emmTable <- jaspResults[["EMTresults"]]$object$emmTable + } + + + EMMCsummary <- createJaspTable(title = gettext("Contrasts")) + + EMMCsummary$position <- ifelse(what == "Means", 8, 10) + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- + c(.mmDependenciesGLMM, if (what == "Means") + "marginalMeansResponse") + } else if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- + c(.mmDependenciesBGLMM, if (what == "Means") + "marginalMeansResponse") + } + if (what == "Means") { if (type %in% c("LMM", "GLMM")) { - dependencies_add <- + dependenciesAdd <- c( "marginalMeans", + "marginalMeansDf", "marginalMeansSD", "marginalMeansCompare", "marginalMeansCompareTo", + "marginalMeansContrast", "marginalMeansCIwidth", "pvalVS", - "marginalMeansContrast" + "marginalMeansOverride", + "Contrasts", + "marginalMeansAdjustment" ) } else{ - dependencies_add <- + dependenciesAdd <- c( "marginalMeans", "marginalMeansSD", + "marginalMeansContrast", "marginalMeansCIwidth", - "marginalMeansContrast" + "Contrasts" ) } - if (type == "LMM") { - dependencies_add <- - c(dependencies_add, - "marginalMeansOverride", - "marginalMeansDf") - } - EMMsummary$dependOn(c(dependencies, dependencies_add)) - EMMresults$dependOn(c(dependencies, dependencies_add)) - - if (options$marginalMeansContrast) { - EMMsummary$addColumnInfo(name = "number", - title = gettext("Row"), - type = "integer") - } - for (v in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(v)]) == "double") { - EMMsummary$addColumnInfo(name = .v(v), - title = .unv(v), - type = "number") - } else{ - EMMsummary$addColumnInfo(name = .v(v), - title = .unv(v), - type = "string") - } - } - + } else if (what == "Trends") { if (type %in% c("LMM", "GLMM")) { - EMMsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMsummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - if(type == "LMM"){ - if(options$marginalMeansDf != "asymptotic"){ - EMMsummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - } - } - EMMsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) - ) - EMMsummary$addColumnInfo( + dependenciesAdd <- + c( + "trendsVariables", + "trendsTrend", + "trendsDf", + "trendsSD", + "trendsCompare", + "trendsCompareTo", + "trendsContrast", + "trendsContrasts", + "trendsCIwidth", + "pvalVS", + "trendsOverride", + "trendsAdjustment" + ) + } else{ + dependenciesAdd <- + c( + "trendsVariables", + "trendsTrend", + "trendsSD", + "trendsCIwidth", + "trendsContrast", + "trendsContrasts" + ) + } + } + + EMMCsummary$dependOn(c(dependencies, dependenciesAdd)) + + + if (type %in% c("LMM", "GLMM")) { + EMMCsummary$addColumnInfo(name = "contrast", + title = "", + type = "string") + EMMCsummary$addColumnInfo(name = "estimate", + title = gettext("Estimate"), + type = "number") + EMMCsummary$addColumnInfo(name = "se", + title = gettext("SE"), + type = "number") + EMMCsummary$addColumnInfo(name = "df", + title = gettext("df"), + type = "number") + EMMCsummary$addColumnInfo(name = "stat", + title = gettext("z"), + type = "number") + EMMCsummary$addColumnInfo(name = "pval", + title = gettext("p"), + type = "pvalue") + if (options$pvalVS) { + EMMCsummary$addColumnInfo(name = "pvalVS", + title = gettext("VS-MPR"), + type = "number") + EMMCsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") + } + } else if (type %in% c("BLMM", "BGLMM")) { + EMMCsummary$addColumnInfo(name = "contrast", + title = "", + type = "string") + EMMCsummary$addColumnInfo(name = "estimate", + title = gettext("Estimate"), + type = "number") + EMMCsummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf( + "%s%% HPD", + 100 * if (what == "Means") + options$marginalMeansCIwidth + else + options$trendsCIwidth + ) + ) + EMMCsummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf( + "%s%% HPD", + 100 * if (what == "Means") + options$marginalMeansCIwidth + else + options$trendsCIwidth + ) + ) + } + + # Columns have been specified, show to user + jaspResults[[paste0("contrasts_", what)]] <- EMMCsummary + + if (what == "Means") { + selectedContrasts <- options$Contrasts + selectedAdjustment <- options$marginalMeansAdjustment + + if (type %in% c("GLMM", "BGLMM")) { + selectedResponse <- options$marginalMeansResponse + } + + + } else if (what == "Trends") { + selectedContrasts <- options$trendsContrasts + selectedAdjustment <- options$trendsAdjustment + } + + contrs <- list() + i <- 0 + for (cont in selectedContrasts[sapply(selectedContrasts, function(x) + x$isContrast)]) { + if (all(cont$values == 0)) + next + i <- i + 1 + contrs[[cont$name]] <- + unname(sapply(cont$values, function(x) + eval(parse(text = x)))) + } + if (length(contrs) == 0) { + return() + } + + + # take care of the scale + if (type %in% c("LMM", "BLMM") || what == "Trends") { + emmContrast <- tryCatch( + as.data.frame( + emmeans::contrast(emm, contrs, + adjust = if (type %in% c("LMM", "GLMM")) + selectedAdjustment) + ), + error = function(e) + e + ) + } else if (type %in% c("GLMM", "BGLMM")) { + if (selectedResponse) { + emmContrast <- tryCatch( + as.data.frame( + emmeans::contrast( + emmeans::regrid(emm), + contrs, + adjust = if (type == "GLMM") + selectedAdjustment + ) + ), + error = function(e) + e + ) + } else{ + emmContrast <- tryCatch( + as.data.frame( + emmeans::contrast(emm, contrs, + adjust = if (type == "GLMM") + selectedAdjustment) + ), + error = function(e) + e + ) + } + } + + if (length(emmContrast) == 2) { + EMMCsummary$setError(emmContrast$message) + return() + } + + # fix the title name if there is a t-stats + if (type %in% c("LMM", "GLMM")) + if (colnames(emmContrast)[5] == "t.ratio") + EMMCsummary$setColumnTitle("stat", gettext("t")) + if (type %in% c("GLMM", "BGLMM")) { + if (type == "GLMM") { + tempEstName <- colnames(emmContrast)[ncol(emmContrast) - 4] + } else if (type == "BGLMM") { + tempEstName <- colnames(emmContrast)[ncol(emmContrast) - 2] + } + if (tempEstName == "odds.ratio") { + EMMCsummary$setColumnTitle("estimate", gettext("Odds Ratio")) + } else if (tempEstName == "ratio") { + EMMCsummary$setColumnTitle("estimate", gettext("Ratio")) + } else if (tempEstName == "estimate") { + EMMCsummary$setColumnTitle("estimate", gettext("Estimate")) + } else{ + EMMCsummary$setColumnTitle("estimate", tempEstName) + } + } + + for (i in 1:nrow(emmContrast)) { + if (type %in% c("LMM", "GLMM")) { + tempRow <- list( + contrast = names(contrs)[i], + estimate = emmContrast[i, ncol(emmContrast) - 4], + se = emmContrast[i, "SE"], + df = emmContrast[i, "df"], + stat = emmContrast[i, ncol(emmContrast) - 1], + pval = emmContrast[i, "p.value"] + ) + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) + } + + EMMCsummary$addFootnote(.messagePvalAdjustment(selectedAdjustment), symbol = "\u2020", colNames = "pval") + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) + } + + } else if (type %in% c("BLMM", "BGLMM")) { + tempRow <- list( + contrast = names(contrs)[i], + estimate = emmContrast[i, ncol(emmContrast) - 2], + lowerCI = emmContrast[i, "lower.HPD"], + upperCI = emmContrast[i, "upper.HPD"] + ) + } + + + if (type %in% c("GLMM", "BGLMM") && what == "Means") { + if (!selectedResponse) { + EMMCsummary$addFootnote(.mmMessageNotResponse) + } else{ + EMMCsummary$addFootnote(.mmMessageResponse) + } + } + + + EMMCsummary$addRows(tempRow) + + } +} + + +# specific Bayesian +.mmReadDataB <- function(dataset, options, type = "BLMM") { + if (!is.null(dataset)) { + return(dataset) + } else{ + if (type == "LMM") { + return( + readDataSetToEnd( + columns.as.numeric = options$dependentVariable, + columns.as.factor = c(options$fixedVariables, options$randomVariables) + ) + ) + } else if (type == "GLMM") { + if (options$dependentVariableAggregation == "") { + return(readDataSetToEnd( + columns = c( + options$dependentVariable, + options$fixedVariables, + options$randomVariables + ) + )) + } else{ + return(readDataSetToEnd( + columns = c( + options$dependentVariable, + options$fixedVariables, + options$randomVariables, + options$dependentVariableAggregation + ) + )) + } + } + } +} +.mmFitModelB <- function(jaspResults, dataset, options, type = "BLMM") { + # hopefully fixing the random errors + contr.bayes <<- stanova::contr.bayes + stan_glmer <- rstanarm::stan_glmer + if (!is.null(jaspResults[["mmModel"]])) + return() + + mmModel <- createJaspState() + + + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + mmModel$dependOn(dependencies) + + modelFormula <- .mmModelFormula(options, dataset) + + if (type == "BLMM") { + model <- tryCatch(stanova::stanova( + formula = as.formula(modelFormula$modelFormula), + check_contrasts = "contr.bayes", + data = dataset, + chains = options$chains, + iter = options$iteration, + warmup = options$warmup, + adapt_delta = options$adapt_delta, + control = list(maxTreedepth = options$max_treedepth), + seed = .getSeedJASP(options), + model_fun = "lmer" + ), error = function(e) e ) + + } else if (type == "BGLMM") { + # needs to be evaluated in the global environment + glmmLink <<- options$link + if (options$family == "neg_binomial_2") { + glmmFamily <<- rstanarm::neg_binomial_2(link = glmmLink) + } else if (options$family == "betar") { + glmmFamily <<- mgcv::betar(link = glmmLink) + } else if (options$family != "binomial_agg"){ + tempFamily <<- options$family + glmmFamily <<- eval(call(tempFamily, glmmLink)) + } + + # I wish there was a better way to do this + if (options$family == "binomial_agg") { + glmmWeight <<- dataset[, .v(options$dependentVariableAggregation)] + + model <- tryCatch(stanova::stanova( + formula = as.formula(modelFormula$modelFormula), + check_contrasts = "contr.bayes", + data = dataset, + chains = options$chains, + iter = options$iteration, + warmup = options$warmup, + adapt_delta = options$adapt_delta, + control = list(maxTreedepth = options$max_treedepth), + weights = glmmWeight, + family = eval(call("binomial", glmmLink)), + seed = .getSeedJASP(options), + model_fun = "glmer" + ), error = function(e) e ) + + } else{ + model <- tryCatch(stanova::stanova( + formula = as.formula(modelFormula$modelFormula), + check_contrasts = "contr.bayes", + data = dataset, + chains = options$chains, + iter = options$iteration, + warmup = options$warmup, + adapt_delta = options$adapt_delta, + control = list(maxTreedepth = options$max_treedepth), + family = glmmFamily, + seed = .getSeedJASP(options), + model_fun = "glmer" + ), error = function(e) e ) + + } + + } + + if (inherits(model, "error")) { + if (model$message == "Dropping columns failed to produce full column rank design matrix") + .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. The most likely reason for this issue is a factor / combination of factors leading to more levels than are estimable.")) + else + .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model$message)) + } + + object <- list( + model = model, + removedMe = modelFormula$removedMe, + removedTe = modelFormula$removedTe + ) + + mmModel$object <- object + jaspResults[["mmModel"]] <- mmModel + + return() +} +.mmFitStatsB <- function(jaspResults, options, type = "BLMM") { + if (!is.null(jaspResults[["fitStats"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + fitSummary <- createJaspContainer("Model summary") + fitSummary$position <- 2 + + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + + fitSummary$dependOn(c(dependencies, "fitStats")) + jaspResults[["fitSummary"]] <- fitSummary + + ### fit statistics + fitStats <- createJaspTable(title = gettext("Fit Statistics")) + fitStats$position <- 1 + + fitStats$addColumnInfo(name = "waic", title = gettext("WAIC"), type = "number") + fitStats$addColumnInfo(name = "waicSE", title = gettext("SE (WAIC)"), type = "number") + fitStats$addColumnInfo(name = "loo", title = gettext("LOO"), type = "number") + fitStats$addColumnInfo(name = "looSE", title = gettext("SE (LOO)"), type = "number") + + jaspResults[["fitSummary"]][["fitStats"]] <- fitStats + + waic <- loo::waic(model) + loo <- loo::loo(model) + + + nBadWAIC <- sum(waic$pointwise[,2] > 0.4) + nBadLOO <- length(loo::pareto_k_ids(loo, threshold = .7)) + + + if (nBadWAIC > 0) + fitStats$addFootnote(.mmMessageBadWAIC(nBadWAIC), symbol = gettext("Warning:")) + if (nBadLOO > 0) + fitStats$addFootnote(.mmMessageBadLOO(nBadLOO), symbol = gettext("Warning:")) + + + tempRow <- list( + waic = waic$estimates["waic", "Estimate"], + waicSE = waic$estimates["waic", "SE"], + loo = loo$estimates["looic", "Estimate"], + looSE = loo$estimates["looic", "SE"] + ) + + fitStats$addRows(tempRow) + + ### sample sizes + stanovaSummary <- stanova:::summary.stanova(model) + + fitSizes <- createJaspTable(title = gettext("Sample sizes")) + fitSizes$position <- 2 + + fitSizes$addColumnInfo(name = "observations", title = gettext("Observations"), type = "integer") + tempRow <- list( + observations = attr(stanovaSummary, "nobs") + ) + for (n in names(attr(stanovaSummary, "ngrps"))) { + fitSizes$addColumnInfo(name = n, title = .unv(n), type = "integer", overtitle = gettext("Levels of RE grouping factors")) + tempRow[[n]] <- attr(stanovaSummary, "ngrps")[[n]] + } + fitSizes$addRows(tempRow) + jaspResults[["fitSummary"]][["fitSizes"]] <- fitSizes + + return() +} +.mmSummaryREB <- function(jaspResults, options, type = "BLMM") { + if (!is.null(jaspResults[["REsummary"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + REsummary <- createJaspContainer(title = gettext("Variance/Correlation Estimates")) + + REsummary$position <- 4 + + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + REsummary$dependOn(c(dependencies, "showRE", "summaryCI")) + + ### keep this if we decide to change things + #modelSummary <- rstan::summary(model$stanfit, probs = c(.5-options$summaryCI/2, .5+options$summaryCI/2))$summary + #namesSummary <- rownames(modelSummary) + #re_names <- namesSummary[grepl("Sigma[", namesSummary, fixed = T)] + #re_groups <- sapply(re_names, function(x){ + # substr(x,7,regexpr(":", x, fixed = TRUE)[1]-1) + #}) + #re_summary <- modelSummary[namesSummary %in% re_names,] + #s_summary <- modelSummary[namesSummary == "sigma",] + + VarCorr <- rstanarm:::VarCorr.stanreg(model) + # go over each random effect grouping factor + for (gi in 1:length(VarCorr)) { + tempVarCorr <- VarCorr[[gi]] + + # add variance summary + REvar <- + createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) + + REvar$addColumnInfo(name = "variable", + title = gettext("Term"), + type = "string") + REvar$addColumnInfo(name = "std", + title = gettext("Std. Deviation"), + type = "number") + REvar$addColumnInfo(name = "var", + title = gettext("Variance"), + type = "number") + + tempStdDev <- attr(tempVarCorr, "stddev") + for (i in 1:length(tempStdDev)) { + if (names(tempStdDev)[i] == "(Intercept)") { + varName <- gettext("Intercept") + } else{ + varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) + } + + tempRow <- list( + variable = varName, + std = tempStdDev[i], + var = tempStdDev[i]^2 + ) + + REvar$addRows(tempRow) + } + + REvar$addFootnote(.mmMessageInterpretability) + + REsummary[[paste0("VE", gi)]] <- REvar + + + # add correlation summary + if (length(tempStdDev) > 1) { + tempCorr <- attr(tempVarCorr, "correlation") + REcor <- + createJaspTable(title = gettextf("%s: Correlation Estimates",.unv(names(VarCorr)[gi]))) + + # add columns + REcor$addColumnInfo(name = "variable", + title = gettext("Term"), + type = "string") + for (i in 1:nrow(tempCorr)) { + if (rownames(tempCorr)[i] == "(Intercept)") { + varName <- gettext("Intercept") + } else{ + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) + } + REcor$addColumnInfo(name = paste0("v", i), + title = varName, + type = "number") + } + + # fill rows + for (i in 1:nrow(tempCorr)) { + if (rownames(tempCorr)[i] == "(Intercept)") { + varName <- gettext("Intercept") + } else{ + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) + } + + tempRow <- list(variable = varName) + for (j in 1:i) { + # ncol(tempCorr) + tempRow[paste0("v", j)] <- tempCorr[i, j] + } + REcor$addRows(tempRow) + } + + REcor$addFootnote(.mmMessageInterpretability) + + REsummary[[paste0("CE", gi)]] <- REcor + + } + + } + + # add residual variance summary + REres <- + createJaspTable(title = gettext("Residual Variance Estimates")) + + REres$addColumnInfo(name = "std", title = gettext("Std. Deviation"), type = "number") + REres$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") + + jaspResults[["REsummary"]] <- REsummary + + tempRow <- list( + std = rstanarm:::sigma.stanreg(model), + var = rstanarm:::sigma.stanreg(model)^2 + ) + + REres$addRows(tempRow) + REsummary[["RES"]] <- REres + + return() +} +.mmSummaryFEB <- function(jaspResults, options, type = "BLMM") { + if (!is.null(jaspResults[["FEsummary"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + FEsummary <- createJaspTable(title = "Fixed Effects Estimates") + FEsummary$position <- 3 + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + FEsummary$dependOn(c(dependencies, "showFE", "summaryCI")) + + FEsummary$addColumnInfo(name = "term", + title = "Term", + type = "string") + FEsummary$addColumnInfo(name = "estimate", + title = "Estimate", + type = "number") + FEsummary$addColumnInfo(name = "se", + title = "SE", + type = "number") + FEsummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$summaryCI) + ) + FEsummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$summaryCI) + ) + FEsummary$addColumnInfo(name = "rhat", + title = "R-hat", + type = "number") + FEsummary$addColumnInfo(name = "neff", + title = "ESS", + type = "number") + + jaspResults[["FEsummary"]] <- FEsummary + + modelSummary <- + rstan::summary(model$stanfit, + probs = c(.5 - options$summaryCI / 2, .5 + options$summaryCI / 2))$summary + namesSummary <- rownames(modelSummary) + feSummary <- + modelSummary[!grepl("b[", namesSummary, fixed = T) & + !namesSummary %in% c("mean_PPD", "log-posterior") & + namesSummary != "sigma" & + !grepl("Sigma[", namesSummary, fixed = T), ] + + for (i in 1:nrow(feSummary)) { + if (rownames(feSummary)[i] == "(Intercept)") { + effectName <- "Intercept" + } else{ + effectName <- .mmVariableNames(rownames(feSummary)[i], options$fixedVariables) + } + + tempRow <- list( + term = effectName, + estimate = feSummary[i, 1], + se = feSummary[i, 3], + lowerCI = feSummary[i, 4], + upperCI = feSummary[i, 5], + rhat = feSummary[i, 7], + neff = feSummary[i, 6] + ) + + FEsummary$addRows(tempRow) + } + + # add warning messages + FEsummary$addFootnote(.mmMessageInterpretability) +} +.mmSummaryStanova <- function(jaspResults, dataset, options, type = "BLMM") { + if (!is.null(jaspResults[["STANOVAsummary"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + if (!is.null(model) && !class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { + modelSummary <- + summary( + model, + probs = c(.50 - options$summaryCI / 2, .50, .50 + options$summaryCI / 2), + diff_intercept = options$show == "deviation" + ) + } else{ + # dummy object for creating empty summary + modelSummary <- + list("Model summary" = matrix(NA, nrow = 0, ncol = 0)) + } + + STANOVAsummary <- createJaspContainer(title = "") + jaspResults[["STANOVAsummary"]] <- STANOVAsummary + + STANOVAsummary$position <- 1 + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + STANOVAsummary$dependOn(c(dependencies, "summaryCI", "show")) + + # go over each random effect grouping factor + for (i in 1:length(modelSummary)) { + tempSummary <- modelSummary[[i]] + + if (names(modelSummary)[i] == "Model summary") { + varName <- gettext("Model summary") + tableName <- varName + } else if (names(modelSummary)[i] == "(Intercept)") { + varName <- gettext("Intercept") + tableName <- varName + } else{ + varName <- jaspBase::gsubInteractionSymbol(names(modelSummary)[i]) + if (options$show == "deviation") { + tableName <- + gettextf("%s (differences from intercept)",varName) + } else if (options$show == "mmeans") { + if (nrow(tempSummary) == 1) { + tableName <- gettextf("%s (trend)",varName) + } else{ + tableName <- gettextf("%s (marginal means)",varName) + } + } + } + + tempTable <- createJaspTable(title = tableName) + STANOVAsummary[[paste0("summary_", i)]] <- tempTable + + if (varName != "Intercept" && nrow(tempSummary) > 1) { + tempTable$addColumnInfo(name = "level", + title = gettext("Level"), + type = "string") + } + tempTable$addColumnInfo(name = "estimate", + title = gettext("Estimate"), + type = "number") + tempTable$addColumnInfo(name = "se", + title = gettext("SE"), + type = "number") + tempTable$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$summaryCI) + ) + tempTable$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$summaryCI) + ) + tempTable$addColumnInfo(name = "rhat", + title = gettext("R-hat"), + type = "number") + tempTable$addColumnInfo(name = "ess_bulk", + title = gettext("ESS (bulk)"), + type = "number") + tempTable$addColumnInfo(name = "ess_tail", + title = gettext("ESS (tail)"), + type = "number") + + if (tableName == gettext("Model summary")) { + if(options$dependentVariable != "" && + length(options$fixedVariables) > 0 && + length(options$randomVariables) == 0) { + tempTable$addFootnote(.mmMessageMissingRE) + } + if (type == "BGLMM") { + if (options$family == "binomial_agg" && + options$dependentVariableAggregation == "") { + tempTable$addFootnote(.mmMessageMissingAgg) + } + } + + if(class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { + STANOVAsummary$setError(gettext("The model could not be estimated. Please, check the options and dataset for errors.")) + } + return() + } + + for (j in 1:nrow(tempSummary)) { + tempRow <- list( + estimate = tempSummary$Mean[j], + se = tempSummary$MAD_SD[j], + lowerCI = tempSummary[j, paste0((.50 - options$summaryCI / 2) * + 100, "%")], + upperCI = tempSummary[j, paste0((.50 + options$summaryCI / 2) * + 100, "%")], + rhat = tempSummary$rhat[j], + ess_bulk = tempSummary$ess_bulk[j], + ess_tail = tempSummary$ess_tail[j] + ) + + if (varName != "Intercept" && nrow(tempSummary) > 1) { + varName <- + paste(.unv(unlist(strsplit( + as.character(tempSummary$Variable[j]), "," + ))), collapse = jaspBase::interactionSymbol) + varName <- gsub(" ", "", varName, fixed = TRUE) + if (grepl(jaspBase::interactionSymbol, names(modelSummary)[i], fixed = T)) { + for (n in unlist(strsplit(.unv(names( + modelSummary + )[i]), jaspBase::interactionSymbol))) { + varName <- gsub(n, "", varName, fixed = TRUE) + } + } else{ + varName <- + gsub(.unv(names(modelSummary)[i]), "", varName, fixed = TRUE) + } + tempRow$level <- varName + } + + tempTable$addRows(tempRow) + } + + # add message about (lack of) random effects grouping factors + tempTable$addFootnote(.mmMessageREgrouping(options$randomVariables)) + + # check model fit + divIterations <- rstan::get_num_divergent(model$stanfit) + lowBmfi <- rstan::get_low_bfmi_chains(model$stanfit) + maxTreedepth <- rstan::get_num_max_treedepth(model$stanfit) + if(any(is.infinite(rstan::summary(model$stanfit)$summary[, "Rhat"]))){ + maxRhat <- Inf + }else{ + maxRhat <- max(rstan::summary(model$stanfit)$summary[, "Rhat"]) + } + minESS <- + min(rstan::summary(model$stanfit)$summary[, "n_eff"]) + if (divIterations != 0) { + tempTable$addFootnote(.mmMessageDivergentIter(divIterations), symbol = gettext("Warning:")) + } + if (length(lowBmfi) != 0) { + tempTable$addFootnote(.mmMessageLowBMFI(length(lowBmfi)), symbol = gettext("Warning:")) + } + if (maxTreedepth != 0) { + tempTable$addFootnote(.mmMessageMaxTreedepth(max_treedepth)) + } + if (maxRhat > 1.01) { + tempTable$addFootnote(.mmMessageMaxRhat(maxRhat), symbol = gettext("Warning:")) + } + if (minESS < 100 * options$chains || is.nan(minESS)) { + tempTable$addFootnote(.mmMessageMinESS(minESS, 100 * options$chains), symbol = gettext("Warning:")) + } + + removedMe <- jaspResults[["mmModel"]]$object$removedMe + removedTe <- jaspResults[["mmModel"]]$object$removedTe + addedRe <- jaspResults[["mmModel"]]$object$addedRe + if (length(removedMe) > 0) { + for (j in 1:length(removedMe)) { + tempTable$addFootnote(.mmMessageOmmitedTerms1(removedMe[[j]], names(removedMe)[j]), + symbol = gettext("Note:")) + } + } + if (length(removedTe) > 0) { + for (j in 1:length(removedTe)) { + tempTable$addFootnote(.mmMessageOmmitedTerms2(removedTe[[j]], names(removedTe)[j]), + symbol = gettext("Note:")) + } + } + if (length(addedRe) > 0) { + for (i in 1:length(addedRe)) { + tempTable$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) + } + } + if (jaspResults[["n_missing"]]$object != 0) { + tempTable$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) + } + if (type == "BGLMM") { + tempTable$addFootnote(.mmMessageGLMMtype(options$family, options$link)) + } + + } + +} +.mmDiagnostics <- function(jaspResults, options, dataset, type = "BLMM") { + if (!is.null(jaspResults[["diagnosticPlots"]])) + return() + + + diagnosticPlots <- createJaspContainer(title = gettext("Sampling diagnostics")) + + diagnosticPlots$position <- 5 + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + diagnosticPlots$dependOn(c( + dependencies, + "samplingPlot", + "samplingVariable1", + "samplingVariable2" + )) + jaspResults[["diagnosticPlots"]] <- diagnosticPlots + + + if (options$samplingPlot == "stan_scat" && + length(options$samplingVariable2) == 0) { + diagnosticPlots[["emptyPlot"]] <- createJaspPlot() + return() + } + + model <- jaspResults[["mmModel"]]$object$model + + if (options$samplingPlot != "stan_scat") { + pars <- + paste0(.v(unlist(options$samplingVariable1)), collapse = ":") + } else{ + pars <- c(paste0(.v(unlist( + options$samplingVariable1 + )), collapse = ":"), + paste0(.v(unlist( + options$samplingVariable2 + )), collapse = ":")) + } + + plotData <- + .mmGetPlotSamples(model = model, + pars = pars, + options = options) + + + for (i in 1:length(plotData)) { + if (names(plotData)[i] == "Intercept") { + varName <- gettext("Intercept") + } else{ + varName <- strsplit(as.character(pars), ":") + varName <- + sapply(varName, function(x) + paste(.unv(unlist( + strsplit(x, ",") + )), collapse = ":")) + varName <- + sapply(varName, function(x) + gsub(" ", "", x, fixed = TRUE)) + varName <- + sapply(varName, function(x) + .mmVariableNames(x, options$fixedVariables)) + varName <- paste0(varName, collapse = " by ") + } + + plots <- + createJaspPlot( + title = varName, + width = 400, + height = 300 + ) + + if (options$samplingPlot == "stan_trace") { + p <- .rstanPlotTrace(plotData[[i]]) + } else if (options$samplingPlot == "stan_scat") { + p <- .rstanPlotScat(plotData[[i]]) + } else if (options$samplingPlot == "stan_hist") { + p <- .rstanPlotHist(plotData[[i]]) + } else if (options$samplingPlot == "stan_dens") { + p <- .rstanPlotDens(plotData[[i]]) + } else if (options$samplingPlot == "stan_ac") { + p <- .rstanPlotAcor(plotData[[i]]) + } + + + if (options$samplingPlot %in% c("stan_hist", "stan_dens")) { + p <- jaspGraphs::themeJasp(p, sides = "b") + p <- p + ggplot2::theme( + axis.title.y = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.ticks.y = ggplot2::element_blank() + ) + p <- p + ggplot2::labs(x = varName) + } else{ + p <- jaspGraphs::themeJasp(p) + } + if (options$samplingPlot == "stan_trace") { + p <- p + ggplot2::theme(plot.margin = ggplot2::margin(r = 10 * (nchar(options$iteration - options$warmup) - 2))) + } + plots$plotObject <- p + + diagnosticPlots[[names(plotData)[i]]] <- plots + } + +} + +# helper functions +.mmVariableNames <- function(varName, variables) { + for (vn in variables) { + inf <- regexpr(vn, varName, fixed = TRUE) + if (inf[1] != -1) { + varName <- paste0( + substr(varName, 0, inf[1] - 1), + substr(varName, inf[1], inf[1] + attr(inf, "match.length") - 1), + " (", + substr( + varName, + inf[1] + attr(inf, "match.length"), + nchar(varName) + ) + ) + } + } + varName <- gsub(":", paste0(")", jaspBase::interactionSymbol), varName, fixed = TRUE) + varName <- paste0(varName, ")") + varName <- gsub(" ()", "", varName, fixed = TRUE) + return(varName) +} +.mmAddCoefNameStanova <- function(samples, par, coefs_name){ + # this is a mess but the stanova::stanova_samples returns an incomplete variable names + + coefs_trend <- attr(samples, "estimate") + coefs_trend <- gsub("trend ('", "", coefs_trend, fixed = TRUE) + coefs_trend <- gsub("')", "", coefs_trend, fixed = TRUE) + coefs_trend <- strsplit(coefs_trend, ",") + + for(cft in coefs_trend){ + if(cft %in% strsplit(par, ":")[[1]] && !grepl(.unv(cft), coefs_name)){ + coefs_name <- paste0(coefs_name, jaspBase::interactionSymbol, .unv(cft)) + } + } + + return(coefs_name) + +} +.mmGetPlotSamples <- function(model, pars, options) { + matrix_diff <- + stanova::stanova_samples(model, + return = "array", + diff_intercept = options$show == "deviation") + + if (length(pars) == 1) { + samples <- matrix_diff[[pars]] + coefs <- dim(matrix_diff[[pars]])[2] + + plotData <- list() + + for (cf in 1:coefs) { + + coefs_name <- + paste(.unv(unlist( + strsplit(dimnames(samples)$Parameter[cf], ",") + )), collapse = ":") + coefs_name <- gsub(" ", "", coefs_name, fixed = TRUE) + coefs_name <- .mmVariableNames(coefs_name, options$fixedVariables) + coefs_name <- .mmAddCoefNameStanova(samples, pars, coefs_name) + + + plotData[[dimnames(samples)$Parameter[cf]]] <- list( + samp = data.frame( + value = as.vector(samples[, cf,]), + parameter = as.factor(rep(coefs_name, length(as.vector(samples[, cf,])))), + chain = as.factor(c(unlist( + sapply(1:dim(samples)[3], function(x) + rep(x, dim(samples)[1])) + ))), + iteration = rep(1:dim(samples)[1], dim(samples)[3]) + ), + nchains = options$chains, + nparams = 1, + warmup = 0 + ) + } + + } else{ + samples1 <- matrix_diff[[pars[1]]] + samples2 <- matrix_diff[[pars[2]]] + coefs1 <- dim(matrix_diff[[pars[1]]])[2] + coefs2 <- dim(matrix_diff[[pars[2]]])[2] + + plotData <- list() + + for (cf1 in 1:coefs1) { + for (cf2 in 1:coefs2) { + + coefs1Name <- + paste(.unv(unlist( + strsplit(dimnames(samples1)$Parameter[cf1], ",") + )), collapse = ":") + coefs1Name <- gsub(" ", "", coefs1Name, fixed = TRUE) + coefs1Name <- .mmVariableNames(coefs1Name, options$fixedVariables) + coefs1Name <- .mmAddCoefNameStanova(samples1, pars[[1]], coefs1Name) + + coefs2Name <- + paste(.unv(unlist( + strsplit(dimnames(samples2)$Parameter[cf2], ",") + )), collapse = ":") + coefs2Name <- gsub(" ", "", coefs2Name, fixed = TRUE) + coefs2Name <- .mmVariableNames(coefs2Name, options$fixedVariables) + coefs2Name <- .mmAddCoefNameStanova(samples2, pars[[2]], coefs2Name) + + + plotData[[paste0(coefs1Name, ":", coefs2Name)]] <- list( + samp = data.frame( + value = c(as.vector(samples1[, cf1,]), + as.vector(samples2[, cf2,])), + parameter = factor(c( + rep(coefs1Name, dim(samples1)[1] * dim(samples1)[3]), + rep(coefs2Name, dim(samples2)[1] * dim(samples2)[3]) + ), levels = c(coefs1Name, coefs2Name)), + chain = as.factor(c( + unlist(sapply(1:dim(samples1)[3], function(x) + rep(x, dim(samples2)[1]))), + unlist(sapply(1:dim(samples2)[3], function(x) + rep(x, dim(samples2)[1]))) + )), + iteration = c(rep( + 1:dim(samples1)[1], dim(samples1)[3] + ), + rep( + 1:dim(samples2)[1], dim(samples2)[3] + )) + ), + nchains = options$chains, + nparams = 2, + warmup = 0 + ) + } + } + + } + + return(plotData) + +} +# as explained in ?is.integer +.is.wholenumber <- + function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol +# modified rstan plotting functions +.rstanPlotHist <- function(plotData) { + dots <- rstan:::.add_aesthetics(list(), c("fill", "color")) + thm <- rstan:::rstanvis_hist_theme() + base <- + ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) + graph <- base + do.call(ggplot2::geom_histogram, dots) + + ggplot2::xlab("") + thm + ggplot2::xlab(unique(plotData$samp$parameter)) + + return(graph) +} +.rstanPlotTrace <- function(plotData) { + thm <- rstan:::rstanvis_theme() + clrs <- + rep_len(rstan:::rstanvis_aes_ops("chain_colors"), + plotData$nchains) + base <- + ggplot2::ggplot(plotData$samp, + ggplot2::aes_string(x = "iteration", + y = "value", color = "chain")) + + graph <- + base + ggplot2::geom_path() + ggplot2::scale_color_manual(values = clrs) + + ggplot2::labs(x = "", y = levels(plotData$samp$parameter)) + thm + + graph <- graph + ggplot2::scale_x_continuous( + breaks = jaspGraphs::getPrettyAxisBreaks(c(1,max(plotData$samp$iteration)))) + + + graph +} +.rstanPlotDens <- function(plotData, separate_chains = TRUE) { + clrs <- + rep_len(rstan:::rstanvis_aes_ops("chain_colors"), + plotData$nchains) + thm <- rstan:::rstanvis_hist_theme() + base <- + ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) + + ggplot2::xlab("") + + if (!separate_chains) { + dots <- rstan:::.add_aesthetics(list(), c("fill", "color")) + graph <- base + do.call(ggplot2::geom_density, dots) + + thm + } else{ + dots <- rstan:::.add_aesthetics(list(), c("color", "alpha")) + dots$mapping <- ggplot2::aes_string(fill = "chain") + graph <- base + do.call(ggplot2::geom_density, dots) + + ggplot2::scale_fill_manual(values = clrs) + thm + } + + graph + ggplot2::xlab(unique(plotData$samp$parameter)) + +} +.rstanPlotScat <- function(plotData) { + thm <- rstan:::rstanvis_theme() + dots <- rstan:::.add_aesthetics(list(), c("fill", "pt_color", + "pt_size", "alpha", "shape")) + + p1 <- + plotData$samp$parameter == levels(plotData$samp$parameter)[1] + p2 <- + plotData$samp$parameter == levels(plotData$samp$parameter)[2] + val1 <- plotData$samp[p1, "value"] + val2 <- plotData$samp[p2, "value"] + df <- data.frame(x = val1, y = val2) + base <- ggplot2::ggplot(df, ggplot2::aes_string("x", "y")) + graph <- + base + do.call(ggplot2::geom_point, dots) + ggplot2::labs( + x = levels(plotData$samp$parameter)[1], + y = levels(plotData$samp$parameter)[2] + ) + thm + graph + +} +.rstanPlotAcor <- function(plotData, lags = 30) { + clrs <- + rep_len(rstan:::rstanvis_aes_ops("chain_colors"), + plotData$nchains) + thm <- rstan:::rstanvis_theme() + dots <- + rstan:::.add_aesthetics(list(), c("size", "color", "fill")) + ac_dat <- + rstan:::.ac_plotData(dat = plotData$samp, + lags = lags, + partial = FALSE) + + dots$position <- "dodge" + dots$stat <- "summary" + dots$fun.y <- "mean" + y_lab <- gettext("Avg. autocorrelation") + ac_labs <- ggplot2::labs(x = "Lag", y = y_lab) + y_scale <- + ggplot2::scale_y_continuous(breaks = seq(0, 1, 0.25)) + base <- + ggplot2::ggplot(ac_dat, ggplot2::aes_string(x = "lag", y = "ac")) + graph <- + base + do.call(ggplot2::geom_bar, dots) + y_scale + ac_labs + thm + + graph +} + + +.mmCustomChecks <- list( + collinCheck = function(dataset){ + cor_mat <- cor(apply(dataset,2,as.numeric)) + diag(cor_mat) <- 0 + cor_mat[lower.tri(cor_mat)] <- 0 + nearOne <- 1 - abs(cor_mat) < sqrt(.Machine$double.eps) + if(any(nearOne)){ + var_ind <- which(nearOne, arr.ind = TRUE) + varNames <- paste("'", .unv(rownames(cor_mat)[var_ind[,"row"]]),"' and '", .unv(colnames(cor_mat)[var_ind[,"col"]]),"'", sep = "", collapse = ", ") + return(gettextf("The following variables are a linear combination of each other, please, remove one of them from the analysis: %s", varNames)) + } + } +) +.mmDependenciesLMM <- + c( + "dependentVariable", + "fixedEffects", + "randomEffects", + "randomVariables", + "method", + "bootstrap_samples", + "test_intercept", + "type" + ) +.mmDependenciesGLMM <- c(.mmDependenciesLMM, + "dependentVariableAggregation", + "family", + "link") +.mmDependenciesBLMM <- + c( + "dependentVariable", + "fixedEffects", + "randomEffects", + "randomVariables", + "warmup", + "iteration", + "adapt_delta", + "max_treedepth", + "chains", + "seed", + "setSeed" + ) +.mmDependenciesBGLMM <- c(.mmDependenciesBLMM, + "dependentVariableAggregation", + "family", + "link") +# texts and messages +.mmMessageInterpretability <- + gettext("The intercept corresponds to the (unweighted) grand mean; for each factor with k levels, k - 1 parameters are estimated. Consequently, the estimates cannot be directly mapped to factor levels.") +.mmMessageSingularFit <- + gettext("Model fit is singular. Specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Carefully reduce the random effects structure, but this practice might inflate the reported p-value, and invalidates the analysis.") +.mmMessageVovkSellke <- + gettextf("Vovk-Sellke Maximum p-Ratio: Based on a two-sided p-value, the maximum possible odds in favor of H%1$s over H%2$s equals 1/(-e p log(p)) for p %3$s .37 (Sellke, Bayarri, & Berger, 2001).","\u2081","\u2080","\u2264") +.mmMessageNumericalProblems <- + gettext("Numerical problems with the maximum-likelihood estimate (e.g., gradients too large). This may indicate that the specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Consider carefully reducing the random effects structure, but be aware this may induce unknown risks of anti-conservative results (i.e., p-values might be lower than nominal).") +.mmMessageDFdisabled <- + gettext("Estimation of degrees of freedom disabled (i.e., asymptotic results shown), because the number of observations is large. To force estimation, check corresponding option.") +.mmMessageResponse <- gettext("Results are on the response scale.") +.mmMessageNotResponse <- + gettext("Results are not on the response scale and might be misleading.") +.mmMessageANOVAtype <- function(type) { + gettextf("Type %s Sum of Squares",type) +} +.mmMessageREgrouping <- function(RE_grouping_factors) { + sprintf( + ngettext( + length(RE_grouping_factors), + "The following variable is used as a random effects grouping factor: %s.", + "The following variables are used as random effects grouping factors: %s." + ), + paste0("'", RE_grouping_factors, "'", collapse = ", ") + ) +} +.mmMessageMissingRE <- gettext("This analysis requires at least one random effects grouping factor to run.") +.mmMessageMissingAgg <- gettext("The 'Binomial (aggregated)' family requires the 'Number of trials' to be specified to run.") +.mmMessageTestNull <- function(value) { + gettextf("P-values correspond to test of null hypothesis against %s.", value) +} +.mmMessageAveragedOver <- function(terms) { + gettextf("Results are averaged over the levels of: %s.",paste(terms, collapse = ", ")) +} +.mmMessageOmmitedTerms1 <- function(terms, grouping) { + sprintf( + ngettext( + length(terms), + "All random slopes involving ‘%s’ have been removed for the random effects grouping factor ‘%s’. -- Factor %s does not vary within the levels of random effects grouping factor '%s'.", + "All random slopes involving ‘%s’ have been removed for the random effects grouping factor ‘%s’. -- Factors %s do not vary within the levels of random effects grouping factor '%s'.", + ), + paste0("'", terms, "'", collapse = ", "), + grouping, + paste0("'", terms, "'", collapse = ", "), + grouping + ) +} +.mmMessageOmmitedTerms2 <- function(terms, grouping) { + sprintf( + ngettext( + length(terms), + "Random slopes of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slopes of '%s' for random effects grouping factor '%s'.", + "Random slope of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slope of '%s' for random effects grouping factor '%s'.", + ), + paste0("'", terms, "'", collapse = ", "), + grouping, + paste0("'", terms, "'", collapse = ", "), + grouping + ) +} +.mmMessageAddedTerms <- function(terms, grouping) { + sprintf( + ngettext( + length(terms), + "Lower order random effects terms need to be specified in presence of the higher order random effects terms. Therefore, the following random effects term was added to the '%s' random effects grouping factor: '%s.'", + "Lower order random effects terms need to be specified in presence of the higher order random effects terms. Therefore, the following random effects terms were added to the '%s' random effects grouping factor: '%s.'" + ), + grouping, + paste0("'", terms, "'", collapse = ", ") + ) +} +.mmMessageMissingRows <- function(value) { + sprintf( + ngettext( + value, + "%i observation was removed due to missing values.", + "%i observations were removed due to missing values." + ), + value + ) +} +.mmMessageGLMMtype <- function(family, link) { + family <- switch(family, + "binomial" = gettext("binomial"), + "binomial_agg" = gettext("binomial"), + "gaussian" = gettext("gaussian"), + "Gamma" = gettext("gamma"), + "inverse.gaussian" = gettext("inverse gaussian"), + "poisson" = gettext("poisson"), + "neg_binomial_2" = gettext("negative binomial"), + "betar" = gettext("beta"), + ) + gettextf("Generalized linear mixed model with %s family and %s link function.", + family, + link) +} +.mmMessageTermTest <- function(method) { + method <- switch(method, + "S" = gettext("Satterthwaite"), + "KR" = gettext("Kenward-Roger"), + "LRT" = gettext("likelihood ratio tests"), + "PB" = gettext("parametric bootstrap") + ) + gettextf("Model terms tested with %s method.",method) +} +.messagePvalAdjustment <- function(adjustment) { + if (adjustment == "none") { + return(gettext("P-values are not adjusted.")) + } + adjustment <- switch(adjustment, + "holm" = gettext("Holm"), + "hommel" = gettext("Homel"), + "hochberg" = gettext("Hochberg"), + "mvt" = gettext("Multivariate-t"), + "tukey" = gettext("Tukey"), + "BH" = gettext("Benjamini-Hochberg"), + "BY" = gettext("Benjamini-Yekutieli"), + "scheffe" = gettext("Scheffé"), + "sidak" = gettext("Sidak"), + "dunnettx" = gettext("Dunnett"), + "bonferroni" = gettext("Bonferroni") + ) + return(gettextf("P-values are adjusted using %s adjustment.",adjustment)) +} +.mmMessageDivergentIter <- function(iterations) { + sprintf( + ngettext( + iterations, + "The Hamiltonian Monte Carlo procedure might be invalid -- There was %i divergent transition after warmup. This can be solved by carefully increasing 'Adapt delta' until there are no divergent transitions.", + "The Hamiltonian Monte Carlo procedure might be invalid -- There were %i divergent transitions after warmup. This can be solved by carefully increasing 'Adapt delta' until there are no divergent transitions." + ), + iterations + ) +} +.mmMessageLowBMFI <- function(nChains) { + sprintf( + ngettext( + nChains, + "Bayesian Fraction of Missing Information (BFMI) that was too low in %i chain indicating that the posterior distribution was not explored efficiently. Try increasing number of 'Burnin' and 'Iterations'.", + "Bayesian Fraction of Missing Information (BFMI) that was too low in %i chains indicating that the posterior distribution was not explored efficiently. Try increasing number of 'Burnin' and 'Iterations'." + ), + nChains + ) +} +.mmMessageMaxTreedepth <- function(iterations) { + sprintf( + ngettext( + iterations, + "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transition exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth", + "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transitions exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth" + ), + iterations + ) +} +.mmMessageMaxRhat <- function(Rhat) { + gettextf( + "Inference possibly unreliable -- MCMC chains might not have converged; The largest R-hat is %.3f > 1.01. To lower R-hat please increase 'Iterations', or 'Adapt delta' in the Options section.", + Rhat + ) +} +.mmMessageMinESS <- function(ESS, treshold) { + gettextf( + "Low estimation accuracy -- The smallest Effective Sample Size (ESS) is %.2f < %1.0f. To increase accuracy please increase 'Iterations', or 'Adapt delta' in the Options section.", + ESS, + treshold + ) +} +.mmMessageBadWAIC <- function(n_bad) { + sprintf( + ngettext( + n_bad, + "WAIC estimate unreliable -- There was %1.0f p_waic estimate larger than 0.4. We recommend using LOO instead.", + "WAIC estimate unreliable -- There were %1.0f p_waic estimates larger than 0.4. We recommend using LOO instead." + ), + n_bad + ) +} +.mmMessageBadLOO <- function(n_bad) { + sprintf( + ngettext( + n_bad, + "LOO estimate unreliable -- There was %1.0f observation with the shape parameter (k) of the generalized Pareto distribution higher than > .5.", + "LOO estimate unreliable -- There were %1.0f observations with the shape parameter (k) of the generalized Pareto distribution higher than > .5." + ), + n_bad + ) +} +.mmMessageFitType <- function(REML) { + gettextf("The model was fitted using %1$s.%2$s", + ifelse(REML, gettext("restricted maximum likelihood"), gettext("maximum likelihood")), + ifelse(REML, gettext(" Please note that models with different fixed effects cannot be compared when REML is used. To use ML, switch 'Test model terms' to 'Likelihood ratio tests'."), "")) +} +# +# Copyright (C) 2019 University of Amsterdam +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +# + + +# TODO: Expose priors specification to users in Bxxx? +# TODO: Add 3rd level random effects grouping factors ;) (not that difficult actually) + +.mmRunAnalysis <- function(jaspResults, dataset, options, type){ + + if (.mmReady(options, type)) + dataset <- .mmReadData(jaspResults, dataset, options, type) + if (.mmReady(options, type)) + .mmCheckData(dataset, options, type) + + + # fit the model + if (.mmReady(options, type)){ + if(type %in% c("LMM", "GLMM")).mmFitModel(jaspResults, dataset, options, type) + if(type %in% c("BLMM", "BGLMM")).mmFitModelB(jaspResults, dataset, options, type) + } + + + # create (default) summary tables + if(type %in% c("LMM", "GLMM")).mmSummaryAnova(jaspResults, dataset, options, type) + if(type %in% c("BLMM", "BGLMM")).mmSummaryStanova(jaspResults, dataset, options, type) + + + if (!is.null(jaspResults[["mmModel"]]) && + !jaspResults[[ifelse(type %in% c("LMM", "GLMM"), "ANOVAsummary", "STANOVAsummary")]]$getError()) { + + + # show fit statistics + if (options$fitStats) { + if(type %in% c("LMM", "GLMM")).mmFitStats(jaspResults, options, type) + if(type %in% c("BLMM", "BGLMM")).mmFitStatsB(jaspResults, options, type) + } + + + # show fixed / random effects summary + if (options$showFE){ + if(type %in% c("LMM", "GLMM")).mmSummaryFE(jaspResults, options, type) + if(type %in% c("BLMM", "BGLMM")).mmSummaryFEB(jaspResults, options, type) + } + if (options$showRE){ + if(type %in% c("LMM", "GLMM")).mmSummaryRE(jaspResults, options, type) + if(type %in% c("BLMM", "BGLMM")).mmSummaryREB(jaspResults, options, type) + } + + + # sampling diagnostics + if(type %in% c("BLMM", "BGLMM")){ + if (length(options$samplingVariable1) != 0) + .mmDiagnostics(jaspResults, options, dataset, type) + } + + + # create plots + if (length(options$plotsX)) + .mmPlot(jaspResults, dataset, options, type) + + + # marginal means + if (length(options$marginalMeans) > 0) + .mmMarginalMeans(jaspResults, dataset, options, type) + if (length(options$marginalMeans) > 0 && + options$marginalMeansContrast && + !is.null(jaspResults[["EMMresults"]])) + .mmContrasts(jaspResults, options, type, what = "Means") + + + # trends + if (length(options$trendsTrend) > 0 && + length(options$trendsVariables) > 0) + .mmTrends(jaspResults, dataset, options, type) + if (options$trendsContrast && + length(options$trendsTrend) > 0 && + length(options$trendsVariables) > 0 && + !is.null(jaspResults[["EMTresults"]])) + .mmContrasts(jaspResults, options, type, what = "Trends") + } + + return() +} + +### common mixed-models functions +.mmReadData <- function(jaspResults, dataset, options, type = "LMM") { + if (is.null(dataset)) { + if (type %in% c("LMM","BLMM")) { + dataset <- readDataSetToEnd( + columns.as.numeric = options$dependentVariable, + columns = c( + options$fixedVariables, + options$randomVariables + ) + ) + } else if (type %in% c("GLMM","BGLMM")) { + if (options$family == "binomial_agg"){ + dataset <- readDataSetToEnd( + columns.as.numeric = c(options$dependentVariable, options$dependentVariableAggregation), + columns = c( + options$fixedVariables, + options$randomVariables + ) + ) + } else if (options$dependentVariableAggregation == "") { + dataset <- readDataSetToEnd( + columns.as.numeric = options$dependentVariable, + columns = c( + options$fixedVariables, + options$randomVariables + ) + ) + } + } + } + + dataset <- data.frame(dataset) + + # check and use only the variables that actually used for modeling + used_variables <- .v(c( + options$dependentVariable, + if(type %in% c("GLMM", "BGLMM")) if(options$dependentVariableAggregation != "") options$dependentVariableAggregation, + unique(unlist(options$fixedEffects)), + if(length(options$randomVariables) != 0) options$randomVariables + )) + dataset <- dataset[,used_variables] + + # omit NAs/NaN/Infs and store the number of omitted observations + all_rows <- nrow(dataset) + dataset <- na.omit(dataset) + + # store the number of missing values into a jaspState object + n_missing <- createJaspState() + n_missing$object <- all_rows - nrow(dataset) + jaspResults[["n_missing"]] <- n_missing + + return(dataset) +} +.mmCheckData <- function(dataset, options, type = "LMM") { + + if(nrow(dataset) < length(options$fixedEffects)).quitAnalysis("The dataset contains fewer observations than predictors (after excluding NAs/NaN/Inf).") + + check_variables <- 1:ncol(dataset) + if(type %in% c("GLMM", "BGLMM")) + if(options$dependentVariableAggregation != "") + check_variables <- check_variables[-which(.v(options$dependentVariableAggregation) == colnames(dataset))] + + + .hasErrors( + dataset, + type = 'infinity', + exitAnalysisIfErrors = TRUE + ) + + # the aggregation variable for binomial can have zero variance and can be without factor levels + .hasErrors( + dataset[,check_variables], + type = c('variance', 'factorLevels'), + factorLevels.amount = "< 2", + exitAnalysisIfErrors = TRUE, + custom = .mmCustomChecks + ) + + for(var in unlist(options$fixedEffects)) { + if(is.factor(dataset[,.v(var)]) || is.character(dataset[,.v(var)])){ + if(length(unique(dataset[,.v(var)])) == nrow(dataset)) + .quitAnalysis(gettextf("The categorical fixed effect '%s' must have fewer levels than the overall number of observations.",var)) + } + } + + for(var in unlist(options$randomVariables)) { + if(length(unique(dataset[,.v(var)])) == nrow(dataset)) + .quitAnalysis(gettextf("The random effects grouping factor '%s' must have fewer levels than the overall number of observations.",var)) + } + + # check hack-able options + if (type %in% c("BLMM", "BGLMM")) { + if (options$iteration - 1 <= options$warmup) { + .quitAnalysis(gettext("The number of iterations must be at least 2 iterations higher than the burnin")) + } + } + + # check families + if (type %in% c("GLMM","BGLMM")) { + family_text <- .mmMessageGLMMtype(options$family, options$link) + family_text <- substr(family_text, 1, nchar(family_text) - 1) + + if (options$family %in% c("Gamma", "inverse.gaussian")) { + if (any(dataset[, .v(options$dependentVariable)] <= 0)) + .quitAnalysis(gettextf("%s requires that the dependent variable is positive.",family_text)) + } else if (options$family %in% c("neg_binomial_2", "poisson")) { + if (any(dataset[, .v(options$dependentVariable)] < 0 | any(!.is.wholenumber(dataset[, .v(options$dependentVariable)])))) + .quitAnalysis(gettextf("%s requires that the dependent variable is an integer.",family_text)) + } else if (options$family == "binomial") { + if (any(!dataset[, .v(options$dependentVariable)] %in% c(0, 1))) + .quitAnalysis(gettextf("%s requires that the dependent variable contains only 0 and 1.",family_text)) + } else if (options$family == "binomial_agg") { + if (any(dataset[, .v(options$dependentVariable)] < 0 | dataset[, .v(options$dependentVariable)] > 1)) + .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",family_text)) + if (any(dataset[, .v(options$dependentVariableAggregation)] < 0) || any(!.is.wholenumber(dataset[, .v(options$dependentVariableAggregation)]))) + .quitAnalysis(gettextf("%s requires that the number of trials variable is an integer.",family_text)) + if (any(!.is.wholenumber(dataset[, .v(options$dependentVariable)] * dataset[, .v(options$dependentVariableAggregation)]))) + .quitAnalysis(gettextf("%s requires that the dependent variable is proportion of successes out of the number of trials.",family_text)) + } else if (options$family == "betar") { + if (any(dataset[, .v(options$dependentVariable)] <= 0 | dataset[, .v(options$dependentVariable)] >= 1)) + .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",family_text)) + } + } +} +.mmReady <- function(options, type = "LMM") { + if (type %in% c("LMM","BLMM")) { + if (options$dependentVariable == "" || + length(options$randomVariables) == 0 || + length(options$fixedEffects) == 0) { + return(FALSE) + } + } else if (type %in% c("GLMM","BGLMM")) { + if (options$family == "binomial_agg"){ + if (options$dependentVariable == "" || + options$dependentVariableAggregation == "" || + length(options$randomVariables) == 0 || + length(options$fixedEffects) == 0) { + return(FALSE) + } + }else{ + if (options$dependentVariable == "" || + length(options$randomVariables) == 0 || + length(options$fixedEffects) == 0) { + return(FALSE) + } + } + + } + return(TRUE) +} +.mmModelFormula <- function(options, dataset) { + # fixed effects + feTerms <- + sapply(options[["fixedEffects"]], function(x) + paste(.v(unlist(x)), collapse = "*")) + # simplify the terms + feTerms <- .mmSimplifyTerms(feTerms) + # create the FE formula + fixedEffects <- paste0(feTerms, collapse = "+") + + if (fixedEffects == "") + fixedEffects <- 1 + + # random effects + randomEffects <- NULL + removedMe <- list() + removedTe <- list() + addedRe <- list() + for (tempRe in options[["randomEffects"]]) { + # unlist selected random effects + tempVars <- sapply(tempRe$randomComponents, function(x) { + if (x$randomSlopes) { + return(.v(unlist(x$value))) + } else{ + return(NA) + } + }) + tempVarsRem <- sapply(tempRe$randomComponents, function(x) { + if (x$randomSlopes) { + return(NA) + } else{ + return(.v(unlist(x$value))) + } + }) + tempVars <- tempVars[!is.na(tempVars)] + tempVars <- + sapply(tempVars, function(x) + paste(unlist(x), collapse = "*")) + tempVarsRem <- tempVarsRem[!is.na(tempVarsRem)] + tempVarsRem <- + sapply(tempVarsRem, function(x) + paste(unlist(x), collapse = "*")) + ### test sensibility of random slopes + # main effect check #1 + # - remove main effects that have only one level of selected variable for the random effect grouping factor (eg only between subject variables) + # - and associated interactions + meToRemove <- NULL + for (me in tempVars[!grepl("\\*", tempVars)]) { + tempTable <- table(dataset[, c(.v(tempRe$value), me)]) + if (all(apply(tempTable, 1, function(x) + sum(x > 0)) <= 1)) { + meToRemove <- c(meToRemove, me) + } + } + if (!is.null(meToRemove)) { + tempVars <- + tempVars[!tempVars %in% unique(as.vector(sapply(meToRemove, function(x) + tempVars[grepl(x, tempVars, fixed = TRUE)])))] + } + tempVars <- na.omit(tempVars) + # terms check #2 + # - remove terms that have at maximum one measure across the level of variables (targeted at interactions of between subject variables) + teToRemove <- NULL + for (te in tempVars) { + tempTerms <- unlist(strsplit(te, "\\*")) + if (any(sapply(tempTerms, function(x) + typeof(dataset[, .v(x)]) == "double"))) + next + tempTable <- + table(dataset[, c(.v(tempRe$value), tempTerms)]) + if (all(tempTable <= 1)) { + teToRemove <- c(teToRemove, te) + } + } + if (!is.null(teToRemove)) { + teToRemove <- + unique(as.vector(sapply(teToRemove, function(x) + tempVars[grepl(x, tempVars, fixed = TRUE)]))) + tempVars <- tempVars[!tempVars %in% teToRemove] + } + + # simplify the formula + reAdded <- .mmAddedRETerms(tempVars, tempVarsRem) + reTerms <- .mmSimplifyTerms(tempVars) + reTerms <- paste0(reTerms, collapse = "+") + + newRe <- + paste0( + "(", + ifelse(reTerms == "", 1, reTerms), + ifelse(tempRe$correlation || + reTerms == "", "|", "||"), + .v(tempRe$value), + ")" + ) + + randomEffects <- c(randomEffects, newRe) + removedMe[[tempRe$value]] <- .unv(meToRemove) + removedTe[[tempRe$value]] <- .unv(teToRemove) + addedRe[[tempRe$value]] <- reAdded + } + randomEffects <- paste0(randomEffects, collapse = "+") + + modelFormula <- + paste0(.v(options$dependentVariable), + "~", + fixedEffects, + "+", + randomEffects) + + return( + list( + modelFormula = modelFormula, + removedMe = removedMe, + removedTe = removedTe, + addedRe = addedRe + ) + ) +} +.mmSimplifyTerms <- function(terms) { + if (length(terms) > 1) { + splitTerms <- sapply(terms, strsplit, "\\*") + splitTerms <- + sapply(splitTerms, function(x) + trimws(x, which = c("both"))) + + termsToRemove <- rep(NA, length(splitTerms)) + for (i in 1:length(terms)) { + termsToRemove[i] <- + any(sapply(splitTerms[-i], function(x) + all(splitTerms[[i]] %in% x))) + } + terms <- terms[!termsToRemove] + } + return(terms) +} +.mmAddedRETerms <- function(terms, removed) { + added <- NULL + if (length(terms) > 1 && length(removed) >= 1) { + splitTerms <- sapply(terms, strsplit, "\\*") + splitTerms <- + sapply(splitTerms, function(x) + trimws(x, which = c("both"))) + + splitRemoved <- sapply(removed, strsplit, "\\*") + splitRemoved <- + sapply(splitRemoved, function(x) + trimws(x, which = c("both"))) + + termsToRemove <- rep(NA, length(splitTerms)) + for (i in 1:length(removed)) { + if (any(sapply(splitTerms, function(x) + all(splitRemoved[[i]] %in% x)))) { + added <- c(added, paste0(.unv(splitRemoved[[i]]), collapse = "*")) + } + } + } + return(added) +} +.mmFitModel <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["mmModel"]])) + return() + + mmModel <- createJaspState() + #maybe you should define some columns here + jaspResults[["mmModel"]] <- mmModel + + if (options$method == "PB") { + seedDependencies <- c("seed", "setSeed") + .setSeedJASP(options) + } else{ + seedDependencies <- NULL + } + if (type == "LMM") { + dependencies <- c(.mmDependenciesLMM, seedDependencies) + } else if (type == "GLMM") { + dependencies <- c(.mmDependenciesGLMM, seedDependencies) + } + mmModel$dependOn(dependencies) + + + modelFormula <- .mmModelFormula(options, dataset) + + if (type == "LMM") { + model <- tryCatch( + afex::mixed( + formula = as.formula(modelFormula$modelFormula), + data = dataset, + type = options$type, + method = options$method, + test_intercept = if (options$method %in% c("LRT", "PB")) + options$test_intercept + else + FALSE, + args_test = list(nsim = options$bootstrap_samples), + check_contrasts = TRUE + ), + error = function(e) + return(e) + ) + } else if (type == "GLMM") { + # needs to be avaluated in the global environment + glmmFamily <<- options$family + glmmLink <<- options$link + + # I wish there was a better way to do this + if (options$family == "binomial_agg") { + glmmWeight <<- dataset[, .v(options$dependentVariableAggregation)] + model <- tryCatch( + afex::mixed( + formula = as.formula(modelFormula$modelFormula), + data = dataset, + type = options$type, + method = options$method, + test_intercept = if (options$method %in% c("LRT", "PB")) + options$test_intercept + else + FALSE, + args_test = list(nsim = options$bootstrap_samples), + check_contrasts = TRUE, + family = eval(call("binomial", glmmLink)), + weights = glmmWeight + ), + error = function(e) + return(e) + ) + } else{ + model <- tryCatch( + afex::mixed( + formula = as.formula(modelFormula$modelFormula), + data = dataset, + type = options$type, + method = options$method, + test_intercept = if (options$method %in% c("LRT", "PB")) + options$test_intercept + else + FALSE, + args_test = list(nsim = options$bootstrap_samples), + check_contrasts = TRUE, + #start = start, + family = eval(call(glmmFamily, glmmLink)) + ), + error = function(e) + return(e) + ) + } + } + + + object <- list( + model = model, + removedMe = modelFormula$removedMe, + removedTe = modelFormula$removedTe, + addedRe = modelFormula$addedRe + ) + + mmModel$object <- object + + return() +} +.mmSummaryAnova <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["ANOVAsummary"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + ANOVAsummary <- createJaspTable(title = gettext("ANOVA Summary")) + #defining columns first to give the user something nice to look at + ANOVAsummary$addColumnInfo(name = "effect", title = gettext("Effect"), type = "string") + if (options$method %in% c("S", "KR")) { + ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "string") + ANOVAsummary$addColumnInfo(name = "stat", title = gettext("F"), type = "number") + } else if + (options$method %in% c("PB", "LRT")) { + ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "integer") + ANOVAsummary$addColumnInfo(name = "stat", title = gettext("ChiSq"), type = "number") + } + ANOVAsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") + if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBoot", title = gettext("p (bootstrap)"), type = "pvalue") + if (options$pvalVS) { + ANOVAsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") + if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBootVS", title = gettext("VS-MPR (bootstrap)"), type = "number") + + ANOVAsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = c("pvalVS", "pvalBootVS")) + } + + jaspResults[["ANOVAsummary"]] <- ANOVAsummary + + ANOVAsummary$position <- 1 + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- .mmDependenciesGLMM + } + if (options$method == "PB") { + seedDependencies <- c("seed", "setSeed") + } else{ + seedDependencies <- NULL + } + ANOVAsummary$dependOn(c(dependencies, seedDependencies, "pvalVS")) + + # some error managment for GLMMS - and oh boy, they can fail really easily + if (type %in% c("LMM", "GLMM") && !is.null(model)) { + if (any(attr(model, "class") %in% c("std::runtime_error", "C++Error", "error"))) { + if (model$message == "(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate") + ANOVAsummary$setError( + gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.") + ) + + else if (model$message == "PIRLS loop resulted in NaN value") + ANOVAsummary$setError( + gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data or an overly complex model structure. Try removing some of the predictors.") + ) + + else if (model$message == "cannot find valid starting values: please specify some") + # currently no solution to this, it seems to be a problem with synthetic data only. + # I will try silving it once someone actually has problem with real data. + ANOVAsummary$setError(gettext("The optimizer failed to find a solution due to invalid starting values. (JASP currently does not support specifying different starting values.)")) + + else if (model$message == "Downdated VtV is not positive definite") + ANOVAsummary$setError(gettext("The optimizer failed to find a solution. Probably due to scaling issues quasi-separation in the data. Try rescaling or removing some of the predictors.")) + + + else + ANOVAsummary$setError(.unv(model$message)) + + + return() + } + + } + + + if (is.null(model)) { + if (options$dependentVariable != "" && + length(options$fixedVariables) > 0 && + length(options$randomVariables) == 0) { + ANOVAsummary$addFootnote(.mmMessageMissingRE) + } + if (type == "GLMM") { + if (options$family == "binomial_agg" && + options$dependentVariableAggregation == "") { + ANOVAsummary$addFootnote(.mmMessageMissingAgg) + } + } + return() + } + + + for (i in 1:nrow(model$anova_table)) { + if (rownames(model$anova_table)[i] == "(Intercept)") { + effectName <- gettext("Intercept") + } else{ + effectName <- jaspBase::gsubInteractionSymbol(rownames(model$anova_table)[i]) + } + + tempRow <- list(effect = effectName, + df = afex::nice(model)$df[i]) + + if (options$method %in% c("S", "KR")) { + tempRow$stat = model$anova_table$`F`[i] + tempRow$pval = model$anova_table$`Pr(>F)`[i] + } else if (options$method == "PB") { + tempRow$stat = model$anova_table$Chisq[i] + tempRow$pval = model$anova_table$`Pr(>Chisq)`[i] + tempRow$pvalBoot = model$anova_table$`Pr(>PB)`[i] + } else if (options$method == "LRT") { + tempRow$stat = model$anova_table$Chisq[i] + tempRow$pval = model$anova_table$`Pr(>Chisq)`[i] + } + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) + if (options$method == "PB") { + tempRow$pvalBootVS <- + VovkSellkeMPR(tempRow$pvalBoot) + } + } + + ANOVAsummary$addRows(tempRow) + } + + # add message about (lack of) random effect grouping factors + ANOVAsummary$addFootnote(.mmMessageREgrouping(options$randomVariables)) + + # add warning messages + # deal with type II multiple models stuff + if (is.list(model$full_model)) { + if (lme4::isSingular(model$full_model[[length(model$full_model)]])) { + ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) + } else if (!is.null(model$full_model[[length(model$full_model)]]@optinfo$conv$lme4$messages)) { + ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) + } + } else{ + if (lme4::isSingular(model$full_model)) { + ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) + } else if (!is.null(model$full_model@optinfo$conv$lme4$messages)) { + ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) + } + } + if (jaspResults[["n_missing"]]$object != 0) { + ANOVAsummary$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) + } + + removedMe <- jaspResults[["mmModel"]]$object$removedMe + removedTe <- jaspResults[["mmModel"]]$object$removedTe + addedRe <- jaspResults[["mmModel"]]$object$addedRe + + for (i in seq_along(removedMe)) + ANOVAsummary$addFootnote(.mmMessageOmmitedTerms1(removedMe[[i]], names(removedMe)[i]), symbol = gettext("Note:")) + + for (i in seq_along(removedTe)) + ANOVAsummary$addFootnote(.mmMessageOmmitedTerms2(removedTe[[i]], names(removedTe)[i]), symbol = gettext("Note:")) + + for (i in seq_along(addedRe)) + ANOVAsummary$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) + + + + ANOVAsummary$addFootnote(.mmMessageANOVAtype(ifelse(options$type == 3, gettext("III"), gettext("II")))) + if (type == "GLMM") + ANOVAsummary$addFootnote(.mmMessageGLMMtype(options$family, options$link)) + + ANOVAsummary$addFootnote(.mmMessageTermTest(options$method)) + + + return() +} +.mmFitStats <- function(jaspResults, options, type = "LMM") { + if (!is.null(jaspResults[["fitStats"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + if (is.list(model$full_model)) { + full_model <- model$full_model[[length(model$full_model)]] + } else{ + full_model <- model$full_model + } + + fitSummary <- createJaspContainer("Model summary") + fitSummary$position <- 2 + + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- .mmDependenciesGLMM + } + if (options$method == "PB") + dependencies <- c(dependencies, "seed", "setSeed") + + fitSummary$dependOn(c(dependencies, "fitStats")) + jaspResults[["fitSummary"]] <- fitSummary + + + ### fit statistics + fitStats <- createJaspTable(title = gettext("Fit statistics")) + fitStats$position <- 1 + + if (!lme4::isREML(full_model)) + fitStats$addColumnInfo(name = "deviance", title = gettext("Deviance"), type = "number") + if (lme4::isREML(full_model)) + fitStats$addColumnInfo(name = "devianceREML", title = gettext("Deviance (REML)"), type = "number") + fitStats$addColumnInfo(name = "loglik", title = gettext("log Lik."), type = "number") + fitStats$addColumnInfo(name = "df", title = gettext("df"), type = "integer") + fitStats$addColumnInfo(name = "aic", title = gettext("AIC"), type = "number") + fitStats$addColumnInfo(name = "bic", title = gettext("BIC"), type = "number") + jaspResults[["fitSummary"]][["fitStats"]] <- fitStats + + + tempRow <- list( + loglik = logLik(full_model), + df = attr(logLik(full_model) , "df"), + aic = AIC(full_model), + bic = BIC(full_model) + ) + + if (!lme4::isREML(full_model)) + tempRow$deviance <- deviance(full_model, REML = FALSE) + if (lme4::isREML(full_model)) + tempRow$devianceREML <- lme4::REMLcrit(full_model) + + fitStats$addRows(tempRow) + fitStats$addFootnote(.mmMessageFitType(lme4::isREML(full_model))) + + + ### sample sizes + fitSizes <- createJaspTable(title = gettext("Sample sizes")) + fitSizes$position <- 2 + + fitSizes$addColumnInfo(name = "observations", title = gettext("Observations"), type = "integer") + tempRow <- list( + observations = nrow(full_model@frame) + ) + for (thisName in names(full_model@flist)) { + fitSizes$addColumnInfo(name = thisName, title = .unv(thisName), type = "integer", overtitle = gettext("Levels of RE grouping factors")) + tempRow[[thisName]] <- length(levels(full_model@flist[[thisName]])) + } + fitSizes$addRows(tempRow) + jaspResults[["fitSummary"]][["fitSizes"]] <- fitSizes + + return() +} +.mmSummaryRE <- function(jaspResults, options, type = "LMM") { + if (!is.null(jaspResults[["REsummary"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + REsummary <- createJaspContainer(title = gettext("Variance/Correlation Estimates")) + + REsummary$position <- 4 + + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- .mmDependenciesGLMM + } + if (options$method == "PB") { + seedDependencies <- c("seed", "setSeed") + } else{ + seedDependencies <- NULL + } + REsummary$dependOn(c(dependencies, seedDependencies, "showRE")) + + # deal with SS type II stuff + if (is.list(model$full_model)) { + VarCorr <- + lme4::VarCorr(model$full_model[[length(model$full_model)]]) + } else{ + VarCorr <- lme4::VarCorr(model$full_model) + } + # go over each random effect grouping factor + for (gi in 1:length(VarCorr)) { + tempVarCorr <- VarCorr[[gi]] + + # add variance summary + REvar <- createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) + + REvar$addColumnInfo(name = "variable", + title = gettext("Term"), + type = "string") + REvar$addColumnInfo(name = "std", + title = gettext("Std. Deviation"), + type = "number") + REvar$addColumnInfo(name = "var", + title = gettext("Variance"), + type = "number") + + tempStdDev <- attr(tempVarCorr, "stddev") + for (i in 1:length(tempStdDev)) { + if (names(tempStdDev)[i] == "(Intercept)") { + varName <- gettext("Intercept") + } else{ + varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) + } + + tempRow <- list( + variable = varName, + std = tempStdDev[i], + var = tempStdDev[i]^2 + ) + + REvar$addRows(tempRow) + } + + REvar$addFootnote(.mmMessageInterpretability) + + REsummary[[paste0("VE", gi)]] <- REvar + + + # add correlation summary + if (length(tempStdDev) > 1) { + tempCorr <- attr(tempVarCorr, "correlation") + REcor <- + createJaspTable(title = gettextf("%s: Correlation Estimates",.unv(names(VarCorr)[gi]))) + + # add columns + REcor$addColumnInfo(name = "variable", + title = gettext("Term"), + type = "string") + for (i in 1:nrow(tempCorr)) { + if (rownames(tempCorr)[i] == "(Intercept)") { + varName <- gettext("Intercept") + } else{ + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) + } + REcor$addColumnInfo(name = paste0("v", i), + title = varName, + type = "number") + } + + # fill rows + for (i in 1:nrow(tempCorr)) { + if (rownames(tempCorr)[i] == "(Intercept)") { + varName <- gettext("Intercept") + } else{ + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) + } + + tempRow <- list(variable = varName) + for (j in 1:i) { + tempRow[paste0("v", j)] <- tempCorr[i, j] + } + REcor$addRows(tempRow) + } + + REcor$addFootnote(.mmMessageInterpretability) + + REsummary[[paste0("CE", gi)]] <- REcor + + } + + } + + # add residual variance summary + REres <- + createJaspTable(title = gettext("Residual Variance Estimates")) + + REres$addColumnInfo(name = "std", + title = gettext("Std. Deviation"), + type = "number") + REres$addColumnInfo(name = "var", + title = gettext("Variance"), + type = "number") + + if (is.list(model$full_model)) { + tempRow <- + list(std = sigma(model$full_model[[length(model$full_model)]]), + var = sqrt(sigma(model$full_model[[length(model$full_model)]]))) + } else{ + tempRow <- list(std = sigma(model$full_model), + var = sigma(model$full_model)^2) + } + + REres$addRows(tempRow) + REsummary[[paste0("RES", gi)]] <- REres + + + jaspResults[["REsummary"]] <- REsummary + return() +} +.mmSummaryFE <- function(jaspResults, options, type = "LMM") { + if (!is.null(jaspResults[["FEsummary"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + if (is.list(model$full_model)) { + FEcoef <- + summary(model$full_model[[length(model$full_model)]])$coeff + } else{ + FEcoef <- summary(model$full_model)$coeff + } + + FEsummary <- createJaspTable(title = gettext("Fixed Effects Estimates")) + + FEsummary$position <- 3 + if (type == "LMM") dependencies <- .mmDependenciesLMM + else if (type == "GLMM") dependencies <- .mmDependenciesGLMM + + if(options$method == "PB"){ + seedDependencies <- c("seed", "setSeed") + }else{ + seedDependencies <- NULL + } + + + FEsummary$dependOn(c(dependencies, seedDependencies, "showFE", "pvalVS")) + + FEsummary$addColumnInfo(name = "term", title = gettext("Term"), type = "string") + FEsummary$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") + FEsummary$addColumnInfo(name = "se", title = gettext("SE"), type = "number") + if (type == "LMM") FEsummary$addColumnInfo(name = "df", title = gettext("df"), type = "number") + FEsummary$addColumnInfo(name = "stat", title = gettext("t"), type = "number") + if (ncol(FEcoef) >= 4) FEsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") + + if (options$pvalVS) { + FEsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") + FEsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") + } + + jaspResults[["FEsummary"]] <- FEsummary + + for (i in 1:nrow(FEcoef)) { + if (rownames(FEcoef)[i] == "(Intercept)") { + effectName <- gettext("Intercept") + } else{ + effectName <- .mmVariableNames(rownames(FEcoef)[i], options$fixedVariables) + } + + if (type == "LMM") { + tempRow <- list( + term = effectName, + estimate = FEcoef[i, 1], + se = FEcoef[i, 2], + df = FEcoef[i, 3], + stat = FEcoef[i, 4], + pval = FEcoef[i, 5] + ) + } else if (type == "GLMM") { + tempRow <- list( + term = effectName, + estimate = FEcoef[i, 1], + se = FEcoef[i, 2], + stat = FEcoef[i, 3] + ) + if (ncol(FEcoef) >= 4) { + tempRow$pval <- FEcoef[i, 4] + } + } + + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) + } + + FEsummary$addRows(tempRow) + } + + # add warning messages + FEsummary$addFootnote(.mmMessageInterpretability) + + +} +.mmFixPlotAxis <- function(p){ + + yTicks <- jaspGraphs::getPrettyAxisBreaks(ggplot2::layer_scales(p)$y$range$range) + yRange <- range(yTicks) + xTicks <- ggplot2::layer_scales(p)$x$range$range + + p + ggplot2::scale_y_continuous(breaks = yTicks, limits = yRange) + + ggplot2::scale_x_discrete(breaks = xTicks) +} +.mmPlot <- function(jaspResults, dataset, options, type = "LMM") { + + if (!is.null(jaspResults[["plots"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + # automatic size specification will somewhat work unless there is more than 2 variables in panel + height <- 350 + width <- 150 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, .v(x)])) / 2)) + + if (length(options$plotsPanel) > 0) { + width <- + width * length(unique(dataset[, .v(unlist(options$plotsPanel)[1])])) + } else if (length(options$plotsPanel) > 1) { + height <- + height * length(unique(dataset[, .v(unlist(options$plotsPanel)[2])])) + } + if (options$plotLegendPosition %in% c("bottom", "top")) { + height <- height + 50 + } else if (options$plotLegendPosition %in% c("left", "right")) { + width <- width + 100 + } + width <- width + 150 + + plots <- createJaspPlot(title = gettext("Plot"), width = width, height = height) + + plots$position <- 5 + switch(type, + LMM = dependencies <- .mmDependenciesLMM, + GLMM = dependencies <- .mmDependenciesGLMM, + BLMM = dependencies <- .mmDependenciesBLMM, + BGLMM = dependencies <- .mmDependenciesBGLMM + ) + + plots$dependOn( + c( + dependencies, + "plotsX", + "plotsTrace", + "plotsPanel", + "plotsAgregatedOver", + "plotsGeom", + "plotsTrace", + "plotsPanel", + "plotsTheme", + "plotsCIwidth", + "plotsCImethod", + "plotAlpha", + "plotJitterWidth", + "plotJitterHeight", + "plotGeomWidth", + "plotDodge", + "plotsBackgroundColor", + "plotRelativeSize", + "plotRelativeSizeText", + "plotLegendPosition", + "plotsMappingColor", + "plotsMappingShape", + "plotsMappingLineType", + "plotsMappingFill", + "seed", + "setSeed" + ) + ) + + jaspResults[["plots"]] <- plots + plots$status <- "running" + + # stop with message if there is no random effects grouping factor selected + if (length(options$plotsAgregatedOver) == 0) { + plots$setError( + gettext("At least one random effects grouping factor needs to be selected in field 'Background data show'.") + ) + return() + } + if (all( + !c( + options$plotsMappingColor, + options$plotsMappingShape, + options$plotsMappingLineType, + options$plotsMappingFill + ) + )) { + plots$setError( + gettext("Factor levels need to be distinguished by at least one feature. Please, check one of the 'Distinguish factor levels' options.") + ) + return() + } + + # select geom + if (options$plotsGeom %in% c("geom_jitter", "geom_violin", "geom_boxplot", "geom_count")) { + geom_package <- "ggplot2" + } else if (options$plotsGeom == "geom_beeswarm") { + geom_package <- "ggbeeswarm" + } else if (options$plotsGeom == "geom_boxjitter") { + geom_package <- "ggpol" + } + + # select mapping + mapping <- + c("color", "shape", "linetype", "fill")[c( + options$plotsMappingColor, + options$plotsMappingShape, + options$plotsMappingLineType, + options$plotsMappingFill + )] + if (length(mapping) == 0) + mapping <- "" + + # specify data_arg + if (options$plotsGeom == "geom_jitter") { + data_arg <- list( + position = + ggplot2::position_jitterdodge( + jitter.width = options$plotJitterWidth, + jitter.height = options$plotJitterHeight, + dodge.width = options$plotDodge + ) + ) + } else if (options$plotsGeom == "geom_violin") { + data_arg <- list(width = options$plotGeomWidth) + } else if (options$plotsGeom == "geom_boxplot") { + data_arg <- list(width = options$plotGeomWidth) + } else if (options$plotsGeom == "geom_count") { + data_arg <- list() + } else if (options$plotsGeom == "geom_beeswarm") { + data_arg <- list(dodge.width = options$plotDodge) + } else if (options$plotsGeom == "geom_boxjitter") { + data_arg <- list( + width = options$plotGeomWidth, + jitter.width = options$plotJitterWidth, + jitter.height = options$plotJitterHeight, + outlier.intersect = TRUE + ) + } + if (options$plotsBackgroundColor != "none" && options$plotsGeom != "geom_jitter" && "color" %in% mapping) + data_arg$color <- options$plotsBackgroundColor + + # fixing afex issues with bootstrap and LRT type II SS - hopefully removeable in the future + if (type %in% c("LMM", "GLMM")) + if (options$method %in% c("LRT", "PB") && options$type == 2) + model <- model$full_model[[length(model$full_model)]] + + .setSeedJASP(options) + p <- tryCatch( + afex::afex_plot( + model, + dv = .v(options$dependentVariable), + x = .v(unlist(options$plotsX)), + trace = if (length(options$plotsTrace) != 0) .v(unlist(options$plotsTrace)), + panel = if (length(options$plotsPanel) != 0) .v(unlist(options$plotsPanel)), + id = .v(options$plotsAgregatedOver), + data_geom = getFromNamespace(options$plotsGeom, geom_package), + mapping = mapping, + error = options$plotsCImethod, + error_level = options$plotsCIwidth, + data_alpha = options$plotAlpha, + data_arg = if (length(data_arg) != 0) data_arg, + error_arg = list( + width = 0, + size = .5 * options$plotRelativeSize + ), + point_arg = list(size = 1.5 * options$plotRelativeSize), + line_arg = list(size = .5 * options$plotRelativeSize), + legend_title = paste(.unv(unlist(options$plotsTrace)), collapse = "\n"), + dodge = options$plotDodge + ), + error = function(e) + e + ) + + if (any(class(p) %in% c("simpleError", "error"))) { + plots$setError(p$message) + return() + } + + if (options$plotsGeom == "geom_violin" && (length(options$plotsAgregatedOver) == 1 && length(unique(dataset[, .v(options$plotsAgregatedOver)])) < 3)) { + plots$setError(gettext("Violin geom requires that the random effects grouping factors has at least 3 levels.")) + return() + } + + # fix the axis + p <- .mmFixPlotAxis(p) + + # fix names of the variables + p <- p + ggplot2::labs(x = unlist(options$plotsX), y = options$dependentVariable) + + # add theme + if (options$plotsTheme == "JASP") { + + p <- jaspGraphs::themeJasp(p, legend.position = options$plotLegendPosition) + + } else if (options$plotsTheme != "JASP") { + + p <- p + switch( + options$plotsTheme, + "theme_bw" = ggplot2::theme_bw() + ggplot2::theme(legend.position = "bottom"), + "theme_light" = ggplot2::theme_light() + ggplot2::theme(legend.position = "bottom"), + "theme_minimal" = ggplot2::theme_minimal() + ggplot2::theme(legend.position = "bottom"), + "theme_pubr" = jaspGraphs::themePubrRaw(legend = options$plotLegendPosition), + "theme_apa" = jaspGraphs::themeApaRaw(legend.pos = switch( + options$plotLegendPosition, + "none" = "none", + "botom" = "bottommiddle", + "right" = "bottomright", + "top" = "topmiddle", + "left" = "bottomleft" + )) + ) + + p <- p + ggplot2::theme( + legend.text = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), + legend.title = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), + axis.text = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), + axis.title = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), + legend.position = options$plotLegendPosition + ) + + } + + + plots$plotObject <- p + + if (options$plotsEstimatesTable) { + plotData <- afex::afex_plot( + model, + x = .v(unlist(options$plotsX)), + dv = .v(options$dependentVariable), + trace = if (length(options$plotsTrace) != 0) + .v(unlist(options$plotsTrace)), + panel = if (length(options$plotsPanel) != 0) + .v(unlist(options$plotsPanel)), + id = .v(options$plotsAgregatedOver), + data_geom = getFromNamespace(options$plotsGeom, geom_package), + error = options$plotsCImethod, + error_level = options$plotsCIwidth, + return = "data" + )$means + + + EstimatesTable <- + createJaspTable(title = gettext("Estimated Means and Confidence Intervals")) + EstimatesTable$position <- 5 + EstimatesTable$dependOn( + c( + dependencies, + "plotsX", + "plotsTrace", + "plotsPanel", + "plotsAgregatedOver", + "plotsCIwidth", + "plotsCImethod", + "seed", + "setSeed", + "plotsEstimatesTable" + ) + ) + + + for (v in attr(plotData, "pri.vars")) { + EstimatesTable$addColumnInfo(name = v, + title = .unv(v), + type = "string") + } + + for (v in options$marginalMeans) { + + } + + EstimatesTable$addColumnInfo(name = "mean", + title = gettext("Mean"), + type = "number") + if (options$plotsCImethod != "none") { + EstimatesTable$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) + ) + EstimatesTable$addColumnInfo( name = "upperCI", title = gettext("Upper"), type = "number", - overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) + overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) ) - if (options$marginalMeansCompare) { - EMMsummary$addColumnInfo( - name = "stat", - title = ifelse(colnames(emm_test)[ncol(emm_test) - 1] == "t.ratio", gettext("t"), gettext("z")), - type = "number" + } + + jaspResults[["EstimatesTable"]] <- EstimatesTable + + for (i in 1:nrow(plotData)) { + tempRow <- list() + for (v in attr(plotData, "pri.vars")) { + tempRow[v] <- as.character(plotData[i, v]) + } + + tempRow$mean <- plotData[i, "y"] + if (options$plotsCImethod != "none") { + tempRow$lowerCI <- plotData[i, "lower"] + tempRow$upperCI <- plotData[i, "upper"] + } + + EstimatesTable$addRows(tempRow) + } + + + } + + return() +} +.mmMarginalMeans <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["EMMresults"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + # deal with continuous predictors + at <- NULL + for (var in unlist(options$marginalMeans)) { + if (typeof(dataset[, .v(var)]) == "double") { + at[[.v(var)]] <- + c( + mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$marginalMeansSD * + sd(dataset[, .v(var)], na.rm = TRUE) ) - EMMsummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") - EMMsummary$addFootnote(.mmMessageTestNull(options$marginalMeansCompareTo), - symbol = "\u2020", colNames = "pval") - + } + } + + # compute the results + if (type == "LMM") { + emmeans::emm_options(pbkrtest.limit = if (options$marginalMeansOverride) + Inf, + mmrTest.limit = if (options$marginalMeansOverride) + Inf) + } + emm <- emmeans::emmeans( + object = model, + specs = .v(unlist(options$marginalMeans)), + at = at, + options = list(level = options$marginalMeansCIwidth), + lmer.df = if (type == "LMM") + options$marginalMeansDf + else if (type == "GLMM" && + options$family == "gaussian" && + options$link == "identity") + "asymptotic", + type = if (type %in% c("GLMM", "BGLMM")) + if (options$marginalMeansResponse) + "response" + ) + + emmTable <- as.data.frame(emm) + if (type %in% c("LMM", "GLMM")) { + if (options$marginalMeansCompare) { + emmTest <- + as.data.frame(emmeans::test(emm, null = options$marginalMeansCompareTo)) + } + } + + EMMsummary <- createJaspTable(title = gettext("Estimated Marginal Means")) + EMMresults <- createJaspState() + + EMMsummary$position <- 7 + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") + } else if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") + } + if (type %in% c("LMM", "GLMM")) { + dependenciesAdd <- + c( + "marginalMeans", + "marginalMeansSD", + "marginalMeansCompare", + "marginalMeansCompareTo", + "marginalMeansCIwidth", + "pvalVS", + "marginalMeansContrast" + ) + } else{ + dependenciesAdd <- + c( + "marginalMeans", + "marginalMeansSD", + "marginalMeansCIwidth", + "marginalMeansContrast" + ) + } + if (type == "LMM") { + dependenciesAdd <- + c(dependenciesAdd, + "marginalMeansOverride", + "marginalMeansDf") + } + EMMsummary$dependOn(c(dependencies, dependenciesAdd)) + EMMresults$dependOn(c(dependencies, dependenciesAdd)) + + if (options$marginalMeansContrast) { + EMMsummary$addColumnInfo(name = "number", + title = gettext("Row"), + type = "integer") + } + for (v in unlist(options$marginalMeans)) { + if (typeof(dataset[, .v(v)]) == "double") { + EMMsummary$addColumnInfo(name = .v(v), + title = .unv(v), + type = "number") + } else{ + EMMsummary$addColumnInfo(name = .v(v), + title = .unv(v), + type = "string") + } + } + + if (type %in% c("LMM", "GLMM")) { + EMMsummary$addColumnInfo(name = "estimate", + title = gettext("Estimate"), + type = "number") + EMMsummary$addColumnInfo(name = "se", + title = gettext("SE"), + type = "number") + if(type == "LMM"){ + if(options$marginalMeansDf != "asymptotic"){ + EMMsummary$addColumnInfo(name = "df", + title = gettext("df"), + type = "number") + } + } + EMMsummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) + ) + EMMsummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) + ) + if (options$marginalMeansCompare) { + EMMsummary$addColumnInfo( + name = "stat", + title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), + type = "number" + ) + EMMsummary$addColumnInfo(name = "pval", + title = gettext("p"), + type = "pvalue") + EMMsummary$addFootnote(.mmMessageTestNull(options$marginalMeansCompareTo), + symbol = "\u2020", colNames = "pval") + + if (options$pvalVS) { + EMMsummary$addColumnInfo(name = "pvalVS", + title = gettext("VS-MPR"), + type = "number") + EMMsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") + } + } + } else if (type %in% c("BLMM", "BGLMM")) { + EMMsummary$addColumnInfo(name = "estimate", + title = gettext("Median"), + type = "number") + EMMsummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) + ) + EMMsummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) + ) + } + + jaspResults[["EMMsummary"]] <- EMMsummary + + for (i in 1:nrow(emmTable)) { + tempRow <- list() + + if (options$marginalMeansContrast) { + tempRow$number <- i + } + + for (v in unlist(options$marginalMeans)) { + if (typeof(dataset[, .v(v)]) == "double") { + tempRow[.v(v)] <- emmTable[i, .v(v)] + } else{ + tempRow[.v(v)] <- as.character(emmTable[i, .v(v)]) + } + } + + if (type %in% c("LMM", "GLMM")) { + # the estimate is before SE (names change for GLMM) + tempRow$estimate <- + emmTable[i, grep("SE", colnames(emmTable)) - 1] + tempRow$se <- emmTable[i, "SE"] + if(type == "LMM"){ + if(options$marginalMeansDf != "asymptotic"){ + tempRow$df <- emmTable[i, "df"] + } + } + if (options$marginalMeansCompare) { + tempRow$stat <- emmTest[i, grep("ratio", colnames(emmTest))] + tempRow$pval <- emmTest[i, "p.value"] if (options$pvalVS) { - EMMsummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") - EMMsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) } } } else if (type %in% c("BLMM", "BGLMM")) { - EMMsummary$addColumnInfo(name = "estimate", - title = gettext("Median"), - type = "number") - EMMsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) + tempRow$estimate <- emmTable[i, ncol(emmTable) - 2] + } + + tempRow$lowerCI <- emmTable[i, ncol(emmTable) - 1] + tempRow$upperCI <- emmTable[i, ncol(emmTable)] + + + EMMsummary$addRows(tempRow) + } + + + if (length(emm@misc$avgd.over) != 0) { + EMMsummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) + } + # add warning message + if (type == "LMM") { + if (options$marginalMeansDf != attr(emm@dffun, "mesg")) { + EMMsummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) + } + } + if (type %in% c("GLMM","BGLMM")) { + EMMsummary$addFootnote( + ifelse( + options$marginalMeansResponse, + .mmMessageResponse, + .mmMessageNotResponse ) - EMMsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) + ) + } + + + + + object <- list(emm = emm, + emmTable = emmTable) + EMMresults$object <- object + jaspResults[["EMMresults"]] <- EMMresults + + return() +} +.mmTrends <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["contrasts_Trends"]])) + return() + + model <- jaspResults[["mmModel"]]$object$model + + # deal with continuous predictors + at <- NULL + for (var in unlist(options$trendsVariables)) { + if (typeof(dataset[, .v(var)]) == "double") { + at[[.v(var)]] <- + c( + mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$trendsSD * + sd(dataset[, .v(var)], na.rm = TRUE) + ) + } + } + + # compute the results + if (type %in% c("LMM")) { + emmeans::emm_options(pbkrtest.limit = if (options$trendsOverride) + Inf, + mmrTest.limit = if (options$trendsOverride) + Inf) + } + + # TODO: deal with the emtrends scoping problems + trendsCI <<- options$trendsCIwidth + trendsAt <<- at + trendsType <<- if (type == "LMM" || (type == "GLMM" && + options$family == "gaussian" && + options$link == "identity")) + "LMM" + else + type + trendsDataset <<- dataset + trendsModel <<- model + trendsDf <<- + if (type == "LMM") + options$trendsDf + else if (type == "GLMM" && + options$family == "gaussian" && + options$link == "identity") + "asymptotic" + + emm <- emmeans::emtrends( + object = trendsModel, + data = trendsDataset, + specs = .v(unlist(options$trendsVariables)), + var = .v(unlist(options$trendsTrend)), + at = trendsAt, + options = list(level = trendsCI), + lmer.df = if (trendsType == "LMM") + trendsDf + ) + emmTable <- as.data.frame(emm) + if (type %in% c("LMM", "GLMM")) { + if (options$trendsCompare) { + emmTest <- + as.data.frame(emmeans::test(emm, null = options$trendsCompareTo)) + } + } + + trendsSummary <- createJaspTable(title = gettext("Estimated Trends")) + EMTresults <- createJaspState() + + trendsSummary$position <- 9 + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- c(.mmDependenciesGLMM) + } else if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- c(.mmDependenciesBGLMM) + } + if (type %in% c("LMM", "GLMM")) { + dependenciesAdd <- + c( + "trendsVariables", + "trendsTrend", + "trendsSD", + "trendsCompare", + "trendsCompareTo", + "trendsCIwidth", + "pvalVS", + "trendsContrast" + ) + } else{ + dependenciesAdd <- + c( + "trendsVariables", + "trendsTrend", + "trendsSD", + "trendsCIwidth", + "trendsContrast" + ) + } + if (type == "LMM") { + dependenciesAdd <- + c(dependenciesAdd, "trendsDf", "trendsOverride") + } + trendsSummary$dependOn(c(dependencies, dependenciesAdd)) + EMTresults$dependOn(c(dependencies, dependenciesAdd)) + + if (options$trendsContrast) { + trendsSummary$addColumnInfo(name = "number", + title = gettext("Row"), + type = "integer") + } + + trendsVarNames <- colnames(emmTable)[1:(grep(".trend", colnames(emmTable), fixed = TRUE) - 1)] + + for (v in trendsVarNames) { + if (typeof(dataset[, .v(v)]) == "double") { + trendsSummary$addColumnInfo(name = v, + title = .unv(v), + type = "number") + } else{ + trendsSummary$addColumnInfo(name = v, + title = .unv(v), + type = "string") + } + } + trendsSummary$addColumnInfo( + name = "slope", + title = gettextf("%s (slope)",unlist(options$trendsTrend)), + type = "number" + ) + if (type %in% c("LMM", "GLMM")) { + trendsSummary$addColumnInfo(name = "se", + title = gettext("SE"), + type = "number") + if(type == "LMM"){ + if(options$trendsDf != "asymptotic"){ + trendsSummary$addColumnInfo(name = "df", + title = gettext("df"), + type = "number") + } + } + trendsSummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) + ) + trendsSummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) + ) + if (options$trendsCompare) { + trendsSummary$addColumnInfo( + name = "stat", + title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), + type = "number" ) + trendsSummary$addColumnInfo(name = "pval", + title = gettext("p"), + type = "pvalue") + trendsSummary$addFootnote(.mmMessageTestNull(options$trendsCompareTo), symbol = "\u2020", colNames = "pval") + + if (options$pvalVS) { + trendsSummary$addColumnInfo(name = "pvalVS", + title = gettext("VS-MPR"), + type = "number") + trendsSummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") + } + } + } else if (type %in% c("BLMM", "BGLMM")) { + trendsSummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) + ) + trendsSummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) + ) + } + + jaspResults[["trendsSummary"]] <- trendsSummary + + + for (i in 1:nrow(emmTable)) { + tempRow <- list() + + if (options$trendsContrast) { + tempRow$number <- i } - jaspResults[["EMMsummary"]] <- EMMsummary - - for (i in 1:nrow(emm_table)) { - temp_row <- list() - - if (options$marginalMeansContrast) { - temp_row$number <- i + for (vi in 1:length(trendsVarNames)) { + if (typeof(dataset[, .v(trendsVarNames[vi])]) == "double") { + tempRow[trendsVarNames[vi]] <- emmTable[i, vi] + } else{ + tempRow[trendsVarNames[vi]] <- + as.character(emmTable[i, vi]) } - - for (v in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(v)]) == "double") { - temp_row[.v(v)] <- emm_table[i, .v(v)] - } else{ - temp_row[.v(v)] <- as.character(emm_table[i, .v(v)]) + } + tempRow$slope <- emmTable[i, length(trendsVarNames) + 1] + + if (type %in% c("LMM", "GLMM")) { + # the estimate is before SE (names change for GLMM) + tempRow$se <- emmTable[i, "SE"] + if(type == "LMM"){ + if(options$trendsDf != "asymptotic"){ + tempRow$df <- emmTable[i, "df"] } } - - if (type %in% c("LMM", "GLMM")) { - # the estimate is before SE (names change for GLMM) - temp_row$estimate <- - emm_table[i, grep("SE", colnames(emm_table)) - 1] - temp_row$se <- emm_table[i, "SE"] - if(type == "LMM"){ - if(options$marginalMeansDf != "asymptotic"){ - temp_row$df <- emm_table[i, "df"] - } - } - if (options$marginalMeansCompare) { - temp_row$stat <- emm_test[i, grep("ratio", colnames(emm_test))] - temp_row$pval <- emm_test[i, "p.value"] - if (options$pvalVS) { - temp_row$pvalVS <- VovkSellkeMPR(temp_row$pval) - } + + if (options$trendsCompare) { + tempRow$stat <- emmTest[i, grep("ratio", colnames(emmTest))] + tempRow$pval <- emmTest[i, "p.value"] + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) } - } else if (type %in% c("BLMM", "BGLMM")) { - temp_row$estimate <- emm_table[i, ncol(emm_table) - 2] - } - - temp_row$lowerCI <- emm_table[i, ncol(emm_table) - 1] - temp_row$upperCI <- emm_table[i, ncol(emm_table)] - - - EMMsummary$addRows(temp_row) - } - - - if (length(emm@misc$avgd.over) != 0) { - EMMsummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) - } - # add warning message - if (type == "LMM") { - if (options$marginalMeansDf != attr(emm@dffun, "mesg")) { - EMMsummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) } } - if (type %in% c("GLMM","BGLMM")) { - EMMsummary$addFootnote( - ifelse( - options$marginalMeansResponse, - .mmMessageResponse, - .mmMessageNotResponse - ) - ) - } - - - - object <- list(emm = emm, - emm_table = emm_table) - EMMresults$object <- object - jaspResults[["EMMresults"]] <- EMMresults - - return() + tempRow$lowerCI <- emmTable[i, ncol(emmTable) - 1] + tempRow$upperCI <- emmTable[i, ncol(emmTable)] + + + trendsSummary$addRows(tempRow) } -.mmTrends <- function(jaspResults, dataset, options, type = "LMM") { + + + if (length(emm@misc$avgd.over) != 0) { + trendsSummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) + } + # add warning message + if (type == "LMM") { + if (options$trendsDf != attr(emm@dffun, "mesg")) { + # TODO: for GLMM + trendsSummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) + } + } + if (type == "GLMM") { + trendsSummary$addFootnote(.mmMessageNotResponse) + } + + + + + object <- list(emm = emm, + emmTable = emmTable) + EMTresults$object <- object + + jaspResults[["EMTresults"]] <- EMTresults + + return() +} +.mmContrasts <- function(jaspResults, options, type = "LMM", what = "Means") { + if (what == "Means") { + if (!is.null(jaspResults[["contrasts_Means"]])) + return() + emm <- jaspResults[["EMMresults"]]$object$emm + emmTable <- jaspResults[["EMMresults"]]$object$emmTable + } else if (what == "Trends") { if (!is.null(jaspResults[["contrasts_Trends"]])) return() - - model <- jaspResults[["mmModel"]]$object$model - - # deal with continuous predictors - at <- NULL - for (var in unlist(options$trendsVariables)) { - if (typeof(dataset[, .v(var)]) == "double") { - at[[.v(var)]] <- - c( - mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$trendsSD * - sd(dataset[, .v(var)], na.rm = TRUE) - ) - } - } - - # compute the results - if (type %in% c("LMM")) { - emmeans::emm_options(pbkrtest.limit = if (options$trendsOverride) - Inf, - mmrTest.limit = if (options$trendsOverride) - Inf) - } - - # TODO: deal with the emtrends scoping problems - trends_CI <<- options$trendsCIwidth - trends_at <<- at - trends_type <<- if (type == "LMM" || (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity")) - "LMM" - else - type - trends_dataset <<- dataset - trends_model <<- model - trends_df <<- - if (type == "LMM") - options$trendsDf - else if (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity") - "asymptotic" - - emm <- emmeans::emtrends( - object = trends_model, - data = trends_dataset, - specs = .v(unlist(options$trendsVariables)), - var = .v(unlist(options$trendsTrend)), - at = trends_at, - options = list(level = trends_CI), - lmer.df = if (trends_type == "LMM") - trends_df - ) - emm_table <- as.data.frame(emm) + emm <- jaspResults[["EMTresults"]]$object$emm + emmTable <- jaspResults[["EMTresults"]]$object$emmTable + } + + + EMMCsummary <- createJaspTable(title = gettext("Contrasts")) + + EMMCsummary$position <- ifelse(what == "Means", 8, 10) + if (type == "LMM") { + dependencies <- .mmDependenciesLMM + } else if (type == "GLMM") { + dependencies <- + c(.mmDependenciesGLMM, if (what == "Means") + "marginalMeansResponse") + } else if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- + c(.mmDependenciesBGLMM, if (what == "Means") + "marginalMeansResponse") + } + if (what == "Means") { if (type %in% c("LMM", "GLMM")) { - if (options$trendsCompare) { - emm_test <- - as.data.frame(emmeans::test(emm, null = options$trendsCompareTo)) - } - } - - trendsSummary <- createJaspTable(title = gettext("Estimated Trends")) - EMTresults <- createJaspState() - - trendsSummary$position <- 9 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM) - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- c(.mmDependenciesBGLMM) + dependenciesAdd <- + c( + "marginalMeans", + "marginalMeansDf", + "marginalMeansSD", + "marginalMeansCompare", + "marginalMeansCompareTo", + "marginalMeansContrast", + "marginalMeansCIwidth", + "pvalVS", + "marginalMeansOverride", + "Contrasts", + "marginalMeansAdjustment" + ) + } else{ + dependenciesAdd <- + c( + "marginalMeans", + "marginalMeansSD", + "marginalMeansContrast", + "marginalMeansCIwidth", + "Contrasts" + ) } + } else if (what == "Trends") { if (type %in% c("LMM", "GLMM")) { - dependencies_add <- + dependenciesAdd <- c( "trendsVariables", "trendsTrend", + "trendsDf", "trendsSD", "trendsCompare", "trendsCompareTo", + "trendsContrast", + "trendsContrasts", "trendsCIwidth", "pvalVS", - "trendsContrast" + "trendsOverride", + "trendsAdjustment" ) } else{ - dependencies_add <- + dependenciesAdd <- c( "trendsVariables", "trendsTrend", "trendsSD", "trendsCIwidth", - "trendsContrast" + "trendsContrast", + "trendsContrasts" ) } - if (type == "LMM") { - dependencies_add <- - c(dependencies_add, "trendsDf", "trendsOverride") - } - trendsSummary$dependOn(c(dependencies, dependencies_add)) - EMTresults$dependOn(c(dependencies, dependencies_add)) - - if (options$trendsContrast) { - trendsSummary$addColumnInfo(name = "number", - title = gettext("Row"), - type = "integer") - } - - trends_var_names <- - colnames(emm_table)[1:(grep(".trend", colnames(emm_table), fixed = TRUE) - - 1)] - for (v in trends_var_names) { - if (typeof(dataset[, .v(v)]) == "double") { - trendsSummary$addColumnInfo(name = v, - title = .unv(v), - type = "number") - } else{ - trendsSummary$addColumnInfo(name = v, - title = .unv(v), - type = "string") - } + } + + EMMCsummary$dependOn(c(dependencies, dependenciesAdd)) + + + if (type %in% c("LMM", "GLMM")) { + EMMCsummary$addColumnInfo(name = "contrast", + title = "", + type = "string") + EMMCsummary$addColumnInfo(name = "estimate", + title = gettext("Estimate"), + type = "number") + EMMCsummary$addColumnInfo(name = "se", + title = gettext("SE"), + type = "number") + EMMCsummary$addColumnInfo(name = "df", + title = gettext("df"), + type = "number") + EMMCsummary$addColumnInfo(name = "stat", + title = gettext("z"), + type = "number") + EMMCsummary$addColumnInfo(name = "pval", + title = gettext("p"), + type = "pvalue") + if (options$pvalVS) { + EMMCsummary$addColumnInfo(name = "pvalVS", + title = gettext("VS-MPR"), + type = "number") + EMMCsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") } - trendsSummary$addColumnInfo( - name = "slope", - title = gettextf("%s (slope)",unlist(options$trendsTrend)), - type = "number" - ) - if (type %in% c("LMM", "GLMM")) { - trendsSummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - if(type == "LMM"){ - if(options$trendsDf != "asymptotic"){ - trendsSummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - } - } - trendsSummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) - ) - trendsSummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) - ) - if (options$trendsCompare) { - trendsSummary$addColumnInfo( - name = "stat", - title = ifelse(colnames(emm_test)[ncol(emm_test) - 1] == "t.ratio", gettext("t"), gettext("z")), - type = "number" - ) - trendsSummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") - trendsSummary$addFootnote(.mmMessageTestNull(options$trendsCompareTo), symbol = "\u2020", colNames = "pval") - - if (options$pvalVS) { - trendsSummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") - trendsSummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") - } - } - } else if (type %in% c("BLMM", "BGLMM")) { - trendsSummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) + } else if (type %in% c("BLMM", "BGLMM")) { + EMMCsummary$addColumnInfo(name = "contrast", + title = "", + type = "string") + EMMCsummary$addColumnInfo(name = "estimate", + title = gettext("Estimate"), + type = "number") + EMMCsummary$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf( + "%s%% HPD", + 100 * if (what == "Means") + options$marginalMeansCIwidth + else + options$trendsCIwidth ) - trendsSummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) + ) + EMMCsummary$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf( + "%s%% HPD", + 100 * if (what == "Means") + options$marginalMeansCIwidth + else + options$trendsCIwidth ) - } + ) + } - jaspResults[["trendsSummary"]] <- trendsSummary - - - for (i in 1:nrow(emm_table)) { - temp_row <- list() - - if (options$trendsContrast) { - temp_row$number <- i - } - - for (vi in 1:length(trends_var_names)) { - if (typeof(dataset[, .v(trends_var_names[vi])]) == "double") { - temp_row[trends_var_names[vi]] <- emm_table[i, vi] - } else{ - temp_row[trends_var_names[vi]] <- - as.character(emm_table[i, vi]) - } - } - temp_row$slope <- emm_table[i, length(trends_var_names) + 1] - - if (type %in% c("LMM", "GLMM")) { - # the estimate is before SE (names change for GLMM) - temp_row$se <- emm_table[i, "SE"] - if(type == "LMM"){ - if(options$trendsDf != "asymptotic"){ - temp_row$df <- emm_table[i, "df"] - } - } - - if (options$trendsCompare) { - temp_row$stat <- emm_test[i, grep("ratio", colnames(emm_test))] - temp_row$pval <- emm_test[i, "p.value"] - if (options$pvalVS) { - temp_row$pvalVS <- VovkSellkeMPR(temp_row$pval) - } - } - } - - temp_row$lowerCI <- emm_table[i, ncol(emm_table) - 1] - temp_row$upperCI <- emm_table[i, ncol(emm_table)] - - - trendsSummary$addRows(temp_row) - } - - - if (length(emm@misc$avgd.over) != 0) { - trendsSummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) - } - # add warning message - if (type == "LMM") { - if (options$trendsDf != attr(emm@dffun, "mesg")) { - # TODO: for GLMM - trendsSummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) - } - } - if (type == "GLMM") { - trendsSummary$addFootnote(.mmMessageNotResponse) + # Columns have been specified, show to user + jaspResults[[paste0("contrasts_", what)]] <- EMMCsummary + + if (what == "Means") { + selectedContrasts <- options$Contrasts + selectedAdjustment <- options$marginalMeansAdjustment + + if (type %in% c("GLMM", "BGLMM")) { + selectedResponse <- options$marginalMeansResponse } - - - object <- list(emm = emm, - emm_table = emm_table) - EMTresults$object <- object + } else if (what == "Trends") { + selectedContrasts <- options$trendsContrasts + selectedAdjustment <- options$trendsAdjustment + } - jaspResults[["EMTresults"]] <- EMTresults - + contrs <- list() + i <- 0 + for (cont in selectedContrasts[sapply(selectedContrasts, function(x) + x$isContrast)]) { + if (all(cont$values == 0)) + next + i <- i + 1 + contrs[[cont$name]] <- + unname(sapply(cont$values, function(x) + eval(parse(text = x)))) + } + if (length(contrs) == 0) { return() } -.mmContrasts <- function(jaspResults, options, type = "LMM", what = "Means") { - if (what == "Means") { - if (!is.null(jaspResults[["contrasts_Means"]])) - return() - emm <- jaspResults[["EMMresults"]]$object$emm - emm_table <- jaspResults[["EMMresults"]]$object$emm_table - } else if (what == "Trends") { - if (!is.null(jaspResults[["contrasts_Trends"]])) - return() - emm <- jaspResults[["EMTresults"]]$object$emm - emm_table <- jaspResults[["EMTresults"]]$object$emm_table - } - - - EMMCsummary <- createJaspTable(title = gettext("Contrasts")) - - EMMCsummary$position <- ifelse(what == "Means", 8, 10) - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- - c(.mmDependenciesGLMM, if (what == "Means") - "marginalMeansResponse") - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- - c(.mmDependenciesBGLMM, if (what == "Means") - "marginalMeansResponse") - } - if (what == "Means") { - if (type %in% c("LMM", "GLMM")) { - dependencies_add <- - c( - "marginalMeans", - "marginalMeansDf", - "marginalMeansSD", - "marginalMeansCompare", - "marginalMeansCompareTo", - "marginalMeansContrast", - "marginalMeansCIwidth", - "pvalVS", - "marginalMeansOverride", - "Contrasts", - "marginalMeansAdjustment" - ) - } else{ - dependencies_add <- - c( - "marginalMeans", - "marginalMeansSD", - "marginalMeansContrast", - "marginalMeansCIwidth", - "Contrasts" - ) - } - } else if (what == "Trends") { - if (type %in% c("LMM", "GLMM")) { - dependencies_add <- - c( - "trendsVariables", - "trendsTrend", - "trendsDf", - "trendsSD", - "trendsCompare", - "trendsCompareTo", - "trendsContrast", - "trendsContrasts", - "trendsCIwidth", - "pvalVS", - "trendsOverride", - "trendsAdjustment" - ) - } else{ - dependencies_add <- - c( - "trendsVariables", - "trendsTrend", - "trendsSD", - "trendsCIwidth", - "trendsContrast", - "trendsContrasts" + + + # take care of the scale + if (type %in% c("LMM", "BLMM") || what == "Trends") { + emmContrast <- tryCatch( + as.data.frame( + emmeans::contrast(emm, contrs, + adjust = if (type %in% c("LMM", "GLMM")) + selectedAdjustment) + ), + error = function(e) + e + ) + } else if (type %in% c("GLMM", "BGLMM")) { + if (selectedResponse) { + emmContrast <- tryCatch( + as.data.frame( + emmeans::contrast( + emmeans::regrid(emm), + contrs, + adjust = if (type == "GLMM") + selectedAdjustment ) - } - } - - EMMCsummary$dependOn(c(dependencies, dependencies_add)) - - - if (type %in% c("LMM", "GLMM")) { - EMMCsummary$addColumnInfo(name = "contrast", - title = "", - type = "string") - EMMCsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMCsummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - EMMCsummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - EMMCsummary$addColumnInfo(name = "stat", - title = gettext("z"), - type = "number") - EMMCsummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") - if (options$pvalVS) { - EMMCsummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") - EMMCsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") - } - } else if (type %in% c("BLMM", "BGLMM")) { - EMMCsummary$addColumnInfo(name = "contrast", - title = "", - type = "string") - EMMCsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMCsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf( - "%s%% HPD", - 100 * if (what == "Means") - options$marginalMeansCIwidth - else - options$trendsCIwidth - ) - ) - EMMCsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf( - "%s%% HPD", - 100 * if (what == "Means") - options$marginalMeansCIwidth - else - options$trendsCIwidth - ) + ), + error = function(e) + e ) - } - - # Columns have been specified, show to user - jaspResults[[paste0("contrasts_", what)]] <- EMMCsummary - - if (what == "Means") { - selectedContrasts <- options$Contrasts - selectedAdjustment <- options$marginalMeansAdjustment - - if (type %in% c("GLMM", "BGLMM")) { - selectedResponse <- options$marginalMeansResponse - } - - - } else if (what == "Trends") { - selectedContrasts <- options$trendsContrasts - selectedAdjustment <- options$trendsAdjustment - } - - contrs <- list() - i <- 0 - for (cont in selectedContrasts[sapply(selectedContrasts, function(x) - x$isContrast)]) { - if (all(cont$values == 0)) - next - i <- i + 1 - contrs[[cont$name]] <- - unname(sapply(cont$values, function(x) - eval(parse(text = x)))) - } - if (length(contrs) == 0) { - return() - } - - - # take care of the scale - if (type %in% c("LMM", "BLMM") || what == "Trends") { - emm_contrast <- tryCatch( + } else{ + emmContrast <- tryCatch( as.data.frame( emmeans::contrast(emm, contrs, - adjust = if (type %in% c("LMM", "GLMM")) + adjust = if (type == "GLMM") selectedAdjustment) ), error = function(e) e ) - } else if (type %in% c("GLMM", "BGLMM")) { - if (selectedResponse) { - emm_contrast <- tryCatch( - as.data.frame( - emmeans::contrast( - emmeans::regrid(emm), - contrs, - adjust = if (type == "GLMM") - selectedAdjustment - ) - ), - error = function(e) - e - ) - } else{ - emm_contrast <- tryCatch( - as.data.frame( - emmeans::contrast(emm, contrs, - adjust = if (type == "GLMM") - selectedAdjustment) - ), - error = function(e) - e - ) - } } - - if (length(emm_contrast) == 2) { - EMMCsummary$setError(emm_contrast$message) - return() + } + + if (length(emmContrast) == 2) { + EMMCsummary$setError(emmContrast$message) + return() + } + + # fix the title name if there is a t-stats + if (type %in% c("LMM", "GLMM")) + if (colnames(emmContrast)[5] == "t.ratio") + EMMCsummary$setColumnTitle("stat", gettext("t")) + if (type %in% c("GLMM", "BGLMM")) { + if (type == "GLMM") { + tempEstName <- colnames(emmContrast)[ncol(emmContrast) - 4] + } else if (type == "BGLMM") { + tempEstName <- colnames(emmContrast)[ncol(emmContrast) - 2] } - - # fix the title name if there is a t-stats - if (type %in% c("LMM", "GLMM")) - if (colnames(emm_contrast)[5] == "t.ratio") - EMMCsummary$setColumnTitle("stat", gettext("t")) - if (type %in% c("GLMM", "BGLMM")) { - if (type == "GLMM") { - temp_est_name <- colnames(emm_contrast)[ncol(emm_contrast) - 4] - } else if (type == "BGLMM") { - temp_est_name <- colnames(emm_contrast)[ncol(emm_contrast) - 2] - } - if (temp_est_name == "odds.ratio") { - EMMCsummary$setColumnTitle("estimate", gettext("Odds Ratio")) - } else if (temp_est_name == "ratio") { - EMMCsummary$setColumnTitle("estimate", gettext("Ratio")) - } else if (temp_est_name == "estimate") { - EMMCsummary$setColumnTitle("estimate", gettext("Estimate")) - } else{ - EMMCsummary$setColumnTitle("estimate", temp_est_name) - } - } - - for (i in 1:nrow(emm_contrast)) { - if (type %in% c("LMM", "GLMM")) { - temp_row <- list( - contrast = names(contrs)[i], - estimate = emm_contrast[i, ncol(emm_contrast) - 4], - se = emm_contrast[i, "SE"], - df = emm_contrast[i, "df"], - stat = emm_contrast[i, ncol(emm_contrast) - 1], - pval = emm_contrast[i, "p.value"] - ) - if (options$pvalVS) { - temp_row$pvalVS <- VovkSellkeMPR(temp_row$pval) - } - - EMMCsummary$addFootnote(.messagePvalAdjustment(selectedAdjustment), symbol = "\u2020", colNames = "pval") - if (options$pvalVS) { - temp_row$pvalVS <- VovkSellkeMPR(temp_row$pval) - } - - } else if (type %in% c("BLMM", "BGLMM")) { - temp_row <- list( - contrast = names(contrs)[i], - estimate = emm_contrast[i, ncol(emm_contrast) - 2], - lowerCI = emm_contrast[i, "lower.HPD"], - upperCI = emm_contrast[i, "upper.HPD"] - ) + if (tempEstName == "odds.ratio") { + EMMCsummary$setColumnTitle("estimate", gettext("Odds Ratio")) + } else if (tempEstName == "ratio") { + EMMCsummary$setColumnTitle("estimate", gettext("Ratio")) + } else if (tempEstName == "estimate") { + EMMCsummary$setColumnTitle("estimate", gettext("Estimate")) + } else{ + EMMCsummary$setColumnTitle("estimate", tempEstName) + } + } + + for (i in 1:nrow(emmContrast)) { + if (type %in% c("LMM", "GLMM")) { + tempRow <- list( + contrast = names(contrs)[i], + estimate = emmContrast[i, ncol(emmContrast) - 4], + se = emmContrast[i, "SE"], + df = emmContrast[i, "df"], + stat = emmContrast[i, ncol(emmContrast) - 1], + pval = emmContrast[i, "p.value"] + ) + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) } - - - if (type %in% c("GLMM", "BGLMM") && what == "Means") { - if (!selectedResponse) { - EMMCsummary$addFootnote(.mmMessageNotResponse) - } else{ - EMMCsummary$addFootnote(.mmMessageResponse) - } + + EMMCsummary$addFootnote(.messagePvalAdjustment(selectedAdjustment), symbol = "\u2020", colNames = "pval") + if (options$pvalVS) { + tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) + } + + } else if (type %in% c("BLMM", "BGLMM")) { + tempRow <- list( + contrast = names(contrs)[i], + estimate = emmContrast[i, ncol(emmContrast) - 2], + lowerCI = emmContrast[i, "lower.HPD"], + upperCI = emmContrast[i, "upper.HPD"] + ) + } + + + if (type %in% c("GLMM", "BGLMM") && what == "Means") { + if (!selectedResponse) { + EMMCsummary$addFootnote(.mmMessageNotResponse) + } else{ + EMMCsummary$addFootnote(.mmMessageResponse) } - - - EMMCsummary$addRows(temp_row) - } + + + EMMCsummary$addRows(tempRow) + } +} # specific Bayesian @@ -2115,213 +5404,213 @@ } } .mmFitModelB <- function(jaspResults, dataset, options, type = "BLMM") { - # hopefully fixing the random errors - contr.bayes <<- stanova::contr.bayes - stan_glmer <- rstanarm::stan_glmer - if (!is.null(jaspResults[["mmModel"]])) - return() - - mmModel <- createJaspState() + # hopefully fixing the random errors + contr.bayes <<- stanova::contr.bayes + stan_glmer <- rstanarm::stan_glmer + if (!is.null(jaspResults[["mmModel"]])) + return() + + mmModel <- createJaspState() + + + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + mmModel$dependOn(dependencies) - - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM + modelFormula <- .mmModelFormula(options, dataset) + + if (type == "BLMM") { + model <- tryCatch(stanova::stanova( + formula = as.formula(modelFormula$modelFormula), + check_contrasts = "contr.bayes", + data = dataset, + chains = options$chains, + iter = options$iteration, + warmup = options$warmup, + adapt_delta = options$adapt_delta, + control = list(maxTreedepth = options$max_treedepth), + seed = .getSeedJASP(options), + model_fun = "lmer" + ), error = function(e) e ) + + } else if (type == "BGLMM") { + # needs to be evaluated in the global environment + glmmLink <<- options$link + if (options$family == "neg_binomial_2") { + glmmFamily <<- rstanarm::neg_binomial_2(link = glmmLink) + } else if (options$family == "betar") { + glmmFamily <<- mgcv::betar(link = glmmLink) + } else if (options$family != "binomial_agg"){ + tempFamily <<- options$family + glmmFamily <<- eval(call(tempFamily, glmmLink)) } - mmModel$dependOn(dependencies) - - model_formula <- .mmModelFormula(options, dataset) - if (type == "BLMM") { + # I wish there was a better way to do this + if (options$family == "binomial_agg") { + glmmWeight <<- dataset[, .v(options$dependentVariableAggregation)] + model <- tryCatch(stanova::stanova( - formula = as.formula(model_formula$model_formula), + formula = as.formula(modelFormula$modelFormula), check_contrasts = "contr.bayes", data = dataset, chains = options$chains, iter = options$iteration, warmup = options$warmup, adapt_delta = options$adapt_delta, - control = list(max_treedepth = options$max_treedepth), + control = list(maxTreedepth = options$max_treedepth), + weights = glmmWeight, + family = eval(call("binomial", glmmLink)), seed = .getSeedJASP(options), - model_fun = "lmer" + model_fun = "glmer" ), error = function(e) e ) - - } else if (type == "BGLMM") { - # needs to be evaluated in the global environment - glmm_link <<- options$link - if (options$family == "neg_binomial_2") { - glmm_family <<- rstanarm::neg_binomial_2(link = glmm_link) - } else if (options$family == "betar") { - glmm_family <<- mgcv::betar(link = glmm_link) - } else if (options$family != "binomial_agg"){ - temp_family <<- options$family - glmm_family <<- eval(call(temp_family, glmm_link)) - } - - # I wish there was a better way to do this - if (options$family == "binomial_agg") { - glmm_weight <<- dataset[, .v(options$dependentVariableAggregation)] - - model <- tryCatch(stanova::stanova( - formula = as.formula(model_formula$model_formula), - check_contrasts = "contr.bayes", - data = dataset, - chains = options$chains, - iter = options$iteration, - warmup = options$warmup, - adapt_delta = options$adapt_delta, - control = list(max_treedepth = options$max_treedepth), - weights = glmm_weight, - family = eval(call("binomial", glmm_link)), - seed = .getSeedJASP(options), - model_fun = "glmer" - ), error = function(e) e ) - - } else{ - model <- tryCatch(stanova::stanova( - formula = as.formula(model_formula$model_formula), - check_contrasts = "contr.bayes", - data = dataset, - chains = options$chains, - iter = options$iteration, - warmup = options$warmup, - adapt_delta = options$adapt_delta, - control = list(max_treedepth = options$max_treedepth), - family = glmm_family, - seed = .getSeedJASP(options), - model_fun = "glmer" - ), error = function(e) e ) - - } - - } - + + } else{ + model <- tryCatch(stanova::stanova( + formula = as.formula(modelFormula$modelFormula), + check_contrasts = "contr.bayes", + data = dataset, + chains = options$chains, + iter = options$iteration, + warmup = options$warmup, + adapt_delta = options$adapt_delta, + control = list(maxTreedepth = options$max_treedepth), + family = glmmFamily, + seed = .getSeedJASP(options), + model_fun = "glmer" + ), error = function(e) e ) + + } + + } + if (inherits(model, "error")) { if (model$message == "Dropping columns failed to produce full column rank design matrix") .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. The most likely reason for this issue is a factor / combination of factors leading to more levels than are estimable.")) else .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model$message)) } - - object <- list( - model = model, - removed_me = model_formula$removed_me, - removed_te = model_formula$removed_te - ) - - mmModel$object <- object - jaspResults[["mmModel"]] <- mmModel - - return() - } + + object <- list( + model = model, + removedMe = modelFormula$removedMe, + removedTe = modelFormula$removedTe + ) + + mmModel$object <- object + jaspResults[["mmModel"]] <- mmModel + + return() +} .mmFitStatsB <- function(jaspResults, options, type = "BLMM") { if (!is.null(jaspResults[["fitStats"]])) return() - + model <- jaspResults[["mmModel"]]$object$model - + fitSummary <- createJaspContainer("Model summary") fitSummary$position <- 2 - + if (type == "BLMM") { dependencies <- .mmDependenciesBLMM } else if (type == "BGLMM") { dependencies <- .mmDependenciesBGLMM } - + fitSummary$dependOn(c(dependencies, "fitStats")) jaspResults[["fitSummary"]] <- fitSummary - + ### fit statistics fitStats <- createJaspTable(title = gettext("Fit Statistics")) fitStats$position <- 1 - + fitStats$addColumnInfo(name = "waic", title = gettext("WAIC"), type = "number") fitStats$addColumnInfo(name = "waicSE", title = gettext("SE (WAIC)"), type = "number") fitStats$addColumnInfo(name = "loo", title = gettext("LOO"), type = "number") fitStats$addColumnInfo(name = "looSE", title = gettext("SE (LOO)"), type = "number") - + jaspResults[["fitSummary"]][["fitStats"]] <- fitStats - + waic <- loo::waic(model) loo <- loo::loo(model) nBadWAIC <- sum(waic$pointwise[,2] > 0.4) nBadLOO <- length(loo::pareto_k_ids(loo, threshold = .7)) - - + + if (nBadWAIC > 0) - fitStats$addFootnote(.mmMessageBadWAIC(nBadWAIC), symbol = gettext("Warning:")) + fitStats$addFootnote(.mmMessageBadWAIC(nBadWAIC), symbol = gettext("Warning:")) if (nBadLOO > 0) - fitStats$addFootnote(.mmMessageBadLOO(nBadLOO), symbol = gettext("Warning:")) - - - temp_row <- list( + fitStats$addFootnote(.mmMessageBadLOO(nBadLOO), symbol = gettext("Warning:")) + + + tempRow <- list( waic = waic$estimates["waic", "Estimate"], waicSE = waic$estimates["waic", "SE"], loo = loo$estimates["looic", "Estimate"], looSE = loo$estimates["looic", "SE"] ) - - fitStats$addRows(temp_row) + + fitStats$addRows(tempRow) ### sample sizes - stanova_summary <- stanova:::summary.stanova(model) - + stanovaSummary <- stanova:::summary.stanova(model) + fitSizes <- createJaspTable(title = gettext("Sample sizes")) fitSizes$position <- 2 - + fitSizes$addColumnInfo(name = "observations", title = gettext("Observations"), type = "integer") - temp_row <- list( - observations = attr(stanova_summary, "nobs") + tempRow <- list( + observations = attr(stanovaSummary, "nobs") ) - for (n in names(attr(stanova_summary, "ngrps"))) { + for (n in names(attr(stanovaSummary, "ngrps"))) { fitSizes$addColumnInfo(name = n, title = .unv(n), type = "integer", overtitle = gettext("Levels of RE grouping factors")) - temp_row[[n]] <- attr(stanova_summary, "ngrps")[[n]] + tempRow[[n]] <- attr(stanovaSummary, "ngrps")[[n]] } - fitSizes$addRows(temp_row) + fitSizes$addRows(tempRow) jaspResults[["fitSummary"]][["fitSizes"]] <- fitSizes - + return() } .mmSummaryREB <- function(jaspResults, options, type = "BLMM") { if (!is.null(jaspResults[["REsummary"]])) return() - + model <- jaspResults[["mmModel"]]$object$model - + REsummary <- createJaspContainer(title = gettext("Variance/Correlation Estimates")) - + REsummary$position <- 4 - + if (type == "BLMM") { dependencies <- .mmDependenciesBLMM } else if (type == "BGLMM") { dependencies <- .mmDependenciesBGLMM } REsummary$dependOn(c(dependencies, "showRE", "summaryCI")) - + ### keep this if we decide to change things - #model_summary <- rstan::summary(model$stanfit, probs = c(.5-options$summaryCI/2, .5+options$summaryCI/2))$summary - #names_summary <- rownames(model_summary) - #re_names <- names_summary[grepl("Sigma[", names_summary, fixed = T)] + #modelSummary <- rstan::summary(model$stanfit, probs = c(.5-options$summaryCI/2, .5+options$summaryCI/2))$summary + #namesSummary <- rownames(modelSummary) + #re_names <- namesSummary[grepl("Sigma[", namesSummary, fixed = T)] #re_groups <- sapply(re_names, function(x){ # substr(x,7,regexpr(":", x, fixed = TRUE)[1]-1) #}) - #re_summary <- model_summary[names_summary %in% re_names,] - #s_summary <- model_summary[names_summary == "sigma",] - + #re_summary <- modelSummary[namesSummary %in% re_names,] + #s_summary <- modelSummary[namesSummary == "sigma",] + VarCorr <- rstanarm:::VarCorr.stanreg(model) # go over each random effect grouping factor for (gi in 1:length(VarCorr)) { - temp_VarCorr <- VarCorr[[gi]] - + tempVarCorr <- VarCorr[[gi]] + # add variance summary REvar <- createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) - + REvar$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") @@ -2331,99 +5620,99 @@ REvar$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") - - temp_StdDev <- attr(temp_VarCorr, "stddev") - for (i in 1:length(temp_StdDev)) { - if (names(temp_StdDev)[i] == "(Intercept)") { - var_name <- gettext("Intercept") + + tempStdDev <- attr(tempVarCorr, "stddev") + for (i in 1:length(tempStdDev)) { + if (names(tempStdDev)[i] == "(Intercept)") { + varName <- gettext("Intercept") } else{ - var_name <- .mmVariableNames(names(temp_StdDev)[i], options$fixedVariables) + varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) } - - temp_row <- list( - variable = var_name, - std = temp_StdDev[i], - var = temp_StdDev[i]^2 + + tempRow <- list( + variable = varName, + std = tempStdDev[i], + var = tempStdDev[i]^2 ) - - REvar$addRows(temp_row) + + REvar$addRows(tempRow) } - + REvar$addFootnote(.mmMessageInterpretability) - + REsummary[[paste0("VE", gi)]] <- REvar - - + + # add correlation summary - if (length(temp_StdDev) > 1) { - temp_Corr <- attr(temp_VarCorr, "correlation") + if (length(tempStdDev) > 1) { + tempCorr <- attr(tempVarCorr, "correlation") REcor <- createJaspTable(title = gettextf("%s: Correlation Estimates",.unv(names(VarCorr)[gi]))) - + # add columns REcor$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") - for (i in 1:nrow(temp_Corr)) { - if (rownames(temp_Corr)[i] == "(Intercept)") { - var_name <- gettext("Intercept") + for (i in 1:nrow(tempCorr)) { + if (rownames(tempCorr)[i] == "(Intercept)") { + varName <- gettext("Intercept") } else{ - var_name <- .mmVariableNames(rownames(temp_Corr)[i], options$fixedVariables) + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) } REcor$addColumnInfo(name = paste0("v", i), - title = var_name, + title = varName, type = "number") } - + # fill rows - for (i in 1:nrow(temp_Corr)) { - if (rownames(temp_Corr)[i] == "(Intercept)") { - var_name <- gettext("Intercept") + for (i in 1:nrow(tempCorr)) { + if (rownames(tempCorr)[i] == "(Intercept)") { + varName <- gettext("Intercept") } else{ - var_name <- .mmVariableNames(rownames(temp_Corr)[i], options$fixedVariables) + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) } - - temp_row <- list(variable = var_name) + + tempRow <- list(variable = varName) for (j in 1:i) { - # ncol(temp_Corr) - temp_row[paste0("v", j)] <- temp_Corr[i, j] + # ncol(tempCorr) + tempRow[paste0("v", j)] <- tempCorr[i, j] } - REcor$addRows(temp_row) + REcor$addRows(tempRow) } - + REcor$addFootnote(.mmMessageInterpretability) - + REsummary[[paste0("CE", gi)]] <- REcor - + } - + } - + # add residual variance summary REres <- createJaspTable(title = gettext("Residual Variance Estimates")) - + REres$addColumnInfo(name = "std", title = gettext("Std. Deviation"), type = "number") REres$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") jaspResults[["REsummary"]] <- REsummary - - temp_row <- list( + + tempRow <- list( std = rstanarm:::sigma.stanreg(model), var = rstanarm:::sigma.stanreg(model)^2 ) - - REres$addRows(temp_row) + + REres$addRows(tempRow) REsummary[["RES"]] <- REres - + return() } .mmSummaryFEB <- function(jaspResults, options, type = "BLMM") { if (!is.null(jaspResults[["FEsummary"]])) return() - + model <- jaspResults[["mmModel"]]$object$model - + FEsummary <- createJaspTable(title = "Fixed Effects Estimates") FEsummary$position <- 3 if (type == "BLMM") { @@ -2432,7 +5721,7 @@ dependencies <- .mmDependenciesBGLMM } FEsummary$dependOn(c(dependencies, "showFE", "summaryCI")) - + FEsummary$addColumnInfo(name = "term", title = "Term", type = "string") @@ -2462,404 +5751,404 @@ type = "number") jaspResults[["FEsummary"]] <- FEsummary - - model_summary <- + + modelSummary <- rstan::summary(model$stanfit, probs = c(.5 - options$summaryCI / 2, .5 + options$summaryCI / 2))$summary - names_summary <- rownames(model_summary) - fe_summary <- - model_summary[!grepl("b[", names_summary, fixed = T) & - !names_summary %in% c("mean_PPD", "log-posterior") & - names_summary != "sigma" & - !grepl("Sigma[", names_summary, fixed = T), ] - - for (i in 1:nrow(fe_summary)) { - if (rownames(fe_summary)[i] == "(Intercept)") { - effect_name <- "Intercept" + namesSummary <- rownames(modelSummary) + feSummary <- + modelSummary[!grepl("b[", namesSummary, fixed = T) & + !namesSummary %in% c("mean_PPD", "log-posterior") & + namesSummary != "sigma" & + !grepl("Sigma[", namesSummary, fixed = T), ] + + for (i in 1:nrow(feSummary)) { + if (rownames(feSummary)[i] == "(Intercept)") { + effectName <- "Intercept" } else{ - effect_name <- .mmVariableNames(rownames(fe_summary)[i], options$fixedVariables) - } - - temp_row <- list( - term = effect_name, - estimate = fe_summary[i, 1], - se = fe_summary[i, 3], - lowerCI = fe_summary[i, 4], - upperCI = fe_summary[i, 5], - rhat = fe_summary[i, 7], - neff = fe_summary[i, 6] + effectName <- .mmVariableNames(rownames(feSummary)[i], options$fixedVariables) + } + + tempRow <- list( + term = effectName, + estimate = feSummary[i, 1], + se = feSummary[i, 3], + lowerCI = feSummary[i, 4], + upperCI = feSummary[i, 5], + rhat = feSummary[i, 7], + neff = feSummary[i, 6] ) - - FEsummary$addRows(temp_row) + + FEsummary$addRows(tempRow) } - + # add warning messages FEsummary$addFootnote(.mmMessageInterpretability) } .mmSummaryStanova <- function(jaspResults, dataset, options, type = "BLMM") { - if (!is.null(jaspResults[["STANOVAsummary"]])) - return() + if (!is.null(jaspResults[["STANOVAsummary"]])) + return() - model <- jaspResults[["mmModel"]]$object$model - if (!is.null(model) && !class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { - model_summary <- - summary( - model, - probs = c(.50 - options$summaryCI / 2, .50, .50 + options$summaryCI / 2), - diff_intercept = options$show == "deviation" - ) + model <- jaspResults[["mmModel"]]$object$model + if (!is.null(model) && !class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { + modelSummary <- + summary( + model, + probs = c(.50 - options$summaryCI / 2, .50, .50 + options$summaryCI / 2), + diff_intercept = options$show == "deviation" + ) + } else{ + # dummy object for creating empty summary + modelSummary <- + list("Model summary" = matrix(NA, nrow = 0, ncol = 0)) + } + + STANOVAsummary <- createJaspContainer(title = "") + jaspResults[["STANOVAsummary"]] <- STANOVAsummary + + STANOVAsummary$position <- 1 + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + STANOVAsummary$dependOn(c(dependencies, "summaryCI", "show")) + + # go over each random effect grouping factor + for (i in 1:length(modelSummary)) { + tempSummary <- modelSummary[[i]] + + if (names(modelSummary)[i] == "Model summary") { + varName <- gettext("Model summary") + tableName <- varName + } else if (names(modelSummary)[i] == "(Intercept)") { + varName <- gettext("Intercept") + tableName <- varName } else{ - # dummy object for creating empty summary - model_summary <- - list("Model summary" = matrix(NA, nrow = 0, ncol = 0)) - } - - STANOVAsummary <- createJaspContainer(title = "") - jaspResults[["STANOVAsummary"]] <- STANOVAsummary - - STANOVAsummary$position <- 1 - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - STANOVAsummary$dependOn(c(dependencies, "summaryCI", "show")) - - # go over each random effect grouping factor - for (i in 1:length(model_summary)) { - temp_summary <- model_summary[[i]] - - if (names(model_summary)[i] == "Model summary") { - var_name <- gettext("Model summary") - table_name <- var_name - } else if (names(model_summary)[i] == "(Intercept)") { - var_name <- gettext("Intercept") - table_name <- var_name - } else{ - var_name <- jaspBase::gsubInteractionSymbol(names(model_summary)[i]) - if (options$show == "deviation") { - table_name <- - gettextf("%s (differences from intercept)",var_name) - } else if (options$show == "mmeans") { - if (nrow(temp_summary) == 1) { - table_name <- gettextf("%s (trend)",var_name) - } else{ - table_name <- gettextf("%s (marginal means)",var_name) - } + varName <- jaspBase::gsubInteractionSymbol(names(modelSummary)[i]) + if (options$show == "deviation") { + tableName <- + gettextf("%s (differences from intercept)",varName) + } else if (options$show == "mmeans") { + if (nrow(tempSummary) == 1) { + tableName <- gettextf("%s (trend)",varName) + } else{ + tableName <- gettextf("%s (marginal means)",varName) } } - - temp_table <- createJaspTable(title = table_name) - STANOVAsummary[[paste0("summary_", i)]] <- temp_table - - if (var_name != "Intercept" && nrow(temp_summary) > 1) { - temp_table$addColumnInfo(name = "level", - title = gettext("Level"), - type = "string") - } - temp_table$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - temp_table$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - temp_table$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - temp_table$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - temp_table$addColumnInfo(name = "rhat", - title = gettext("R-hat"), - type = "number") - temp_table$addColumnInfo(name = "ess_bulk", - title = gettext("ESS (bulk)"), - type = "number") - temp_table$addColumnInfo(name = "ess_tail", - title = gettext("ESS (tail)"), - type = "number") - - if (table_name == gettext("Model summary")) { - if(options$dependentVariable != "" && - length(options$fixedVariables) > 0 && - length(options$randomVariables) == 0) { - temp_table$addFootnote(.mmMessageMissingRE) - } - if (type == "BGLMM") { - if (options$family == "binomial_agg" && - options$dependentVariableAggregation == "") { - temp_table$addFootnote(.mmMessageMissingAgg) - } - } - - if(class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { - STANOVAsummary$setError(gettext("The model could not be estimated. Please, check the options and dataset for errors.")) - } - return() - } - - for (j in 1:nrow(temp_summary)) { - temp_row <- list( - estimate = temp_summary$Mean[j], - se = temp_summary$MAD_SD[j], - lowerCI = temp_summary[j, paste0((.50 - options$summaryCI / 2) * - 100, "%")], - upperCI = temp_summary[j, paste0((.50 + options$summaryCI / 2) * - 100, "%")], - rhat = temp_summary$rhat[j], - ess_bulk = temp_summary$ess_bulk[j], - ess_tail = temp_summary$ess_tail[j] - ) - - if (var_name != "Intercept" && nrow(temp_summary) > 1) { - var_name <- - paste(.unv(unlist(strsplit( - as.character(temp_summary$Variable[j]), "," - ))), collapse = jaspBase::interactionSymbol) - var_name <- gsub(" ", "", var_name, fixed = TRUE) - if (grepl(jaspBase::interactionSymbol, names(model_summary)[i], fixed = T)) { - for (n in unlist(strsplit(.unv(names( - model_summary - )[i]), jaspBase::interactionSymbol))) { - var_name <- gsub(n, "", var_name, fixed = TRUE) - } - } else{ - var_name <- - gsub(.unv(names(model_summary)[i]), "", var_name, fixed = TRUE) - } - temp_row$level <- var_name - } - - temp_table$addRows(temp_row) - } - - # add message about (lack of) random effects grouping factors - temp_table$addFootnote(.mmMessageREgrouping(options$randomVariables)) - - # check model fit - div_iterations <- rstan::get_num_divergent(model$stanfit) - low_bmfi <- rstan::get_low_bfmi_chains(model$stanfit) - max_treedepth <- rstan::get_num_max_treedepth(model$stanfit) - if(any(is.infinite(rstan::summary(model$stanfit)$summary[, "Rhat"]))){ - max_Rhat <- Inf - }else{ - max_Rhat <- max(rstan::summary(model$stanfit)$summary[, "Rhat"]) - } - min_ESS <- - min(rstan::summary(model$stanfit)$summary[, "n_eff"]) - if (div_iterations != 0) { - temp_table$addFootnote(.mmMessageDivergentIter(div_iterations), symbol = gettext("Warning:")) - } - if (length(low_bmfi) != 0) { - temp_table$addFootnote(.mmMessageLowBMFI(length(low_bmfi)), symbol = gettext("Warning:")) - } - if (max_treedepth != 0) { - temp_table$addFootnote(.mmMessageMaxTreedepth(max_treedepth)) - } - if (max_Rhat > 1.01) { - temp_table$addFootnote(.mmMessageMaxRhat(max_Rhat), symbol = gettext("Warning:")) - } - if (min_ESS < 100 * options$chains || is.nan(min_ESS)) { - temp_table$addFootnote(.mmMessageMinESS(min_ESS, 100 * options$chains), symbol = gettext("Warning:")) - } - - removed_me <- jaspResults[["mmModel"]]$object$removed_me - removed_te <- jaspResults[["mmModel"]]$object$removed_te - added_re <- jaspResults[["mmModel"]]$object$added_re - if (length(removed_me) > 0) { - for (j in 1:length(removed_me)) { - temp_table$addFootnote(.mmMessageOmmitedTerms1(removed_me[[j]], names(removed_me)[j]), - symbol = gettext("Note:")) - } + } + + tempTable <- createJaspTable(title = tableName) + STANOVAsummary[[paste0("summary_", i)]] <- tempTable + + if (varName != "Intercept" && nrow(tempSummary) > 1) { + tempTable$addColumnInfo(name = "level", + title = gettext("Level"), + type = "string") + } + tempTable$addColumnInfo(name = "estimate", + title = gettext("Estimate"), + type = "number") + tempTable$addColumnInfo(name = "se", + title = gettext("SE"), + type = "number") + tempTable$addColumnInfo( + name = "lowerCI", + title = gettext("Lower"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$summaryCI) + ) + tempTable$addColumnInfo( + name = "upperCI", + title = gettext("Upper"), + type = "number", + overtitle = gettextf("%s%% CI", 100 * options$summaryCI) + ) + tempTable$addColumnInfo(name = "rhat", + title = gettext("R-hat"), + type = "number") + tempTable$addColumnInfo(name = "ess_bulk", + title = gettext("ESS (bulk)"), + type = "number") + tempTable$addColumnInfo(name = "ess_tail", + title = gettext("ESS (tail)"), + type = "number") + + if (tableName == gettext("Model summary")) { + if(options$dependentVariable != "" && + length(options$fixedVariables) > 0 && + length(options$randomVariables) == 0) { + tempTable$addFootnote(.mmMessageMissingRE) } - if (length(removed_te) > 0) { - for (j in 1:length(removed_te)) { - temp_table$addFootnote(.mmMessageOmmitedTerms2(removed_te[[j]], names(removed_te)[j]), - symbol = gettext("Note:")) + if (type == "BGLMM") { + if (options$family == "binomial_agg" && + options$dependentVariableAggregation == "") { + tempTable$addFootnote(.mmMessageMissingAgg) } } - if (length(added_re) > 0) { - for (i in 1:length(added_re)) { - temp_table$addFootnote(.mmMessageAddedTerms(added_re[[i]], names(added_re)[i]), symbol = gettext("Note:")) + + if(class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { + STANOVAsummary$setError(gettext("The model could not be estimated. Please, check the options and dataset for errors.")) + } + return() + } + + for (j in 1:nrow(tempSummary)) { + tempRow <- list( + estimate = tempSummary$Mean[j], + se = tempSummary$MAD_SD[j], + lowerCI = tempSummary[j, paste0((.50 - options$summaryCI / 2) * + 100, "%")], + upperCI = tempSummary[j, paste0((.50 + options$summaryCI / 2) * + 100, "%")], + rhat = tempSummary$rhat[j], + ess_bulk = tempSummary$ess_bulk[j], + ess_tail = tempSummary$ess_tail[j] + ) + + if (varName != "Intercept" && nrow(tempSummary) > 1) { + varName <- + paste(.unv(unlist(strsplit( + as.character(tempSummary$Variable[j]), "," + ))), collapse = jaspBase::interactionSymbol) + varName <- gsub(" ", "", varName, fixed = TRUE) + if (grepl(jaspBase::interactionSymbol, names(modelSummary)[i], fixed = T)) { + for (n in unlist(strsplit(.unv(names( + modelSummary + )[i]), jaspBase::interactionSymbol))) { + varName <- gsub(n, "", varName, fixed = TRUE) + } + } else{ + varName <- + gsub(.unv(names(modelSummary)[i]), "", varName, fixed = TRUE) } + tempRow$level <- varName } - if (jaspResults[["n_missing"]]$object != 0) { - temp_table$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) + + tempTable$addRows(tempRow) + } + + # add message about (lack of) random effects grouping factors + tempTable$addFootnote(.mmMessageREgrouping(options$randomVariables)) + + # check model fit + divIterations <- rstan::get_num_divergent(model$stanfit) + lowBmfi <- rstan::get_low_bfmi_chains(model$stanfit) + maxTreedepth <- rstan::get_num_max_treedepth(model$stanfit) + if(any(is.infinite(rstan::summary(model$stanfit)$summary[, "Rhat"]))){ + maxRhat <- Inf + }else{ + maxRhat <- max(rstan::summary(model$stanfit)$summary[, "Rhat"]) + } + minESS <- + min(rstan::summary(model$stanfit)$summary[, "n_eff"]) + if (divIterations != 0) { + tempTable$addFootnote(.mmMessageDivergentIter(divIterations), symbol = gettext("Warning:")) + } + if (length(lowBmfi) != 0) { + tempTable$addFootnote(.mmMessageLowBMFI(length(lowBmfi)), symbol = gettext("Warning:")) + } + if (maxTreedepth != 0) { + tempTable$addFootnote(.mmMessageMaxTreedepth(max_treedepth)) + } + if (maxRhat > 1.01) { + tempTable$addFootnote(.mmMessageMaxRhat(maxRhat), symbol = gettext("Warning:")) + } + if (minESS < 100 * options$chains || is.nan(minESS)) { + tempTable$addFootnote(.mmMessageMinESS(minESS, 100 * options$chains), symbol = gettext("Warning:")) + } + + removedMe <- jaspResults[["mmModel"]]$object$removedMe + removedTe <- jaspResults[["mmModel"]]$object$removedTe + addedRe <- jaspResults[["mmModel"]]$object$addedRe + if (length(removedMe) > 0) { + for (j in 1:length(removedMe)) { + tempTable$addFootnote(.mmMessageOmmitedTerms1(removedMe[[j]], names(removedMe)[j]), + symbol = gettext("Note:")) } - if (type == "BGLMM") { - temp_table$addFootnote(.mmMessageGLMMtype(options$family, options$link)) + } + if (length(removedTe) > 0) { + for (j in 1:length(removedTe)) { + tempTable$addFootnote(.mmMessageOmmitedTerms2(removedTe[[j]], names(removedTe)[j]), + symbol = gettext("Note:")) + } + } + if (length(addedRe) > 0) { + for (i in 1:length(addedRe)) { + tempTable$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) } - } - + if (jaspResults[["n_missing"]]$object != 0) { + tempTable$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) + } + if (type == "BGLMM") { + tempTable$addFootnote(.mmMessageGLMMtype(options$family, options$link)) + } + } + +} .mmDiagnostics <- function(jaspResults, options, dataset, type = "BLMM") { - if (!is.null(jaspResults[["diagnosticPlots"]])) - return() - - - diagnosticPlots <- createJaspContainer(title = gettext("Sampling diagnostics")) - - diagnosticPlots$position <- 5 - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM + if (!is.null(jaspResults[["diagnosticPlots"]])) + return() + + + diagnosticPlots <- createJaspContainer(title = gettext("Sampling diagnostics")) + + diagnosticPlots$position <- 5 + if (type == "BLMM") { + dependencies <- .mmDependenciesBLMM + } else if (type == "BGLMM") { + dependencies <- .mmDependenciesBGLMM + } + diagnosticPlots$dependOn(c( + dependencies, + "samplingPlot", + "samplingVariable1", + "samplingVariable2" + )) + jaspResults[["diagnosticPlots"]] <- diagnosticPlots + + + if (options$samplingPlot == "stan_scat" && + length(options$samplingVariable2) == 0) { + diagnosticPlots[["emptyPlot"]] <- createJaspPlot() + return() + } + + model <- jaspResults[["mmModel"]]$object$model + + if (options$samplingPlot != "stan_scat") { + pars <- + paste0(.v(unlist(options$samplingVariable1)), collapse = ":") + } else{ + pars <- c(paste0(.v(unlist( + options$samplingVariable1 + )), collapse = ":"), + paste0(.v(unlist( + options$samplingVariable2 + )), collapse = ":")) + } + + plotData <- + .mmGetPlotSamples(model = model, + pars = pars, + options = options) + + + for (i in 1:length(plotData)) { + if (names(plotData)[i] == "Intercept") { + varName <- gettext("Intercept") + } else{ + varName <- strsplit(as.character(pars), ":") + varName <- + sapply(varName, function(x) + paste(.unv(unlist( + strsplit(x, ",") + )), collapse = ":")) + varName <- + sapply(varName, function(x) + gsub(" ", "", x, fixed = TRUE)) + varName <- + sapply(varName, function(x) + .mmVariableNames(x, options$fixedVariables)) + varName <- paste0(varName, collapse = " by ") } - diagnosticPlots$dependOn(c( - dependencies, - "samplingPlot", - "samplingVariable1", - "samplingVariable2" - )) - jaspResults[["diagnosticPlots"]] <- diagnosticPlots - - - if (options$samplingPlot == "stan_scat" && - length(options$samplingVariable2) == 0) { - diagnosticPlots[["emptyPlot"]] <- createJaspPlot() - return() + + plots <- + createJaspPlot( + title = varName, + width = 400, + height = 300 + ) + + if (options$samplingPlot == "stan_trace") { + p <- .rstanPlotTrace(plotData[[i]]) + } else if (options$samplingPlot == "stan_scat") { + p <- .rstanPlotScat(plotData[[i]]) + } else if (options$samplingPlot == "stan_hist") { + p <- .rstanPlotHist(plotData[[i]]) + } else if (options$samplingPlot == "stan_dens") { + p <- .rstanPlotDens(plotData[[i]]) + } else if (options$samplingPlot == "stan_ac") { + p <- .rstanPlotAcor(plotData[[i]]) } - - model <- jaspResults[["mmModel"]]$object$model - - if (options$samplingPlot != "stan_scat") { - pars <- - paste0(.v(unlist(options$samplingVariable1)), collapse = ":") + + + if (options$samplingPlot %in% c("stan_hist", "stan_dens")) { + p <- jaspGraphs::themeJasp(p, sides = "b") + p <- p + ggplot2::theme( + axis.title.y = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.ticks.y = ggplot2::element_blank() + ) + p <- p + ggplot2::labs(x = varName) } else{ - pars <- c(paste0(.v(unlist( - options$samplingVariable1 - )), collapse = ":"), - paste0(.v(unlist( - options$samplingVariable2 - )), collapse = ":")) - } - - plot_data <- - .mmGetPlotSamples(model = model, - pars = pars, - options = options) - - - for (i in 1:length(plot_data)) { - if (names(plot_data)[i] == "Intercept") { - var_name <- gettext("Intercept") - } else{ - var_name <- strsplit(as.character(pars), ":") - var_name <- - sapply(var_name, function(x) - paste(.unv(unlist( - strsplit(x, ",") - )), collapse = ":")) - var_name <- - sapply(var_name, function(x) - gsub(" ", "", x, fixed = TRUE)) - var_name <- - sapply(var_name, function(x) - .mmVariableNames(x, options$fixedVariables)) - var_name <- paste0(var_name, collapse = " by ") - } - - plots <- - createJaspPlot( - title = var_name, - width = 400, - height = 300 - ) - - if (options$samplingPlot == "stan_trace") { - p <- .rstanPlotTrace(plot_data[[i]]) - } else if (options$samplingPlot == "stan_scat") { - p <- .rstanPlotScat(plot_data[[i]]) - } else if (options$samplingPlot == "stan_hist") { - p <- .rstanPlotHist(plot_data[[i]]) - } else if (options$samplingPlot == "stan_dens") { - p <- .rstanPlotDens(plot_data[[i]]) - } else if (options$samplingPlot == "stan_ac") { - p <- .rstanPlotAcor(plot_data[[i]]) - } - - - if (options$samplingPlot %in% c("stan_hist", "stan_dens")) { - p <- jaspGraphs::themeJasp(p, sides = "b") - p <- p + ggplot2::theme( - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank() - ) - p <- p + ggplot2::labs(x = var_name) - } else{ - p <- jaspGraphs::themeJasp(p) - } - if (options$samplingPlot == "stan_trace") { - p <- p + ggplot2::theme(plot.margin = ggplot2::margin(r = 10 * (nchar(options$iteration - options$warmup) - 2))) - } - plots$plotObject <- p - - diagnosticPlots[[names(plot_data)[i]]] <- plots + p <- jaspGraphs::themeJasp(p) } - + if (options$samplingPlot == "stan_trace") { + p <- p + ggplot2::theme(plot.margin = ggplot2::margin(r = 10 * (nchar(options$iteration - options$warmup) - 2))) + } + plots$plotObject <- p + + diagnosticPlots[[names(plotData)[i]]] <- plots } +} + # helper functions -.mmVariableNames <- function(var_name, variables) { +.mmVariableNames <- function(varName, variables) { for (vn in variables) { - inf <- regexpr(vn, var_name, fixed = TRUE) + inf <- regexpr(vn, varName, fixed = TRUE) if (inf[1] != -1) { - var_name <- paste0( - substr(var_name, 0, inf[1] - 1), - substr(var_name, inf[1], inf[1] + attr(inf, "match.length") - 1), + varName <- paste0( + substr(varName, 0, inf[1] - 1), + substr(varName, inf[1], inf[1] + attr(inf, "match.length") - 1), " (", substr( - var_name, + varName, inf[1] + attr(inf, "match.length"), - nchar(var_name) + nchar(varName) ) ) } } - var_name <- gsub(":", paste0(")", jaspBase::interactionSymbol), var_name, fixed = TRUE) - var_name <- paste0(var_name, ")") - var_name <- gsub(" ()", "", var_name, fixed = TRUE) - return(var_name) + varName <- gsub(":", paste0(")", jaspBase::interactionSymbol), varName, fixed = TRUE) + varName <- paste0(varName, ")") + varName <- gsub(" ()", "", varName, fixed = TRUE) + return(varName) } .mmAddCoefNameStanova <- function(samples, par, coefs_name){ # this is a mess but the stanova::stanova_samples returns an incomplete variable names - + coefs_trend <- attr(samples, "estimate") coefs_trend <- gsub("trend ('", "", coefs_trend, fixed = TRUE) coefs_trend <- gsub("')", "", coefs_trend, fixed = TRUE) coefs_trend <- strsplit(coefs_trend, ",") - + for(cft in coefs_trend){ if(cft %in% strsplit(par, ":")[[1]] && !grepl(.unv(cft), coefs_name)){ coefs_name <- paste0(coefs_name, jaspBase::interactionSymbol, .unv(cft)) } } - + return(coefs_name) - + } .mmGetPlotSamples <- function(model, pars, options) { matrix_diff <- stanova::stanova_samples(model, return = "array", diff_intercept = options$show == "deviation") - + if (length(pars) == 1) { samples <- matrix_diff[[pars]] coefs <- dim(matrix_diff[[pars]])[2] - - plot_data <- list() - + + plotData <- list() + for (cf in 1:coefs) { - + coefs_name <- paste(.unv(unlist( strsplit(dimnames(samples)$Parameter[cf], ",") @@ -2868,8 +6157,8 @@ coefs_name <- .mmVariableNames(coefs_name, options$fixedVariables) coefs_name <- .mmAddCoefNameStanova(samples, pars, coefs_name) - - plot_data[[dimnames(samples)$Parameter[cf]]] <- list( + + plotData[[dimnames(samples)$Parameter[cf]]] <- list( samp = data.frame( value = as.vector(samples[, cf,]), parameter = as.factor(rep(coefs_name, length(as.vector(samples[, cf,])))), @@ -2884,43 +6173,43 @@ warmup = 0 ) } - + } else{ samples1 <- matrix_diff[[pars[1]]] samples2 <- matrix_diff[[pars[2]]] coefs1 <- dim(matrix_diff[[pars[1]]])[2] coefs2 <- dim(matrix_diff[[pars[2]]])[2] - - plot_data <- list() - + + plotData <- list() + for (cf1 in 1:coefs1) { for (cf2 in 1:coefs2) { - coefs1_name <- + coefs1Name <- paste(.unv(unlist( strsplit(dimnames(samples1)$Parameter[cf1], ",") )), collapse = ":") - coefs1_name <- gsub(" ", "", coefs1_name, fixed = TRUE) - coefs1_name <- .mmVariableNames(coefs1_name, options$fixedVariables) - coefs1_name <- .mmAddCoefNameStanova(samples1, pars[[1]], coefs1_name) - - coefs2_name <- + coefs1Name <- gsub(" ", "", coefs1Name, fixed = TRUE) + coefs1Name <- .mmVariableNames(coefs1Name, options$fixedVariables) + coefs1Name <- .mmAddCoefNameStanova(samples1, pars[[1]], coefs1Name) + + coefs2Name <- paste(.unv(unlist( strsplit(dimnames(samples2)$Parameter[cf2], ",") )), collapse = ":") - coefs2_name <- gsub(" ", "", coefs2_name, fixed = TRUE) - coefs2_name <- .mmVariableNames(coefs2_name, options$fixedVariables) - coefs2_name <- .mmAddCoefNameStanova(samples2, pars[[2]], coefs2_name) + coefs2Name <- gsub(" ", "", coefs2Name, fixed = TRUE) + coefs2Name <- .mmVariableNames(coefs2Name, options$fixedVariables) + coefs2Name <- .mmAddCoefNameStanova(samples2, pars[[2]], coefs2Name) - - plot_data[[paste0(coefs1_name, ":", coefs2_name)]] <- list( + + plotData[[paste0(coefs1Name, ":", coefs2Name)]] <- list( samp = data.frame( value = c(as.vector(samples1[, cf1,]), as.vector(samples2[, cf2,])), parameter = factor(c( - rep(coefs1_name, dim(samples1)[1] * dim(samples1)[3]), - rep(coefs2_name, dim(samples2)[1] * dim(samples2)[3]) - ), levels = c(coefs1_name, coefs2_name)), + rep(coefs1Name, dim(samples1)[1] * dim(samples1)[3]), + rep(coefs2Name, dim(samples2)[1] * dim(samples2)[3]) + ), levels = c(coefs1Name, coefs2Name)), chain = as.factor(c( unlist(sapply(1:dim(samples1)[3], function(x) rep(x, dim(samples2)[1]))), @@ -2940,55 +6229,55 @@ ) } } - + } - - return(plot_data) - + + return(plotData) + } # as explained in ?is.integer .is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol # modified rstan plotting functions -.rstanPlotHist <- function(plot_data) { +.rstanPlotHist <- function(plotData) { dots <- rstan:::.add_aesthetics(list(), c("fill", "color")) thm <- rstan:::rstanvis_hist_theme() base <- - ggplot2::ggplot(plot_data$samp, ggplot2::aes_string(x = "value")) + ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) graph <- base + do.call(ggplot2::geom_histogram, dots) + - ggplot2::xlab("") + thm + ggplot2::xlab(unique(plot_data$samp$parameter)) - + ggplot2::xlab("") + thm + ggplot2::xlab(unique(plotData$samp$parameter)) + return(graph) } -.rstanPlotTrace <- function(plot_data) { +.rstanPlotTrace <- function(plotData) { thm <- rstan:::rstanvis_theme() clrs <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plot_data$nchains) + plotData$nchains) base <- - ggplot2::ggplot(plot_data$samp, + ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "iteration", y = "value", color = "chain")) - + graph <- base + ggplot2::geom_path() + ggplot2::scale_color_manual(values = clrs) + - ggplot2::labs(x = "", y = levels(plot_data$samp$parameter)) + thm + ggplot2::labs(x = "", y = levels(plotData$samp$parameter)) + thm graph <- graph + ggplot2::scale_x_continuous( - breaks = jaspGraphs::getPrettyAxisBreaks(c(1,max(plot_data$samp$iteration)))) + breaks = jaspGraphs::getPrettyAxisBreaks(c(1,max(plotData$samp$iteration)))) + - graph } -.rstanPlotDens <- function(plot_data, separate_chains = TRUE) { +.rstanPlotDens <- function(plotData, separate_chains = TRUE) { clrs <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plot_data$nchains) + plotData$nchains) thm <- rstan:::rstanvis_hist_theme() base <- - ggplot2::ggplot(plot_data$samp, ggplot2::aes_string(x = "value")) + + ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) + ggplot2::xlab("") - + if (!separate_chains) { dots <- rstan:::.add_aesthetics(list(), c("fill", "color")) graph <- base + do.call(ggplot2::geom_density, dots) + @@ -2999,43 +6288,43 @@ graph <- base + do.call(ggplot2::geom_density, dots) + ggplot2::scale_fill_manual(values = clrs) + thm } - - graph + ggplot2::xlab(unique(plot_data$samp$parameter)) - + + graph + ggplot2::xlab(unique(plotData$samp$parameter)) + } -.rstanPlotScat <- function(plot_data) { +.rstanPlotScat <- function(plotData) { thm <- rstan:::rstanvis_theme() dots <- rstan:::.add_aesthetics(list(), c("fill", "pt_color", "pt_size", "alpha", "shape")) - + p1 <- - plot_data$samp$parameter == levels(plot_data$samp$parameter)[1] + plotData$samp$parameter == levels(plotData$samp$parameter)[1] p2 <- - plot_data$samp$parameter == levels(plot_data$samp$parameter)[2] - val1 <- plot_data$samp[p1, "value"] - val2 <- plot_data$samp[p2, "value"] + plotData$samp$parameter == levels(plotData$samp$parameter)[2] + val1 <- plotData$samp[p1, "value"] + val2 <- plotData$samp[p2, "value"] df <- data.frame(x = val1, y = val2) base <- ggplot2::ggplot(df, ggplot2::aes_string("x", "y")) graph <- base + do.call(ggplot2::geom_point, dots) + ggplot2::labs( - x = levels(plot_data$samp$parameter)[1], - y = levels(plot_data$samp$parameter)[2] + x = levels(plotData$samp$parameter)[1], + y = levels(plotData$samp$parameter)[2] ) + thm graph - + } -.rstanPlotAcor <- function(plot_data, lags = 30) { +.rstanPlotAcor <- function(plotData, lags = 30) { clrs <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plot_data$nchains) + plotData$nchains) thm <- rstan:::rstanvis_theme() dots <- rstan:::.add_aesthetics(list(), c("size", "color", "fill")) ac_dat <- - rstan:::.ac_plot_data(dat = plot_data$samp, - lags = lags, - partial = FALSE) - + rstan:::.ac_plotData(dat = plotData$samp, + lags = lags, + partial = FALSE) + dots$position <- "dodge" dots$stat <- "summary" dots$fun.y <- "mean" @@ -3047,23 +6336,23 @@ ggplot2::ggplot(ac_dat, ggplot2::aes_string(x = "lag", y = "ac")) graph <- base + do.call(ggplot2::geom_bar, dots) + y_scale + ac_labs + thm - + graph } .mmCustomChecks <- list( - collinCheck = function(dataset){ - cor_mat <- cor(apply(dataset,2,as.numeric)) - diag(cor_mat) <- 0 - cor_mat[lower.tri(cor_mat)] <- 0 - nearOne <- 1 - abs(cor_mat) < sqrt(.Machine$double.eps) - if(any(nearOne)){ - var_ind <- which(nearOne, arr.ind = TRUE) - var_names <- paste("'", .unv(rownames(cor_mat)[var_ind[,"row"]]),"' and '", .unv(colnames(cor_mat)[var_ind[,"col"]]),"'", sep = "", collapse = ", ") - return(gettextf("The following variables are a linear combination of each other, please, remove one of them from the analysis: %s", var_names)) - } - } + collinCheck = function(dataset){ + cor_mat <- cor(apply(dataset,2,as.numeric)) + diag(cor_mat) <- 0 + cor_mat[lower.tri(cor_mat)] <- 0 + nearOne <- 1 - abs(cor_mat) < sqrt(.Machine$double.eps) + if(any(nearOne)){ + var_ind <- which(nearOne, arr.ind = TRUE) + varNames <- paste("'", .unv(rownames(cor_mat)[var_ind[,"row"]]),"' and '", .unv(colnames(cor_mat)[var_ind[,"col"]]),"'", sep = "", collapse = ", ") + return(gettextf("The following variables are a linear combination of each other, please, remove one of them from the analysis: %s", varNames)) + } + } ) .mmDependenciesLMM <- c( @@ -3182,14 +6471,14 @@ } .mmMessageGLMMtype <- function(family, link) { family <- switch(family, - "binomial" = gettext("binomial"), - "binomial_agg" = gettext("binomial"), - "gaussian" = gettext("gaussian"), - "Gamma" = gettext("gamma"), - "inverse.gaussian" = gettext("inverse gaussian"), - "poisson" = gettext("poisson"), - "neg_binomial_2" = gettext("negative binomial"), - "betar" = gettext("beta"), + "binomial" = gettext("binomial"), + "binomial_agg" = gettext("binomial"), + "gaussian" = gettext("gaussian"), + "Gamma" = gettext("gamma"), + "inverse.gaussian" = gettext("inverse gaussian"), + "poisson" = gettext("poisson"), + "neg_binomial_2" = gettext("negative binomial"), + "betar" = gettext("beta"), ) gettextf("Generalized linear mixed model with %s family and %s link function.", family, @@ -3197,10 +6486,10 @@ } .mmMessageTermTest <- function(method) { method <- switch(method, - "S" = gettext("Satterthwaite"), - "KR" = gettext("Kenward-Roger"), - "LRT" = gettext("likelihood ratio tests"), - "PB" = gettext("parametric bootstrap") + "S" = gettext("Satterthwaite"), + "KR" = gettext("Kenward-Roger"), + "LRT" = gettext("likelihood ratio tests"), + "PB" = gettext("parametric bootstrap") ) gettextf("Model terms tested with %s method.",method) } @@ -3209,17 +6498,17 @@ return(gettext("P-values are not adjusted.")) } adjustment <- switch(adjustment, - "holm" = gettext("Holm"), - "hommel" = gettext("Homel"), - "hochberg" = gettext("Hochberg"), - "mvt" = gettext("Multivariate-t"), - "tukey" = gettext("Tukey"), - "BH" = gettext("Benjamini-Hochberg"), - "BY" = gettext("Benjamini-Yekutieli"), - "scheffe" = gettext("Scheffé"), - "sidak" = gettext("Sidak"), - "dunnettx" = gettext("Dunnett"), - "bonferroni" = gettext("Bonferroni") + "holm" = gettext("Holm"), + "hommel" = gettext("Homel"), + "hochberg" = gettext("Hochberg"), + "mvt" = gettext("Multivariate-t"), + "tukey" = gettext("Tukey"), + "BH" = gettext("Benjamini-Hochberg"), + "BY" = gettext("Benjamini-Yekutieli"), + "scheffe" = gettext("Scheffé"), + "sidak" = gettext("Sidak"), + "dunnettx" = gettext("Dunnett"), + "bonferroni" = gettext("Bonferroni") ) return(gettextf("P-values are adjusted using %s adjustment.",adjustment)) } From acd32d415213f071573b00fc3b699ec66d93ffe1 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Sat, 12 Jun 2021 08:45:04 +0200 Subject: [PATCH 14/38] changing error message --- R/MixedModelsCommon.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 8fec863c..3bf56c36 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -2197,7 +2197,7 @@ if (inherits(model, "error")) { if (model$message == "Dropping columns failed to produce full column rank design matrix") - .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. The most likely reason for this issue is a factor / combination of factors leading to more levels than are estimable.")) + .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. A factor or combination of factors resulted in more levels than the effective sample size.")) else .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model$message)) } @@ -5488,7 +5488,7 @@ if (inherits(model, "error")) { if (model$message == "Dropping columns failed to produce full column rank design matrix") - .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. The most likely reason for this issue is a factor / combination of factors leading to more levels than are estimable.")) + .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. A factor or combination of factors resulted in more levels than the effective sample size.")) else .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model$message)) } From 4f834c5d13884546cf707423f75c15cedc7a7a6c Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Sat, 26 Jun 2021 20:31:42 +0200 Subject: [PATCH 15/38] update unit tests to use vdiffr 1.0 fixes: https://github.com/jasp-stats/INTERNAL-jasp/issues/1408 --- .github/workflows/unittests.yml | 6 +- .../mixedmodelsglmm-plot-glmm-1.svg | 79 ----------- .../mixedmodelsglmm-plot-glmm-2.svg | 73 ---------- .../mixedmodelsglmm-plot-glmm-3.svg | 93 ------------- .../mixedmodelsglmm-plot-glmm-4.svg | 83 ------------ .../mixedmodelsglmm-plot-glmm-5.svg | 120 ----------------- .../MixedModelsGLMM/mixedmodelsglmm-plot.svg | 79 ----------- .../mixedmodelslmm-plot-lmm-1.svg | 118 ---------------- .../mixedmodelslmm-plot-lmm-2.svg | 94 ------------- .../mixedmodelslmm-plot-lmm-3.svg | 86 ------------ .../mixedmodelslmm-plot-lmm-4.svg | 93 ------------- .../mixedmodelslmm-plot-lmm-5.svg | 85 ------------ .../MixedModelsLMM/mixedmodelslmm-plot.svg | 118 ---------------- tests/figs/deps.txt | 3 - tests/figs/jasp-deps.txt | 1 - .../_snaps/mixedmodelsglmm/plot-glmm-1.svg | 85 ++++++++++++ .../_snaps/mixedmodelsglmm/plot-glmm-2.svg | 79 +++++++++++ .../_snaps/mixedmodelsglmm/plot-glmm-3.svg | 99 ++++++++++++++ .../_snaps/mixedmodelsglmm/plot-glmm-4.svg | 89 +++++++++++++ .../_snaps/mixedmodelsglmm/plot-glmm-5.svg | 126 ++++++++++++++++++ .../_snaps/mixedmodelslmm/plot-lmm-1.svg | 124 +++++++++++++++++ .../_snaps/mixedmodelslmm/plot-lmm-2.svg | 100 ++++++++++++++ .../_snaps/mixedmodelslmm/plot-lmm-3.svg | 92 +++++++++++++ .../_snaps/mixedmodelslmm/plot-lmm-4.svg | 99 ++++++++++++++ .../_snaps/mixedmodelslmm/plot-lmm-5.svg | 91 +++++++++++++ tests/testthat/test-mixedmodelsglmm.R | 28 ++-- tests/testthat/test-mixedmodelslmm.R | 62 ++++----- 27 files changed, 1032 insertions(+), 1173 deletions(-) delete mode 100644 tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-1.svg delete mode 100644 tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-2.svg delete mode 100644 tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-3.svg delete mode 100644 tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-4.svg delete mode 100644 tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-5.svg delete mode 100644 tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot.svg delete mode 100644 tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-1.svg delete mode 100644 tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-2.svg delete mode 100644 tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-3.svg delete mode 100644 tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-4.svg delete mode 100644 tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-5.svg delete mode 100644 tests/figs/MixedModelsLMM/mixedmodelslmm-plot.svg delete mode 100644 tests/figs/deps.txt delete mode 100644 tests/figs/jasp-deps.txt create mode 100644 tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-1.svg create mode 100644 tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-2.svg create mode 100644 tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-3.svg create mode 100644 tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-4.svg create mode 100644 tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-5.svg create mode 100644 tests/testthat/_snaps/mixedmodelslmm/plot-lmm-1.svg create mode 100644 tests/testthat/_snaps/mixedmodelslmm/plot-lmm-2.svg create mode 100644 tests/testthat/_snaps/mixedmodelslmm/plot-lmm-3.svg create mode 100644 tests/testthat/_snaps/mixedmodelslmm/plot-lmm-4.svg create mode 100644 tests/testthat/_snaps/mixedmodelslmm/plot-lmm-5.svg diff --git a/.github/workflows/unittests.yml b/.github/workflows/unittests.yml index 63e6253e..db25d5f3 100644 --- a/.github/workflows/unittests.yml +++ b/.github/workflows/unittests.yml @@ -12,9 +12,9 @@ jobs: fail-fast: false matrix: config: - - {os: windows-latest, r: "4.0.5"} - - {os: macOS-latest, r: "4.0.5"} - - {os: ubuntu-20.04, r: "4.0.5"} + - {os: windows-latest, r: "4.1.0"} + - {os: macOS-latest, r: "4.1.0"} + - {os: ubuntu-20.04, r: "4.1.0"} env: R_REMOTES_NO_ERRORS_FROM_WARNINGS: true diff --git a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-1.svg b/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-1.svg deleted file mode 100644 index d290b28d..00000000 --- a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-1.svg +++ /dev/null @@ -1,79 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -0.0 -0.2 -0.4 -0.6 -0.8 -1.0 - - - - - - - - - -1 -2 -JaspColumn_.1._Encoded -JaspColumn_.5._Encoded -MixedModelsGLMM-plot-glmm-1 - diff --git a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-2.svg b/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-2.svg deleted file mode 100644 index a3f241e8..00000000 --- a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-2.svg +++ /dev/null @@ -1,73 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -0.1 -0.2 -0.3 -0.4 -0.5 -0.6 -0.7 - - - - - - - - - - -f -m -facGender -contBinom - - - - - - - - -f -m -MixedModelsGLMM-plot-glmm-2 - diff --git a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-3.svg b/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-3.svg deleted file mode 100644 index 42a6f97e..00000000 --- a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-3.svg +++ /dev/null @@ -1,93 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -1.0 -1.5 -2.0 -2.5 -3.0 -3.5 - - - - - - - - - -f -m -facGender -contGamma - - - - - - - - - - - - - - -f -m -MixedModelsGLMM-plot-glmm-3 - diff --git a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-4.svg b/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-4.svg deleted file mode 100644 index ca30c2b5..00000000 --- a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-4.svg +++ /dev/null @@ -1,83 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -20 -25 -30 -35 -40 - - - - - - - - -f -m -facGender -facFifty - - - - - - - - - - - - - - -f -m -MixedModelsGLMM-plot-glmm-4 - diff --git a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-5.svg b/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-5.svg deleted file mode 100644 index 7659650b..00000000 --- a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot-glmm-5.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -0.0 -0.2 -0.4 -0.6 -0.8 -1.0 - - - - - - - - - -1 -2 -cA -binom_mean -MixedModelsGLMM-plot-glmm-5 - diff --git a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot.svg b/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot.svg deleted file mode 100644 index 5f52244e..00000000 --- a/tests/figs/MixedModelsGLMM/mixedmodelsglmm-plot.svg +++ /dev/null @@ -1,79 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -0.0 -0.2 -0.4 -0.6 -0.8 -1.0 - - - - - - - - - -1 -2 -JaspColumn_.1._Encoded -JaspColumn_.5._Encoded -MixedModelsGLMM-plot - diff --git a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-1.svg b/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-1.svg deleted file mode 100644 index 868d33b5..00000000 --- a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-1.svg +++ /dev/null @@ -1,118 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --2 --1 -0 -1 -2 - - - - - - - - -1 -2 -JaspColumn_.1._Encoded -JaspColumn_.4._Encoded -MixedModelsLMM-plot-lmm-1 - diff --git a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-2.svg b/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-2.svg deleted file mode 100644 index 28a9c9df..00000000 --- a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-2.svg +++ /dev/null @@ -1,94 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --1.0 --0.5 -0.0 -0.5 -1.0 - - - - - - - -0 -1 -contBinom -contNormal - -facExperim - - - - - - - - - - - - -control -experimental -MixedModelsLMM-plot-lmm-2 - diff --git a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-3.svg b/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-3.svg deleted file mode 100644 index 6848a43b..00000000 --- a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-3.svg +++ /dev/null @@ -1,86 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --3 --2 --1 -0 -1 -2 - - - - - - - - - -f -m -facGender -contNormal - - - - - - - - - - - - - - - - -f -m -MixedModelsLMM-plot-lmm-3 - diff --git a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-4.svg b/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-4.svg deleted file mode 100644 index d13fcfe4..00000000 --- a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-4.svg +++ /dev/null @@ -1,93 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --1.0 --0.8 --0.6 --0.4 --0.2 -0.0 -0.2 -0.4 -0.6 - - - - - - - - - - - - -f -m -facGender -contNormal - - - - - - - - -f -m -MixedModelsLMM-plot-lmm-4 - diff --git a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-5.svg b/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-5.svg deleted file mode 100644 index 2885924a..00000000 --- a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot-lmm-5.svg +++ /dev/null @@ -1,85 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --1.0 --0.5 -0.0 -0.5 -1.0 - - - - - - - - -f -m -facGender -contNormal - - - - - - - - -f -m -MixedModelsLMM-plot-lmm-5 - diff --git a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot.svg b/tests/figs/MixedModelsLMM/mixedmodelslmm-plot.svg deleted file mode 100644 index f7d1cc79..00000000 --- a/tests/figs/MixedModelsLMM/mixedmodelslmm-plot.svg +++ /dev/null @@ -1,118 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --2 --1 -0 -1 -2 - - - - - - - - -1 -2 -JaspColumn_.1._Encoded -JaspColumn_.4._Encoded -MixedModelsLMM-plot - diff --git a/tests/figs/deps.txt b/tests/figs/deps.txt deleted file mode 100644 index 8d7f66b6..00000000 --- a/tests/figs/deps.txt +++ /dev/null @@ -1,3 +0,0 @@ -- vdiffr-svg-engine: 1.0 -- vdiffr: 0.3.3 -- freetypeharfbuzz: 0.2.5 diff --git a/tests/figs/jasp-deps.txt b/tests/figs/jasp-deps.txt deleted file mode 100644 index 0cb3660b..00000000 --- a/tests/figs/jasp-deps.txt +++ /dev/null @@ -1 +0,0 @@ -- jaspGraphs: 0.5.2 diff --git a/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-1.svg b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-1.svg new file mode 100644 index 00000000..0383ae5c --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-1.svg @@ -0,0 +1,85 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + + + +1 +2 +JaspColumn_.1._Encoded +JaspColumn_.5._Encoded +plot-glmm-1 + + diff --git a/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-2.svg b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-2.svg new file mode 100644 index 00000000..a23f7d7b --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-2.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 + + + + + + + + + + +f +m +facGender +contBinom + + + + + + + + +f +m +plot-glmm-2 + + diff --git a/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-3.svg b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-3.svg new file mode 100644 index 00000000..6d88d89d --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-3.svg @@ -0,0 +1,99 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 + + + + + + + + + +f +m +facGender +contGamma + + + + + + + + + + + + + + +f +m +plot-glmm-3 + + diff --git a/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-4.svg b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-4.svg new file mode 100644 index 00000000..263123d2 --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-4.svg @@ -0,0 +1,89 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +20 +25 +30 +35 +40 + + + + + + + + +f +m +facGender +facFifty + + + + + + + + + + + + + + +f +m +plot-glmm-4 + + diff --git a/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-5.svg b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-5.svg new file mode 100644 index 00000000..90e22ec6 --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-5.svg @@ -0,0 +1,126 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + + + +1 +2 +cA +binom_mean +plot-glmm-5 + + diff --git a/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-1.svg b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-1.svg new file mode 100644 index 00000000..3c03baad --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-1.svg @@ -0,0 +1,124 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + +1 +2 +JaspColumn_.1._Encoded +JaspColumn_.4._Encoded +plot-lmm-1 + + diff --git a/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-2.svg b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-2.svg new file mode 100644 index 00000000..40eac374 --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-2.svg @@ -0,0 +1,100 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-1.0 +-0.5 +0.0 +0.5 +1.0 + + + + + + + +0 +1 +contBinom +contNormal + +facExperim + + + + + + + + + + + + +control +experimental +plot-lmm-2 + + diff --git a/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-3.svg b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-3.svg new file mode 100644 index 00000000..76a24970 --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-3.svg @@ -0,0 +1,92 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-3 +-2 +-1 +0 +1 +2 + + + + + + + + + +f +m +facGender +contNormal + + + + + + + + + + + + + + + + +f +m +plot-lmm-3 + + diff --git a/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-4.svg b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-4.svg new file mode 100644 index 00000000..b5032820 --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-4.svg @@ -0,0 +1,99 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-1.0 +-0.8 +-0.6 +-0.4 +-0.2 +0.0 +0.2 +0.4 +0.6 + + + + + + + + + + + + +f +m +facGender +contNormal + + + + + + + + +f +m +plot-lmm-4 + + diff --git a/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-5.svg b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-5.svg new file mode 100644 index 00000000..a6c3553f --- /dev/null +++ b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-5.svg @@ -0,0 +1,91 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-1.0 +-0.5 +0.0 +0.5 +1.0 + + + + + + + + +f +m +facGender +contNormal + + + + + + + + +f +m +plot-lmm-5 + + diff --git a/tests/testthat/test-mixedmodelsglmm.R b/tests/testthat/test-mixedmodelsglmm.R index 7658510d..f5f94fd5 100644 --- a/tests/testthat/test-mixedmodelsglmm.R +++ b/tests/testthat/test-mixedmodelsglmm.R @@ -5,7 +5,7 @@ context("Generalized Linear Mixed Models") { skip_on_os("mac") # problems with precision outside of windows skip_on_os("linux") # problems with precision outside of windows - options <- analysisOptions("MixedModelsGLMM") + options <- jaspTools::analysisOptions("MixedModelsGLMM") options$Contrasts <- list(list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", "6"), name = "cA", values = c("1", "2", "1", "2", "1", "2" )), list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", @@ -290,7 +290,7 @@ context("Generalized Linear Mixed Models") 0.067540856, 0.169211418, 1, 1, 0.052260709, 0.052824504, 1, 0.12313927, 0.085084118, 1, 0.018040391, 0.055642594, 1, 0.901317881, 0.859124256)), class = "data.frame", row.names = c(NA, -300L)) - results <- runAnalysis("MixedModelsGLMM", dataset, options) + results <- jaspTools::runAnalysis("MixedModelsGLMM", dataset, options) test_that("ANOVA Summary table results match", { @@ -387,7 +387,7 @@ context("Generalized Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - jaspTools::expect_equal_plots(testPlot, "plot-glmm-1", dir="MixedModelsGLMM") + jaspTools::expect_equal_plots(testPlot, "plot-glmm-1") }) test_that("Estimated Trends table results match", { @@ -402,7 +402,7 @@ context("Generalized Linear Mixed Models") ### binomial + probit, type II with LRT, no random slopes, custom options { - options <- analysisOptions("MixedModelsGLMM") + options <- jaspTools::analysisOptions("MixedModelsGLMM") options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3", "4", "5", "6", "7"), name = "contNormal", values = c("-1.11", "0", "1.11", "-1.11", "0", "1.11")), list(isContrast = FALSE, levels = c("2", @@ -464,7 +464,7 @@ context("Generalized Linear Mixed Models") options$trendsTrend <- list() options$type <- "2" set.seed(1) - results <- runAnalysis("MixedModelsGLMM", "debug", options) + results <- jaspTools::runAnalysis("MixedModelsGLMM", "debug", options) test_that("ANOVA Summary table results match", { @@ -549,13 +549,13 @@ context("Generalized Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - jaspTools::expect_equal_plots(testPlot, "plot-glmm-2", dir="MixedModelsGLMM") + jaspTools::expect_equal_plots(testPlot, "plot-glmm-2") }) } ### gamma + log, parametric bootsrap, no correlation { - options <- analysisOptions("MixedModelsGLMM") + options <- jaspTools::analysisOptions("MixedModelsGLMM") options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", values = c("f", "m")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 1", values = c("1", "0")), list(isContrast = TRUE, @@ -614,7 +614,7 @@ context("Generalized Linear Mixed Models") options$trendsTrend <- list() options$type <- "2" set.seed(1) - results <- runAnalysis("MixedModelsGLMM", "debug", options) + results <- jaspTools::runAnalysis("MixedModelsGLMM", "debug", options) test_that("ANOVA Summary table results match", { @@ -688,13 +688,13 @@ context("Generalized Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - jaspTools::expect_equal_plots(testPlot, "plot-glmm-3", dir="MixedModelsGLMM") + jaspTools::expect_equal_plots(testPlot, "plot-glmm-3") }) } ### poisson + log, type II parametric bootsrap { - options <- analysisOptions("MixedModelsGLMM") + options <- jaspTools::analysisOptions("MixedModelsGLMM") options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", values = c("f", "m")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 1", values = c("0", "0"))) @@ -742,7 +742,7 @@ context("Generalized Linear Mixed Models") options$trendsTrend <- list() options$type <- "2" set.seed(1) - results <- runAnalysis("MixedModelsGLMM", "debug", options) + results <- jaspTools::runAnalysis("MixedModelsGLMM", "debug", options) test_that("ANOVA Summary table results match", { @@ -791,7 +791,7 @@ context("Generalized Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - jaspTools::expect_equal_plots(testPlot, "plot-glmm-4", dir="MixedModelsGLMM") + jaspTools::expect_equal_plots(testPlot, "plot-glmm-4") }) } @@ -870,7 +870,7 @@ context("Generalized Linear Mixed Models") 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L)), class = "data.frame", row.names = c(NA, -60L)) - results <- runAnalysis("MixedModelsGLMM", dataset, options) + results <- jaspTools::runAnalysis("MixedModelsGLMM", dataset, options) test_that("ANOVA Summary table results match", { @@ -943,6 +943,6 @@ context("Generalized Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - jaspTools::expect_equal_plots(testPlot, "plot-glmm-5", dir="MixedModelsGLMM") + jaspTools::expect_equal_plots(testPlot, "plot-glmm-5") }) } diff --git a/tests/testthat/test-mixedmodelslmm.R b/tests/testthat/test-mixedmodelslmm.R index 072d5472..a2053ca0 100644 --- a/tests/testthat/test-mixedmodelslmm.R +++ b/tests/testthat/test-mixedmodelslmm.R @@ -2,7 +2,7 @@ context("Linear Mixed Models") ### default, all selected output using Satterwhite method { - options <- analysisOptions("MixedModelsLMM") + options <- jaspTools::analysisOptions("MixedModelsLMM") options$Contrasts <- list(list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18"), name = "cA", values = c("1", "2", "1", "2", @@ -313,7 +313,7 @@ context("Linear Mixed Models") 0.067540856, 0.169211418, 1, 1, 0.052260709, 0.052824504, 1, 0.12313927, 0.085084118, 1, 0.018040391, 0.055642594, 1, 0.901317881, 0.859124256)), class = "data.frame", row.names = c(NA, -300L)) - results <- runAnalysis("MixedModelsLMM", dataset, options) + results <- jaspTools::runAnalysis("MixedModelsLMM", dataset, options) test_that("ANOVA Summary table results match", { @@ -412,7 +412,7 @@ context("Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - jaspTools::expect_equal_plots(testPlot, "plot-lmm-1", dir="MixedModelsLMM") + jaspTools::expect_equal_plots(testPlot, "plot-lmm-1") }) test_that("Estimated Trends table results match", { @@ -525,7 +525,7 @@ context("Linear Mixed Models") test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list("1, 18.41", "contGamma", 0.653715812700852, 1, 0.207944253049949, "1, 41.32", "contBinom", 0.980965955359944, 1, 0.000576132863050751, "1, 31.67", "facExperim", 0.150390022121331, 1.29117932770481, @@ -549,7 +549,7 @@ context("Linear Mixed Models") test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(0, -2.8707548076634, 71.9900762735203, 0.162066154069144, -0.776927722113553, 1, 0.079474455095956, 1.82792948364777, 0.471035277718885, -1.77891951105823, 1.10106003025184, 0, 2.03296079621, 6.83551339852499, -0.0692441954233528, @@ -570,7 +570,7 @@ context("Linear Mixed Models") test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(29.731918444623, 0.0266514294991932, 0.912642659804403, 1, 0.240876860206388, 0.110643378016293, "Intercept", 82.2103671303575, -0.0471704250772184, 0.60243960877149, 1, 0.0902066016520024, -0.522915443142307, @@ -606,58 +606,58 @@ context("Linear Mixed Models") test_that("facFive.3: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE4"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(1, "facExperim (control)", "NaN", 1, "facExperim (experimental)" )) }) test_that("facFive.4: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE5"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(1, "facGender (f)", "NaN", 1, "facGender (m)")) }) test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES5"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(1.01552953184787, 1.03130023005516)) }) test_that("facFive: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(0, 0, "Intercept")) }) test_that("facFive.1: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE2"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(0, 0, "contGamma")) }) test_that("facFive.2: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE3"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(0, 0, "contBinom")) }) test_that("facFive.3: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE4"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(0, 0, "facExperim (control)", 0.237531600307891, 0.0564212611448276, "facExperim (experimental)")) }) test_that("facFive.4: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE5"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(0, 0, "facGender (f)", 0.156150662299331, 0.0243830293365197, "facGender (m)")) }) test_that("Contrasts table results match", { table <- results[["results"]][["contrasts_Means"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list("Contrast 1", 82.2103671303575, -0.231310349492497, 0.60243960877149, 1, 0.442347520093316, -0.522915443142307, "Contrast 2", 79.902751067842, -0.642750180031443, 0.548152227927422, 1, 1.06574918195276, @@ -666,7 +666,7 @@ context("Linear Mixed Models") test_that("Contrasts table results match", { table <- results[["results"]][["contrasts_Trends"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list("Contrast 1", 57.0113581457788, -0.560541517971749, 0.0729821205951162, 1.92573082206986, 0.306860675388687, -1.82669713954627)) }) @@ -674,12 +674,12 @@ context("Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - expect_equal_plots(testPlot, "plot-lmm-2", dir="MixedModelsLMM") + jaspTools::expect_equal_plots(testPlot, "plot-lmm-2") }) test_that("Estimated Trends table results match", { table <- results[["results"]][["trendsSummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(54.9443259882744, "control", "f", -0.23167495146059, 1, 2.7550330650536e-44, 1.33130145662102e+41, 0.202640740799574, 0.174435417422133, -43.5527650942956, 0.580545786304856, 71.3758039065814, "experimental", @@ -748,13 +748,13 @@ context("Linear Mixed Models") test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(1, "facGender", 0.0892620294750889, 2.88763209614939)) }) test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(-0.421706173425421, "f", -0.704496259899192, 0.144283307603805, -0.13891608695165, 0.0410342976475168, "m", -0.296581004637054, 0.172255870489273, 0.378649599932087)) @@ -762,7 +762,7 @@ context("Linear Mixed Models") test_that("Estimated Means and Confidence Intervals table results match", { table <- results[["results"]][["EstimatesTable"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list("f", -2.19323331697357, -0.421706173425421, 1.34982097012273, "m", -0.812059108259059, 0.0410342976475168, 0.894127703554092 )) @@ -770,7 +770,7 @@ context("Linear Mixed Models") test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(10.7325465569702, -0.190335937888952, 0.110892631343371, 0.10955506682194, -1.73735403948323, "Intercept", 7.33390917066216, -0.231370235536469, 0.082440039209281, 0.115076349521506, -2.01058024953449, "facGender (1)" @@ -780,7 +780,7 @@ context("Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - expect_equal_plots(testPlot, "plot-lmm-3", dir="MixedModelsLMM") + jaspTools::expect_equal_plots(testPlot, "plot-lmm-3") }) } ### parametric bootstrap @@ -837,14 +837,14 @@ context("Linear Mixed Models") test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(1, "facGender", 0.0585272236145518, 0.129411764705882, 3.57863502661178 )) }) test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(-0.421706207520219, "f", -0.704496301095866, 0.144283311227277, -0.138916113944573, 0.0410341526398586, "m", -0.296585024170459, 0.172257847324448, 0.378653329450176)) @@ -852,7 +852,7 @@ context("Linear Mixed Models") test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(10.7321152909457, -0.19033602744018, 0.110894939742407, 0.109555523338383, -1.73734761735647, "Intercept", 7.33364788694893, -0.231370180080039, 0.0824437479104129, 0.115077396728607, -2.01056147129998, "facGender (1)" @@ -861,19 +861,19 @@ context("Linear Mixed Models") test_that("facFive: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE1"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(1, "Intercept", -1, 1, "facGender (1)")) }) test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES1"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(1.01581460714797, 1.00787628563627)) }) test_that("facFive: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] - expect_equal_tables(table, + jaspTools::expect_equal_tables(table, list(0.0906377552259416, 0.00821520267239771, "Intercept", 0.120437360968589, 0.0145051579170782, "facGender (1)")) }) @@ -881,7 +881,7 @@ context("Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - expect_equal_plots(testPlot, "plot-lmm-4", dir="MixedModelsLMM") + jaspTools::expect_equal_plots(testPlot, "plot-lmm-4") }) } @@ -959,6 +959,6 @@ context("Linear Mixed Models") test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] - jaspTools::expect_equal_plots(testPlot, "plot-lmm-5", dir="MixedModelsLMM") + jaspTools::expect_equal_plots(testPlot, "plot-lmm-5") }) } From 5cf9527e8ac5c79c56ea762d089caa4a958f21d8 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 30 Jun 2021 12:10:55 +0200 Subject: [PATCH 16/38] removing duplication within the common file and separating messages --- R/MixedModelsCommon.R | 3484 --------------------------------------- R/MixedModelsMessages.R | 209 +++ 2 files changed, 209 insertions(+), 3484 deletions(-) create mode 100644 R/MixedModelsMessages.R diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 3bf56c36..1f46ed12 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -3096,3487 +3096,3 @@ "dependentVariableAggregation", "family", "link") -# texts and messages -.mmMessageInterpretability <- - gettext("The intercept corresponds to the (unweighted) grand mean; for each factor with k levels, k - 1 parameters are estimated. Consequently, the estimates cannot be directly mapped to factor levels.") -.mmMessageSingularFit <- - gettext("Model fit is singular. Specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Carefully reduce the random effects structure, but this practice might inflate the reported p-value, and invalidates the analysis.") -.mmMessageVovkSellke <- - gettextf("Vovk-Sellke Maximum p-Ratio: Based on a two-sided p-value, the maximum possible odds in favor of H%1$s over H%2$s equals 1/(-e p log(p)) for p %3$s .37 (Sellke, Bayarri, & Berger, 2001).","\u2081","\u2080","\u2264") -.mmMessageNumericalProblems <- - gettext("Numerical problems with the maximum-likelihood estimate (e.g., gradients too large). This may indicate that the specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Consider carefully reducing the random effects structure, but be aware this may induce unknown risks of anti-conservative results (i.e., p-values might be lower than nominal).") -.mmMessageDFdisabled <- - gettext("Estimation of degrees of freedom disabled (i.e., asymptotic results shown), because the number of observations is large. To force estimation, check corresponding option.") -.mmMessageResponse <- gettext("Results are on the response scale.") -.mmMessageNotResponse <- - gettext("Results are not on the response scale and might be misleading.") -.mmMessageANOVAtype <- function(type) { - gettextf("Type %s Sum of Squares",type) -} -.mmMessageREgrouping <- function(RE_grouping_factors) { - sprintf( - ngettext( - length(RE_grouping_factors), - "The following variable is used as a random effects grouping factor: %s.", - "The following variables are used as random effects grouping factors: %s." - ), - paste0("'", RE_grouping_factors, "'", collapse = ", ") - ) -} -.mmMessageMissingRE <- gettext("This analysis requires at least one random effects grouping factor to run.") -.mmMessageMissingAgg <- gettext("The 'Binomial (aggregated)' family requires the 'Number of trials' to be specified to run.") -.mmMessageTestNull <- function(value) { - gettextf("P-values correspond to test of null hypothesis against %s.", value) -} -.mmMessageAveragedOver <- function(terms) { - gettextf("Results are averaged over the levels of: %s.",paste(terms, collapse = ", ")) -} -.mmMessageOmmitedTerms1 <- function(terms, grouping) { - sprintf( - ngettext( - length(terms), - "All random slopes involving ‘%s’ have been removed for the random effects grouping factor ‘%s’. -- Factor %s does not vary within the levels of random effects grouping factor '%s'.", - "All random slopes involving ‘%s’ have been removed for the random effects grouping factor ‘%s’. -- Factors %s do not vary within the levels of random effects grouping factor '%s'.", - ), - paste0("'", terms, "'", collapse = ", "), - grouping, - paste0("'", terms, "'", collapse = ", "), - grouping - ) -} -.mmMessageOmmitedTerms2 <- function(terms, grouping) { - sprintf( - ngettext( - length(terms), - "Random slopes of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slopes of '%s' for random effects grouping factor '%s'.", - "Random slope of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slope of '%s' for random effects grouping factor '%s'.", - ), - paste0("'", terms, "'", collapse = ", "), - grouping, - paste0("'", terms, "'", collapse = ", "), - grouping - ) -} -.mmMessageAddedTerms <- function(terms, grouping) { - sprintf( - ngettext( - length(terms), - "Lower order random effects terms need to be specified in presence of the higher order random effects terms. Therefore, the following random effects term was added to the '%s' random effects grouping factor: '%s.'", - "Lower order random effects terms need to be specified in presence of the higher order random effects terms. Therefore, the following random effects terms were added to the '%s' random effects grouping factor: '%s.'" - ), - grouping, - paste0("'", terms, "'", collapse = ", ") - ) -} -.mmMessageMissingRows <- function(value) { - sprintf( - ngettext( - value, - "%i observation was removed due to missing values.", - "%i observations were removed due to missing values." - ), - value - ) -} -.mmMessageGLMMtype <- function(family, link) { - family <- switch(family, - "binomial" = gettext("binomial"), - "binomial_agg" = gettext("binomial"), - "gaussian" = gettext("gaussian"), - "Gamma" = gettext("gamma"), - "inverse.gaussian" = gettext("inverse gaussian"), - "poisson" = gettext("poisson"), - "neg_binomial_2" = gettext("negative binomial"), - "betar" = gettext("beta"), - ) - gettextf("Generalized linear mixed model with %s family and %s link function.", - family, - link) -} -.mmMessageTermTest <- function(method) { - method <- switch(method, - "S" = gettext("Satterthwaite"), - "KR" = gettext("Kenward-Roger"), - "LRT" = gettext("likelihood ratio tests"), - "PB" = gettext("parametric bootstrap") - ) - gettextf("Model terms tested with %s method.",method) -} -.messagePvalAdjustment <- function(adjustment) { - if (adjustment == "none") { - return(gettext("P-values are not adjusted.")) - } - adjustment <- switch(adjustment, - "holm" = gettext("Holm"), - "hommel" = gettext("Homel"), - "hochberg" = gettext("Hochberg"), - "mvt" = gettext("Multivariate-t"), - "tukey" = gettext("Tukey"), - "BH" = gettext("Benjamini-Hochberg"), - "BY" = gettext("Benjamini-Yekutieli"), - "scheffe" = gettext("Scheffé"), - "sidak" = gettext("Sidak"), - "dunnettx" = gettext("Dunnett"), - "bonferroni" = gettext("Bonferroni") - ) - return(gettextf("P-values are adjusted using %s adjustment.",adjustment)) -} -.mmMessageDivergentIter <- function(iterations) { - sprintf( - ngettext( - iterations, - "The Hamiltonian Monte Carlo procedure might be invalid -- There was %i divergent transition after warmup. This can be solved by carefully increasing 'Adapt delta' until there are no divergent transitions.", - "The Hamiltonian Monte Carlo procedure might be invalid -- There were %i divergent transitions after warmup. This can be solved by carefully increasing 'Adapt delta' until there are no divergent transitions." - ), - iterations - ) -} -.mmMessageLowBMFI <- function(nChains) { - sprintf( - ngettext( - nChains, - "Bayesian Fraction of Missing Information (BFMI) that was too low in %i chain indicating that the posterior distribution was not explored efficiently. Try increasing number of 'Burnin' and 'Iterations'.", - "Bayesian Fraction of Missing Information (BFMI) that was too low in %i chains indicating that the posterior distribution was not explored efficiently. Try increasing number of 'Burnin' and 'Iterations'." - ), - nChains - ) -} -.mmMessageMaxTreedepth <- function(iterations) { - sprintf( - ngettext( - iterations, - "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transition exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth", - "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transitions exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth" - ), - iterations - ) -} -.mmMessageMaxRhat <- function(Rhat) { - gettextf( - "Inference possibly unreliable -- MCMC chains might not have converged; The largest R-hat is %.3f > 1.01. To lower R-hat please increase 'Iterations', or 'Adapt delta' in the Options section.", - Rhat - ) -} -.mmMessageMinESS <- function(ESS, treshold) { - gettextf( - "Low estimation accuracy -- The smallest Effective Sample Size (ESS) is %.2f < %1.0f. To increase accuracy please increase 'Iterations', or 'Adapt delta' in the Options section.", - ESS, - treshold - ) -} -.mmMessageBadWAIC <- function(n_bad) { - sprintf( - ngettext( - n_bad, - "WAIC estimate unreliable -- There was %1.0f p_waic estimate larger than 0.4. We recommend using LOO instead.", - "WAIC estimate unreliable -- There were %1.0f p_waic estimates larger than 0.4. We recommend using LOO instead." - ), - n_bad - ) -} -.mmMessageBadLOO <- function(n_bad) { - sprintf( - ngettext( - n_bad, - "LOO estimate unreliable -- There was %1.0f observation with the shape parameter (k) of the generalized Pareto distribution higher than > .5.", - "LOO estimate unreliable -- There were %1.0f observations with the shape parameter (k) of the generalized Pareto distribution higher than > .5." - ), - n_bad - ) -} -.mmMessageFitType <- function(REML) { - gettextf("The model was fitted using %1$s.%2$s", - ifelse(REML, gettext("restricted maximum likelihood"), gettext("maximum likelihood")), - ifelse(REML, gettext(" Please note that models with different fixed effects cannot be compared when REML is used. To use ML, switch 'Test model terms' to 'Likelihood ratio tests'."), "")) -} -# -# Copyright (C) 2019 University of Amsterdam -# -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -# - - -# TODO: Expose priors specification to users in Bxxx? -# TODO: Add 3rd level random effects grouping factors ;) (not that difficult actually) - -.mmRunAnalysis <- function(jaspResults, dataset, options, type){ - - if (.mmReady(options, type)) - dataset <- .mmReadData(jaspResults, dataset, options, type) - if (.mmReady(options, type)) - .mmCheckData(dataset, options, type) - - - # fit the model - if (.mmReady(options, type)){ - if(type %in% c("LMM", "GLMM")).mmFitModel(jaspResults, dataset, options, type) - if(type %in% c("BLMM", "BGLMM")).mmFitModelB(jaspResults, dataset, options, type) - } - - - # create (default) summary tables - if(type %in% c("LMM", "GLMM")).mmSummaryAnova(jaspResults, dataset, options, type) - if(type %in% c("BLMM", "BGLMM")).mmSummaryStanova(jaspResults, dataset, options, type) - - - if (!is.null(jaspResults[["mmModel"]]) && - !jaspResults[[ifelse(type %in% c("LMM", "GLMM"), "ANOVAsummary", "STANOVAsummary")]]$getError()) { - - - # show fit statistics - if (options$fitStats) { - if(type %in% c("LMM", "GLMM")).mmFitStats(jaspResults, options, type) - if(type %in% c("BLMM", "BGLMM")).mmFitStatsB(jaspResults, options, type) - } - - - # show fixed / random effects summary - if (options$showFE){ - if(type %in% c("LMM", "GLMM")).mmSummaryFE(jaspResults, options, type) - if(type %in% c("BLMM", "BGLMM")).mmSummaryFEB(jaspResults, options, type) - } - if (options$showRE){ - if(type %in% c("LMM", "GLMM")).mmSummaryRE(jaspResults, options, type) - if(type %in% c("BLMM", "BGLMM")).mmSummaryREB(jaspResults, options, type) - } - - - # sampling diagnostics - if(type %in% c("BLMM", "BGLMM")){ - if (length(options$samplingVariable1) != 0) - .mmDiagnostics(jaspResults, options, dataset, type) - } - - - # create plots - if (length(options$plotsX)) - .mmPlot(jaspResults, dataset, options, type) - - - # marginal means - if (length(options$marginalMeans) > 0) - .mmMarginalMeans(jaspResults, dataset, options, type) - if (length(options$marginalMeans) > 0 && - options$marginalMeansContrast && - !is.null(jaspResults[["EMMresults"]])) - .mmContrasts(jaspResults, options, type, what = "Means") - - - # trends - if (length(options$trendsTrend) > 0 && - length(options$trendsVariables) > 0) - .mmTrends(jaspResults, dataset, options, type) - if (options$trendsContrast && - length(options$trendsTrend) > 0 && - length(options$trendsVariables) > 0 && - !is.null(jaspResults[["EMTresults"]])) - .mmContrasts(jaspResults, options, type, what = "Trends") - } - - return() -} - -### common mixed-models functions -.mmReadData <- function(jaspResults, dataset, options, type = "LMM") { - if (is.null(dataset)) { - if (type %in% c("LMM","BLMM")) { - dataset <- readDataSetToEnd( - columns.as.numeric = options$dependentVariable, - columns = c( - options$fixedVariables, - options$randomVariables - ) - ) - } else if (type %in% c("GLMM","BGLMM")) { - if (options$family == "binomial_agg"){ - dataset <- readDataSetToEnd( - columns.as.numeric = c(options$dependentVariable, options$dependentVariableAggregation), - columns = c( - options$fixedVariables, - options$randomVariables - ) - ) - } else if (options$dependentVariableAggregation == "") { - dataset <- readDataSetToEnd( - columns.as.numeric = options$dependentVariable, - columns = c( - options$fixedVariables, - options$randomVariables - ) - ) - } - } - } - - dataset <- data.frame(dataset) - - # check and use only the variables that actually used for modeling - used_variables <- .v(c( - options$dependentVariable, - if(type %in% c("GLMM", "BGLMM")) if(options$dependentVariableAggregation != "") options$dependentVariableAggregation, - unique(unlist(options$fixedEffects)), - if(length(options$randomVariables) != 0) options$randomVariables - )) - dataset <- dataset[,used_variables] - - # omit NAs/NaN/Infs and store the number of omitted observations - all_rows <- nrow(dataset) - dataset <- na.omit(dataset) - - # store the number of missing values into a jaspState object - n_missing <- createJaspState() - n_missing$object <- all_rows - nrow(dataset) - jaspResults[["n_missing"]] <- n_missing - - return(dataset) -} -.mmCheckData <- function(dataset, options, type = "LMM") { - - if(nrow(dataset) < length(options$fixedEffects)).quitAnalysis("The dataset contains fewer observations than predictors (after excluding NAs/NaN/Inf).") - - check_variables <- 1:ncol(dataset) - if(type %in% c("GLMM", "BGLMM")) - if(options$dependentVariableAggregation != "") - check_variables <- check_variables[-which(.v(options$dependentVariableAggregation) == colnames(dataset))] - - - .hasErrors( - dataset, - type = 'infinity', - exitAnalysisIfErrors = TRUE - ) - - # the aggregation variable for binomial can have zero variance and can be without factor levels - .hasErrors( - dataset[,check_variables], - type = c('variance', 'factorLevels'), - factorLevels.amount = "< 2", - exitAnalysisIfErrors = TRUE, - custom = .mmCustomChecks - ) - - for(var in unlist(options$fixedEffects)) { - if(is.factor(dataset[,.v(var)]) || is.character(dataset[,.v(var)])){ - if(length(unique(dataset[,.v(var)])) == nrow(dataset)) - .quitAnalysis(gettextf("The categorical fixed effect '%s' must have fewer levels than the overall number of observations.",var)) - } - } - - for(var in unlist(options$randomVariables)) { - if(length(unique(dataset[,.v(var)])) == nrow(dataset)) - .quitAnalysis(gettextf("The random effects grouping factor '%s' must have fewer levels than the overall number of observations.",var)) - } - - # check hack-able options - if (type %in% c("BLMM", "BGLMM")) { - if (options$iteration - 1 <= options$warmup) { - .quitAnalysis(gettext("The number of iterations must be at least 2 iterations higher than the burnin")) - } - } - - # check families - if (type %in% c("GLMM","BGLMM")) { - family_text <- .mmMessageGLMMtype(options$family, options$link) - family_text <- substr(family_text, 1, nchar(family_text) - 1) - - if (options$family %in% c("Gamma", "inverse.gaussian")) { - if (any(dataset[, .v(options$dependentVariable)] <= 0)) - .quitAnalysis(gettextf("%s requires that the dependent variable is positive.",family_text)) - } else if (options$family %in% c("neg_binomial_2", "poisson")) { - if (any(dataset[, .v(options$dependentVariable)] < 0 | any(!.is.wholenumber(dataset[, .v(options$dependentVariable)])))) - .quitAnalysis(gettextf("%s requires that the dependent variable is an integer.",family_text)) - } else if (options$family == "binomial") { - if (any(!dataset[, .v(options$dependentVariable)] %in% c(0, 1))) - .quitAnalysis(gettextf("%s requires that the dependent variable contains only 0 and 1.",family_text)) - } else if (options$family == "binomial_agg") { - if (any(dataset[, .v(options$dependentVariable)] < 0 | dataset[, .v(options$dependentVariable)] > 1)) - .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",family_text)) - if (any(dataset[, .v(options$dependentVariableAggregation)] < 0) || any(!.is.wholenumber(dataset[, .v(options$dependentVariableAggregation)]))) - .quitAnalysis(gettextf("%s requires that the number of trials variable is an integer.",family_text)) - if (any(!.is.wholenumber(dataset[, .v(options$dependentVariable)] * dataset[, .v(options$dependentVariableAggregation)]))) - .quitAnalysis(gettextf("%s requires that the dependent variable is proportion of successes out of the number of trials.",family_text)) - } else if (options$family == "betar") { - if (any(dataset[, .v(options$dependentVariable)] <= 0 | dataset[, .v(options$dependentVariable)] >= 1)) - .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",family_text)) - } - } -} -.mmReady <- function(options, type = "LMM") { - if (type %in% c("LMM","BLMM")) { - if (options$dependentVariable == "" || - length(options$randomVariables) == 0 || - length(options$fixedEffects) == 0) { - return(FALSE) - } - } else if (type %in% c("GLMM","BGLMM")) { - if (options$family == "binomial_agg"){ - if (options$dependentVariable == "" || - options$dependentVariableAggregation == "" || - length(options$randomVariables) == 0 || - length(options$fixedEffects) == 0) { - return(FALSE) - } - }else{ - if (options$dependentVariable == "" || - length(options$randomVariables) == 0 || - length(options$fixedEffects) == 0) { - return(FALSE) - } - } - - } - return(TRUE) -} -.mmModelFormula <- function(options, dataset) { - # fixed effects - feTerms <- - sapply(options[["fixedEffects"]], function(x) - paste(.v(unlist(x)), collapse = "*")) - # simplify the terms - feTerms <- .mmSimplifyTerms(feTerms) - # create the FE formula - fixedEffects <- paste0(feTerms, collapse = "+") - - if (fixedEffects == "") - fixedEffects <- 1 - - # random effects - randomEffects <- NULL - removedMe <- list() - removedTe <- list() - addedRe <- list() - for (tempRe in options[["randomEffects"]]) { - # unlist selected random effects - tempVars <- sapply(tempRe$randomComponents, function(x) { - if (x$randomSlopes) { - return(.v(unlist(x$value))) - } else{ - return(NA) - } - }) - tempVarsRem <- sapply(tempRe$randomComponents, function(x) { - if (x$randomSlopes) { - return(NA) - } else{ - return(.v(unlist(x$value))) - } - }) - tempVars <- tempVars[!is.na(tempVars)] - tempVars <- - sapply(tempVars, function(x) - paste(unlist(x), collapse = "*")) - tempVarsRem <- tempVarsRem[!is.na(tempVarsRem)] - tempVarsRem <- - sapply(tempVarsRem, function(x) - paste(unlist(x), collapse = "*")) - ### test sensibility of random slopes - # main effect check #1 - # - remove main effects that have only one level of selected variable for the random effect grouping factor (eg only between subject variables) - # - and associated interactions - meToRemove <- NULL - for (me in tempVars[!grepl("\\*", tempVars)]) { - tempTable <- table(dataset[, c(.v(tempRe$value), me)]) - if (all(apply(tempTable, 1, function(x) - sum(x > 0)) <= 1)) { - meToRemove <- c(meToRemove, me) - } - } - if (!is.null(meToRemove)) { - tempVars <- - tempVars[!tempVars %in% unique(as.vector(sapply(meToRemove, function(x) - tempVars[grepl(x, tempVars, fixed = TRUE)])))] - } - tempVars <- na.omit(tempVars) - # terms check #2 - # - remove terms that have at maximum one measure across the level of variables (targeted at interactions of between subject variables) - teToRemove <- NULL - for (te in tempVars) { - tempTerms <- unlist(strsplit(te, "\\*")) - if (any(sapply(tempTerms, function(x) - typeof(dataset[, .v(x)]) == "double"))) - next - tempTable <- - table(dataset[, c(.v(tempRe$value), tempTerms)]) - if (all(tempTable <= 1)) { - teToRemove <- c(teToRemove, te) - } - } - if (!is.null(teToRemove)) { - teToRemove <- - unique(as.vector(sapply(teToRemove, function(x) - tempVars[grepl(x, tempVars, fixed = TRUE)]))) - tempVars <- tempVars[!tempVars %in% teToRemove] - } - - # simplify the formula - reAdded <- .mmAddedRETerms(tempVars, tempVarsRem) - reTerms <- .mmSimplifyTerms(tempVars) - reTerms <- paste0(reTerms, collapse = "+") - - newRe <- - paste0( - "(", - ifelse(reTerms == "", 1, reTerms), - ifelse(tempRe$correlation || - reTerms == "", "|", "||"), - .v(tempRe$value), - ")" - ) - - randomEffects <- c(randomEffects, newRe) - removedMe[[tempRe$value]] <- .unv(meToRemove) - removedTe[[tempRe$value]] <- .unv(teToRemove) - addedRe[[tempRe$value]] <- reAdded - } - randomEffects <- paste0(randomEffects, collapse = "+") - - modelFormula <- - paste0(.v(options$dependentVariable), - "~", - fixedEffects, - "+", - randomEffects) - - return( - list( - modelFormula = modelFormula, - removedMe = removedMe, - removedTe = removedTe, - addedRe = addedRe - ) - ) -} -.mmSimplifyTerms <- function(terms) { - if (length(terms) > 1) { - splitTerms <- sapply(terms, strsplit, "\\*") - splitTerms <- - sapply(splitTerms, function(x) - trimws(x, which = c("both"))) - - termsToRemove <- rep(NA, length(splitTerms)) - for (i in 1:length(terms)) { - termsToRemove[i] <- - any(sapply(splitTerms[-i], function(x) - all(splitTerms[[i]] %in% x))) - } - terms <- terms[!termsToRemove] - } - return(terms) -} -.mmAddedRETerms <- function(terms, removed) { - added <- NULL - if (length(terms) > 1 && length(removed) >= 1) { - splitTerms <- sapply(terms, strsplit, "\\*") - splitTerms <- - sapply(splitTerms, function(x) - trimws(x, which = c("both"))) - - splitRemoved <- sapply(removed, strsplit, "\\*") - splitRemoved <- - sapply(splitRemoved, function(x) - trimws(x, which = c("both"))) - - termsToRemove <- rep(NA, length(splitTerms)) - for (i in 1:length(removed)) { - if (any(sapply(splitTerms, function(x) - all(splitRemoved[[i]] %in% x)))) { - added <- c(added, paste0(.unv(splitRemoved[[i]]), collapse = "*")) - } - } - } - return(added) -} -.mmFitModel <- function(jaspResults, dataset, options, type = "LMM") { - if (!is.null(jaspResults[["mmModel"]])) - return() - - mmModel <- createJaspState() - #maybe you should define some columns here - jaspResults[["mmModel"]] <- mmModel - - if (options$method == "PB") { - seedDependencies <- c("seed", "setSeed") - .setSeedJASP(options) - } else{ - seedDependencies <- NULL - } - if (type == "LMM") { - dependencies <- c(.mmDependenciesLMM, seedDependencies) - } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM, seedDependencies) - } - mmModel$dependOn(dependencies) - - - modelFormula <- .mmModelFormula(options, dataset) - - if (type == "LMM") { - model <- tryCatch( - afex::mixed( - formula = as.formula(modelFormula$modelFormula), - data = dataset, - type = options$type, - method = options$method, - test_intercept = if (options$method %in% c("LRT", "PB")) - options$test_intercept - else - FALSE, - args_test = list(nsim = options$bootstrap_samples), - check_contrasts = TRUE - ), - error = function(e) - return(e) - ) - } else if (type == "GLMM") { - # needs to be avaluated in the global environment - glmmFamily <<- options$family - glmmLink <<- options$link - - # I wish there was a better way to do this - if (options$family == "binomial_agg") { - glmmWeight <<- dataset[, .v(options$dependentVariableAggregation)] - model <- tryCatch( - afex::mixed( - formula = as.formula(modelFormula$modelFormula), - data = dataset, - type = options$type, - method = options$method, - test_intercept = if (options$method %in% c("LRT", "PB")) - options$test_intercept - else - FALSE, - args_test = list(nsim = options$bootstrap_samples), - check_contrasts = TRUE, - family = eval(call("binomial", glmmLink)), - weights = glmmWeight - ), - error = function(e) - return(e) - ) - } else{ - model <- tryCatch( - afex::mixed( - formula = as.formula(modelFormula$modelFormula), - data = dataset, - type = options$type, - method = options$method, - test_intercept = if (options$method %in% c("LRT", "PB")) - options$test_intercept - else - FALSE, - args_test = list(nsim = options$bootstrap_samples), - check_contrasts = TRUE, - #start = start, - family = eval(call(glmmFamily, glmmLink)) - ), - error = function(e) - return(e) - ) - } - } - - - object <- list( - model = model, - removedMe = modelFormula$removedMe, - removedTe = modelFormula$removedTe, - addedRe = modelFormula$addedRe - ) - - mmModel$object <- object - - return() -} -.mmSummaryAnova <- function(jaspResults, dataset, options, type = "LMM") { - if (!is.null(jaspResults[["ANOVAsummary"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - ANOVAsummary <- createJaspTable(title = gettext("ANOVA Summary")) - #defining columns first to give the user something nice to look at - ANOVAsummary$addColumnInfo(name = "effect", title = gettext("Effect"), type = "string") - if (options$method %in% c("S", "KR")) { - ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "string") - ANOVAsummary$addColumnInfo(name = "stat", title = gettext("F"), type = "number") - } else if - (options$method %in% c("PB", "LRT")) { - ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "integer") - ANOVAsummary$addColumnInfo(name = "stat", title = gettext("ChiSq"), type = "number") - } - ANOVAsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") - if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBoot", title = gettext("p (bootstrap)"), type = "pvalue") - if (options$pvalVS) { - ANOVAsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") - if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBootVS", title = gettext("VS-MPR (bootstrap)"), type = "number") - - ANOVAsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = c("pvalVS", "pvalBootVS")) - } - - jaspResults[["ANOVAsummary"]] <- ANOVAsummary - - ANOVAsummary$position <- 1 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- .mmDependenciesGLMM - } - if (options$method == "PB") { - seedDependencies <- c("seed", "setSeed") - } else{ - seedDependencies <- NULL - } - ANOVAsummary$dependOn(c(dependencies, seedDependencies, "pvalVS")) - - # some error managment for GLMMS - and oh boy, they can fail really easily - if (type %in% c("LMM", "GLMM") && !is.null(model)) { - if (any(attr(model, "class") %in% c("std::runtime_error", "C++Error", "error"))) { - if (model$message == "(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate") - ANOVAsummary$setError( - gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.") - ) - - else if (model$message == "PIRLS loop resulted in NaN value") - ANOVAsummary$setError( - gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data or an overly complex model structure. Try removing some of the predictors.") - ) - - else if (model$message == "cannot find valid starting values: please specify some") - # currently no solution to this, it seems to be a problem with synthetic data only. - # I will try silving it once someone actually has problem with real data. - ANOVAsummary$setError(gettext("The optimizer failed to find a solution due to invalid starting values. (JASP currently does not support specifying different starting values.)")) - - else if (model$message == "Downdated VtV is not positive definite") - ANOVAsummary$setError(gettext("The optimizer failed to find a solution. Probably due to scaling issues quasi-separation in the data. Try rescaling or removing some of the predictors.")) - - - else - ANOVAsummary$setError(.unv(model$message)) - - - return() - } - - } - - - if (is.null(model)) { - if (options$dependentVariable != "" && - length(options$fixedVariables) > 0 && - length(options$randomVariables) == 0) { - ANOVAsummary$addFootnote(.mmMessageMissingRE) - } - if (type == "GLMM") { - if (options$family == "binomial_agg" && - options$dependentVariableAggregation == "") { - ANOVAsummary$addFootnote(.mmMessageMissingAgg) - } - } - return() - } - - - for (i in 1:nrow(model$anova_table)) { - if (rownames(model$anova_table)[i] == "(Intercept)") { - effectName <- gettext("Intercept") - } else{ - effectName <- jaspBase::gsubInteractionSymbol(rownames(model$anova_table)[i]) - } - - tempRow <- list(effect = effectName, - df = afex::nice(model)$df[i]) - - if (options$method %in% c("S", "KR")) { - tempRow$stat = model$anova_table$`F`[i] - tempRow$pval = model$anova_table$`Pr(>F)`[i] - } else if (options$method == "PB") { - tempRow$stat = model$anova_table$Chisq[i] - tempRow$pval = model$anova_table$`Pr(>Chisq)`[i] - tempRow$pvalBoot = model$anova_table$`Pr(>PB)`[i] - } else if (options$method == "LRT") { - tempRow$stat = model$anova_table$Chisq[i] - tempRow$pval = model$anova_table$`Pr(>Chisq)`[i] - } - if (options$pvalVS) { - tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - if (options$method == "PB") { - tempRow$pvalBootVS <- - VovkSellkeMPR(tempRow$pvalBoot) - } - } - - ANOVAsummary$addRows(tempRow) - } - - # add message about (lack of) random effect grouping factors - ANOVAsummary$addFootnote(.mmMessageREgrouping(options$randomVariables)) - - # add warning messages - # deal with type II multiple models stuff - if (is.list(model$full_model)) { - if (lme4::isSingular(model$full_model[[length(model$full_model)]])) { - ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) - } else if (!is.null(model$full_model[[length(model$full_model)]]@optinfo$conv$lme4$messages)) { - ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) - } - } else{ - if (lme4::isSingular(model$full_model)) { - ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) - } else if (!is.null(model$full_model@optinfo$conv$lme4$messages)) { - ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) - } - } - if (jaspResults[["n_missing"]]$object != 0) { - ANOVAsummary$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) - } - - removedMe <- jaspResults[["mmModel"]]$object$removedMe - removedTe <- jaspResults[["mmModel"]]$object$removedTe - addedRe <- jaspResults[["mmModel"]]$object$addedRe - - for (i in seq_along(removedMe)) - ANOVAsummary$addFootnote(.mmMessageOmmitedTerms1(removedMe[[i]], names(removedMe)[i]), symbol = gettext("Note:")) - - for (i in seq_along(removedTe)) - ANOVAsummary$addFootnote(.mmMessageOmmitedTerms2(removedTe[[i]], names(removedTe)[i]), symbol = gettext("Note:")) - - for (i in seq_along(addedRe)) - ANOVAsummary$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) - - - - ANOVAsummary$addFootnote(.mmMessageANOVAtype(ifelse(options$type == 3, gettext("III"), gettext("II")))) - if (type == "GLMM") - ANOVAsummary$addFootnote(.mmMessageGLMMtype(options$family, options$link)) - - ANOVAsummary$addFootnote(.mmMessageTermTest(options$method)) - - - return() -} -.mmFitStats <- function(jaspResults, options, type = "LMM") { - if (!is.null(jaspResults[["fitStats"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - if (is.list(model$full_model)) { - full_model <- model$full_model[[length(model$full_model)]] - } else{ - full_model <- model$full_model - } - - fitSummary <- createJaspContainer("Model summary") - fitSummary$position <- 2 - - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- .mmDependenciesGLMM - } - if (options$method == "PB") - dependencies <- c(dependencies, "seed", "setSeed") - - fitSummary$dependOn(c(dependencies, "fitStats")) - jaspResults[["fitSummary"]] <- fitSummary - - - ### fit statistics - fitStats <- createJaspTable(title = gettext("Fit statistics")) - fitStats$position <- 1 - - if (!lme4::isREML(full_model)) - fitStats$addColumnInfo(name = "deviance", title = gettext("Deviance"), type = "number") - if (lme4::isREML(full_model)) - fitStats$addColumnInfo(name = "devianceREML", title = gettext("Deviance (REML)"), type = "number") - fitStats$addColumnInfo(name = "loglik", title = gettext("log Lik."), type = "number") - fitStats$addColumnInfo(name = "df", title = gettext("df"), type = "integer") - fitStats$addColumnInfo(name = "aic", title = gettext("AIC"), type = "number") - fitStats$addColumnInfo(name = "bic", title = gettext("BIC"), type = "number") - jaspResults[["fitSummary"]][["fitStats"]] <- fitStats - - - tempRow <- list( - loglik = logLik(full_model), - df = attr(logLik(full_model) , "df"), - aic = AIC(full_model), - bic = BIC(full_model) - ) - - if (!lme4::isREML(full_model)) - tempRow$deviance <- deviance(full_model, REML = FALSE) - if (lme4::isREML(full_model)) - tempRow$devianceREML <- lme4::REMLcrit(full_model) - - fitStats$addRows(tempRow) - fitStats$addFootnote(.mmMessageFitType(lme4::isREML(full_model))) - - - ### sample sizes - fitSizes <- createJaspTable(title = gettext("Sample sizes")) - fitSizes$position <- 2 - - fitSizes$addColumnInfo(name = "observations", title = gettext("Observations"), type = "integer") - tempRow <- list( - observations = nrow(full_model@frame) - ) - for (thisName in names(full_model@flist)) { - fitSizes$addColumnInfo(name = thisName, title = .unv(thisName), type = "integer", overtitle = gettext("Levels of RE grouping factors")) - tempRow[[thisName]] <- length(levels(full_model@flist[[thisName]])) - } - fitSizes$addRows(tempRow) - jaspResults[["fitSummary"]][["fitSizes"]] <- fitSizes - - return() -} -.mmSummaryRE <- function(jaspResults, options, type = "LMM") { - if (!is.null(jaspResults[["REsummary"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - REsummary <- createJaspContainer(title = gettext("Variance/Correlation Estimates")) - - REsummary$position <- 4 - - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- .mmDependenciesGLMM - } - if (options$method == "PB") { - seedDependencies <- c("seed", "setSeed") - } else{ - seedDependencies <- NULL - } - REsummary$dependOn(c(dependencies, seedDependencies, "showRE")) - - # deal with SS type II stuff - if (is.list(model$full_model)) { - VarCorr <- - lme4::VarCorr(model$full_model[[length(model$full_model)]]) - } else{ - VarCorr <- lme4::VarCorr(model$full_model) - } - # go over each random effect grouping factor - for (gi in 1:length(VarCorr)) { - tempVarCorr <- VarCorr[[gi]] - - # add variance summary - REvar <- createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) - - REvar$addColumnInfo(name = "variable", - title = gettext("Term"), - type = "string") - REvar$addColumnInfo(name = "std", - title = gettext("Std. Deviation"), - type = "number") - REvar$addColumnInfo(name = "var", - title = gettext("Variance"), - type = "number") - - tempStdDev <- attr(tempVarCorr, "stddev") - for (i in 1:length(tempStdDev)) { - if (names(tempStdDev)[i] == "(Intercept)") { - varName <- gettext("Intercept") - } else{ - varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) - } - - tempRow <- list( - variable = varName, - std = tempStdDev[i], - var = tempStdDev[i]^2 - ) - - REvar$addRows(tempRow) - } - - REvar$addFootnote(.mmMessageInterpretability) - - REsummary[[paste0("VE", gi)]] <- REvar - - - # add correlation summary - if (length(tempStdDev) > 1) { - tempCorr <- attr(tempVarCorr, "correlation") - REcor <- - createJaspTable(title = gettextf("%s: Correlation Estimates",.unv(names(VarCorr)[gi]))) - - # add columns - REcor$addColumnInfo(name = "variable", - title = gettext("Term"), - type = "string") - for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") { - varName <- gettext("Intercept") - } else{ - varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - } - REcor$addColumnInfo(name = paste0("v", i), - title = varName, - type = "number") - } - - # fill rows - for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") { - varName <- gettext("Intercept") - } else{ - varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - } - - tempRow <- list(variable = varName) - for (j in 1:i) { - tempRow[paste0("v", j)] <- tempCorr[i, j] - } - REcor$addRows(tempRow) - } - - REcor$addFootnote(.mmMessageInterpretability) - - REsummary[[paste0("CE", gi)]] <- REcor - - } - - } - - # add residual variance summary - REres <- - createJaspTable(title = gettext("Residual Variance Estimates")) - - REres$addColumnInfo(name = "std", - title = gettext("Std. Deviation"), - type = "number") - REres$addColumnInfo(name = "var", - title = gettext("Variance"), - type = "number") - - if (is.list(model$full_model)) { - tempRow <- - list(std = sigma(model$full_model[[length(model$full_model)]]), - var = sqrt(sigma(model$full_model[[length(model$full_model)]]))) - } else{ - tempRow <- list(std = sigma(model$full_model), - var = sigma(model$full_model)^2) - } - - REres$addRows(tempRow) - REsummary[[paste0("RES", gi)]] <- REres - - - jaspResults[["REsummary"]] <- REsummary - return() -} -.mmSummaryFE <- function(jaspResults, options, type = "LMM") { - if (!is.null(jaspResults[["FEsummary"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - if (is.list(model$full_model)) { - FEcoef <- - summary(model$full_model[[length(model$full_model)]])$coeff - } else{ - FEcoef <- summary(model$full_model)$coeff - } - - FEsummary <- createJaspTable(title = gettext("Fixed Effects Estimates")) - - FEsummary$position <- 3 - if (type == "LMM") dependencies <- .mmDependenciesLMM - else if (type == "GLMM") dependencies <- .mmDependenciesGLMM - - if(options$method == "PB"){ - seedDependencies <- c("seed", "setSeed") - }else{ - seedDependencies <- NULL - } - - - FEsummary$dependOn(c(dependencies, seedDependencies, "showFE", "pvalVS")) - - FEsummary$addColumnInfo(name = "term", title = gettext("Term"), type = "string") - FEsummary$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") - FEsummary$addColumnInfo(name = "se", title = gettext("SE"), type = "number") - if (type == "LMM") FEsummary$addColumnInfo(name = "df", title = gettext("df"), type = "number") - FEsummary$addColumnInfo(name = "stat", title = gettext("t"), type = "number") - if (ncol(FEcoef) >= 4) FEsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") - - if (options$pvalVS) { - FEsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") - FEsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") - } - - jaspResults[["FEsummary"]] <- FEsummary - - for (i in 1:nrow(FEcoef)) { - if (rownames(FEcoef)[i] == "(Intercept)") { - effectName <- gettext("Intercept") - } else{ - effectName <- .mmVariableNames(rownames(FEcoef)[i], options$fixedVariables) - } - - if (type == "LMM") { - tempRow <- list( - term = effectName, - estimate = FEcoef[i, 1], - se = FEcoef[i, 2], - df = FEcoef[i, 3], - stat = FEcoef[i, 4], - pval = FEcoef[i, 5] - ) - } else if (type == "GLMM") { - tempRow <- list( - term = effectName, - estimate = FEcoef[i, 1], - se = FEcoef[i, 2], - stat = FEcoef[i, 3] - ) - if (ncol(FEcoef) >= 4) { - tempRow$pval <- FEcoef[i, 4] - } - } - - if (options$pvalVS) { - tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } - - FEsummary$addRows(tempRow) - } - - # add warning messages - FEsummary$addFootnote(.mmMessageInterpretability) - - -} -.mmFixPlotAxis <- function(p){ - - yTicks <- jaspGraphs::getPrettyAxisBreaks(ggplot2::layer_scales(p)$y$range$range) - yRange <- range(yTicks) - xTicks <- ggplot2::layer_scales(p)$x$range$range - - p + ggplot2::scale_y_continuous(breaks = yTicks, limits = yRange) + - ggplot2::scale_x_discrete(breaks = xTicks) -} -.mmPlot <- function(jaspResults, dataset, options, type = "LMM") { - - if (!is.null(jaspResults[["plots"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - # automatic size specification will somewhat work unless there is more than 2 variables in panel - height <- 350 - width <- 150 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, .v(x)])) / 2)) - - if (length(options$plotsPanel) > 0) { - width <- - width * length(unique(dataset[, .v(unlist(options$plotsPanel)[1])])) - } else if (length(options$plotsPanel) > 1) { - height <- - height * length(unique(dataset[, .v(unlist(options$plotsPanel)[2])])) - } - if (options$plotLegendPosition %in% c("bottom", "top")) { - height <- height + 50 - } else if (options$plotLegendPosition %in% c("left", "right")) { - width <- width + 100 - } - width <- width + 150 - - plots <- createJaspPlot(title = gettext("Plot"), width = width, height = height) - - plots$position <- 5 - switch(type, - LMM = dependencies <- .mmDependenciesLMM, - GLMM = dependencies <- .mmDependenciesGLMM, - BLMM = dependencies <- .mmDependenciesBLMM, - BGLMM = dependencies <- .mmDependenciesBGLMM - ) - - plots$dependOn( - c( - dependencies, - "plotsX", - "plotsTrace", - "plotsPanel", - "plotsAgregatedOver", - "plotsGeom", - "plotsTrace", - "plotsPanel", - "plotsTheme", - "plotsCIwidth", - "plotsCImethod", - "plotAlpha", - "plotJitterWidth", - "plotJitterHeight", - "plotGeomWidth", - "plotDodge", - "plotsBackgroundColor", - "plotRelativeSize", - "plotRelativeSizeText", - "plotLegendPosition", - "plotsMappingColor", - "plotsMappingShape", - "plotsMappingLineType", - "plotsMappingFill", - "seed", - "setSeed" - ) - ) - - jaspResults[["plots"]] <- plots - plots$status <- "running" - - # stop with message if there is no random effects grouping factor selected - if (length(options$plotsAgregatedOver) == 0) { - plots$setError( - gettext("At least one random effects grouping factor needs to be selected in field 'Background data show'.") - ) - return() - } - if (all( - !c( - options$plotsMappingColor, - options$plotsMappingShape, - options$plotsMappingLineType, - options$plotsMappingFill - ) - )) { - plots$setError( - gettext("Factor levels need to be distinguished by at least one feature. Please, check one of the 'Distinguish factor levels' options.") - ) - return() - } - - # select geom - if (options$plotsGeom %in% c("geom_jitter", "geom_violin", "geom_boxplot", "geom_count")) { - geom_package <- "ggplot2" - } else if (options$plotsGeom == "geom_beeswarm") { - geom_package <- "ggbeeswarm" - } else if (options$plotsGeom == "geom_boxjitter") { - geom_package <- "ggpol" - } - - # select mapping - mapping <- - c("color", "shape", "linetype", "fill")[c( - options$plotsMappingColor, - options$plotsMappingShape, - options$plotsMappingLineType, - options$plotsMappingFill - )] - if (length(mapping) == 0) - mapping <- "" - - # specify data_arg - if (options$plotsGeom == "geom_jitter") { - data_arg <- list( - position = - ggplot2::position_jitterdodge( - jitter.width = options$plotJitterWidth, - jitter.height = options$plotJitterHeight, - dodge.width = options$plotDodge - ) - ) - } else if (options$plotsGeom == "geom_violin") { - data_arg <- list(width = options$plotGeomWidth) - } else if (options$plotsGeom == "geom_boxplot") { - data_arg <- list(width = options$plotGeomWidth) - } else if (options$plotsGeom == "geom_count") { - data_arg <- list() - } else if (options$plotsGeom == "geom_beeswarm") { - data_arg <- list(dodge.width = options$plotDodge) - } else if (options$plotsGeom == "geom_boxjitter") { - data_arg <- list( - width = options$plotGeomWidth, - jitter.width = options$plotJitterWidth, - jitter.height = options$plotJitterHeight, - outlier.intersect = TRUE - ) - } - if (options$plotsBackgroundColor != "none" && options$plotsGeom != "geom_jitter" && "color" %in% mapping) - data_arg$color <- options$plotsBackgroundColor - - # fixing afex issues with bootstrap and LRT type II SS - hopefully removeable in the future - if (type %in% c("LMM", "GLMM")) - if (options$method %in% c("LRT", "PB") && options$type == 2) - model <- model$full_model[[length(model$full_model)]] - - .setSeedJASP(options) - p <- tryCatch( - afex::afex_plot( - model, - dv = .v(options$dependentVariable), - x = .v(unlist(options$plotsX)), - trace = if (length(options$plotsTrace) != 0) .v(unlist(options$plotsTrace)), - panel = if (length(options$plotsPanel) != 0) .v(unlist(options$plotsPanel)), - id = .v(options$plotsAgregatedOver), - data_geom = getFromNamespace(options$plotsGeom, geom_package), - mapping = mapping, - error = options$plotsCImethod, - error_level = options$plotsCIwidth, - data_alpha = options$plotAlpha, - data_arg = if (length(data_arg) != 0) data_arg, - error_arg = list( - width = 0, - size = .5 * options$plotRelativeSize - ), - point_arg = list(size = 1.5 * options$plotRelativeSize), - line_arg = list(size = .5 * options$plotRelativeSize), - legend_title = paste(.unv(unlist(options$plotsTrace)), collapse = "\n"), - dodge = options$plotDodge - ), - error = function(e) - e - ) - - if (any(class(p) %in% c("simpleError", "error"))) { - plots$setError(p$message) - return() - } - - if (options$plotsGeom == "geom_violin" && (length(options$plotsAgregatedOver) == 1 && length(unique(dataset[, .v(options$plotsAgregatedOver)])) < 3)) { - plots$setError(gettext("Violin geom requires that the random effects grouping factors has at least 3 levels.")) - return() - } - - # fix the axis - p <- .mmFixPlotAxis(p) - - # fix names of the variables - p <- p + ggplot2::labs(x = unlist(options$plotsX), y = options$dependentVariable) - - # add theme - if (options$plotsTheme == "JASP") { - - p <- jaspGraphs::themeJasp(p, legend.position = options$plotLegendPosition) - - } else if (options$plotsTheme != "JASP") { - - p <- p + switch( - options$plotsTheme, - "theme_bw" = ggplot2::theme_bw() + ggplot2::theme(legend.position = "bottom"), - "theme_light" = ggplot2::theme_light() + ggplot2::theme(legend.position = "bottom"), - "theme_minimal" = ggplot2::theme_minimal() + ggplot2::theme(legend.position = "bottom"), - "theme_pubr" = jaspGraphs::themePubrRaw(legend = options$plotLegendPosition), - "theme_apa" = jaspGraphs::themeApaRaw(legend.pos = switch( - options$plotLegendPosition, - "none" = "none", - "botom" = "bottommiddle", - "right" = "bottomright", - "top" = "topmiddle", - "left" = "bottomleft" - )) - ) - - p <- p + ggplot2::theme( - legend.text = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), - legend.title = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), - axis.text = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), - axis.title = ggplot2::element_text(size = ggplot2::rel(options$plotRelativeSizeText)), - legend.position = options$plotLegendPosition - ) - - } - - - plots$plotObject <- p - - if (options$plotsEstimatesTable) { - plotData <- afex::afex_plot( - model, - x = .v(unlist(options$plotsX)), - dv = .v(options$dependentVariable), - trace = if (length(options$plotsTrace) != 0) - .v(unlist(options$plotsTrace)), - panel = if (length(options$plotsPanel) != 0) - .v(unlist(options$plotsPanel)), - id = .v(options$plotsAgregatedOver), - data_geom = getFromNamespace(options$plotsGeom, geom_package), - error = options$plotsCImethod, - error_level = options$plotsCIwidth, - return = "data" - )$means - - - EstimatesTable <- - createJaspTable(title = gettext("Estimated Means and Confidence Intervals")) - EstimatesTable$position <- 5 - EstimatesTable$dependOn( - c( - dependencies, - "plotsX", - "plotsTrace", - "plotsPanel", - "plotsAgregatedOver", - "plotsCIwidth", - "plotsCImethod", - "seed", - "setSeed", - "plotsEstimatesTable" - ) - ) - - - for (v in attr(plotData, "pri.vars")) { - EstimatesTable$addColumnInfo(name = v, - title = .unv(v), - type = "string") - } - - for (v in options$marginalMeans) { - - } - - EstimatesTable$addColumnInfo(name = "mean", - title = gettext("Mean"), - type = "number") - if (options$plotsCImethod != "none") { - EstimatesTable$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) - ) - EstimatesTable$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) - ) - } - - jaspResults[["EstimatesTable"]] <- EstimatesTable - - for (i in 1:nrow(plotData)) { - tempRow <- list() - for (v in attr(plotData, "pri.vars")) { - tempRow[v] <- as.character(plotData[i, v]) - } - - tempRow$mean <- plotData[i, "y"] - if (options$plotsCImethod != "none") { - tempRow$lowerCI <- plotData[i, "lower"] - tempRow$upperCI <- plotData[i, "upper"] - } - - EstimatesTable$addRows(tempRow) - } - - - } - - return() -} -.mmMarginalMeans <- function(jaspResults, dataset, options, type = "LMM") { - if (!is.null(jaspResults[["EMMresults"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - # deal with continuous predictors - at <- NULL - for (var in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(var)]) == "double") { - at[[.v(var)]] <- - c( - mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$marginalMeansSD * - sd(dataset[, .v(var)], na.rm = TRUE) - ) - } - } - - # compute the results - if (type == "LMM") { - emmeans::emm_options(pbkrtest.limit = if (options$marginalMeansOverride) - Inf, - mmrTest.limit = if (options$marginalMeansOverride) - Inf) - } - emm <- emmeans::emmeans( - object = model, - specs = .v(unlist(options$marginalMeans)), - at = at, - options = list(level = options$marginalMeansCIwidth), - lmer.df = if (type == "LMM") - options$marginalMeansDf - else if (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity") - "asymptotic", - type = if (type %in% c("GLMM", "BGLMM")) - if (options$marginalMeansResponse) - "response" - ) - - emmTable <- as.data.frame(emm) - if (type %in% c("LMM", "GLMM")) { - if (options$marginalMeansCompare) { - emmTest <- - as.data.frame(emmeans::test(emm, null = options$marginalMeansCompareTo)) - } - } - - EMMsummary <- createJaspTable(title = gettext("Estimated Marginal Means")) - EMMresults <- createJaspState() - - EMMsummary$position <- 7 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") - } - if (type %in% c("LMM", "GLMM")) { - dependenciesAdd <- - c( - "marginalMeans", - "marginalMeansSD", - "marginalMeansCompare", - "marginalMeansCompareTo", - "marginalMeansCIwidth", - "pvalVS", - "marginalMeansContrast" - ) - } else{ - dependenciesAdd <- - c( - "marginalMeans", - "marginalMeansSD", - "marginalMeansCIwidth", - "marginalMeansContrast" - ) - } - if (type == "LMM") { - dependenciesAdd <- - c(dependenciesAdd, - "marginalMeansOverride", - "marginalMeansDf") - } - EMMsummary$dependOn(c(dependencies, dependenciesAdd)) - EMMresults$dependOn(c(dependencies, dependenciesAdd)) - - if (options$marginalMeansContrast) { - EMMsummary$addColumnInfo(name = "number", - title = gettext("Row"), - type = "integer") - } - for (v in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(v)]) == "double") { - EMMsummary$addColumnInfo(name = .v(v), - title = .unv(v), - type = "number") - } else{ - EMMsummary$addColumnInfo(name = .v(v), - title = .unv(v), - type = "string") - } - } - - if (type %in% c("LMM", "GLMM")) { - EMMsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMsummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - if(type == "LMM"){ - if(options$marginalMeansDf != "asymptotic"){ - EMMsummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - } - } - EMMsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) - ) - EMMsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) - ) - if (options$marginalMeansCompare) { - EMMsummary$addColumnInfo( - name = "stat", - title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), - type = "number" - ) - EMMsummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") - EMMsummary$addFootnote(.mmMessageTestNull(options$marginalMeansCompareTo), - symbol = "\u2020", colNames = "pval") - - if (options$pvalVS) { - EMMsummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") - EMMsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") - } - } - } else if (type %in% c("BLMM", "BGLMM")) { - EMMsummary$addColumnInfo(name = "estimate", - title = gettext("Median"), - type = "number") - EMMsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) - ) - EMMsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) - ) - } - - jaspResults[["EMMsummary"]] <- EMMsummary - - for (i in 1:nrow(emmTable)) { - tempRow <- list() - - if (options$marginalMeansContrast) { - tempRow$number <- i - } - - for (v in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(v)]) == "double") { - tempRow[.v(v)] <- emmTable[i, .v(v)] - } else{ - tempRow[.v(v)] <- as.character(emmTable[i, .v(v)]) - } - } - - if (type %in% c("LMM", "GLMM")) { - # the estimate is before SE (names change for GLMM) - tempRow$estimate <- - emmTable[i, grep("SE", colnames(emmTable)) - 1] - tempRow$se <- emmTable[i, "SE"] - if(type == "LMM"){ - if(options$marginalMeansDf != "asymptotic"){ - tempRow$df <- emmTable[i, "df"] - } - } - if (options$marginalMeansCompare) { - tempRow$stat <- emmTest[i, grep("ratio", colnames(emmTest))] - tempRow$pval <- emmTest[i, "p.value"] - if (options$pvalVS) { - tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } - } - } else if (type %in% c("BLMM", "BGLMM")) { - tempRow$estimate <- emmTable[i, ncol(emmTable) - 2] - } - - tempRow$lowerCI <- emmTable[i, ncol(emmTable) - 1] - tempRow$upperCI <- emmTable[i, ncol(emmTable)] - - - EMMsummary$addRows(tempRow) - } - - - if (length(emm@misc$avgd.over) != 0) { - EMMsummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) - } - # add warning message - if (type == "LMM") { - if (options$marginalMeansDf != attr(emm@dffun, "mesg")) { - EMMsummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) - } - } - if (type %in% c("GLMM","BGLMM")) { - EMMsummary$addFootnote( - ifelse( - options$marginalMeansResponse, - .mmMessageResponse, - .mmMessageNotResponse - ) - ) - } - - - - - object <- list(emm = emm, - emmTable = emmTable) - EMMresults$object <- object - jaspResults[["EMMresults"]] <- EMMresults - - return() -} -.mmTrends <- function(jaspResults, dataset, options, type = "LMM") { - if (!is.null(jaspResults[["contrasts_Trends"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - # deal with continuous predictors - at <- NULL - for (var in unlist(options$trendsVariables)) { - if (typeof(dataset[, .v(var)]) == "double") { - at[[.v(var)]] <- - c( - mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$trendsSD * - sd(dataset[, .v(var)], na.rm = TRUE) - ) - } - } - - # compute the results - if (type %in% c("LMM")) { - emmeans::emm_options(pbkrtest.limit = if (options$trendsOverride) - Inf, - mmrTest.limit = if (options$trendsOverride) - Inf) - } - - # TODO: deal with the emtrends scoping problems - trendsCI <<- options$trendsCIwidth - trendsAt <<- at - trendsType <<- if (type == "LMM" || (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity")) - "LMM" - else - type - trendsDataset <<- dataset - trendsModel <<- model - trendsDf <<- - if (type == "LMM") - options$trendsDf - else if (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity") - "asymptotic" - - emm <- emmeans::emtrends( - object = trendsModel, - data = trendsDataset, - specs = .v(unlist(options$trendsVariables)), - var = .v(unlist(options$trendsTrend)), - at = trendsAt, - options = list(level = trendsCI), - lmer.df = if (trendsType == "LMM") - trendsDf - ) - emmTable <- as.data.frame(emm) - if (type %in% c("LMM", "GLMM")) { - if (options$trendsCompare) { - emmTest <- - as.data.frame(emmeans::test(emm, null = options$trendsCompareTo)) - } - } - - trendsSummary <- createJaspTable(title = gettext("Estimated Trends")) - EMTresults <- createJaspState() - - trendsSummary$position <- 9 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM) - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- c(.mmDependenciesBGLMM) - } - if (type %in% c("LMM", "GLMM")) { - dependenciesAdd <- - c( - "trendsVariables", - "trendsTrend", - "trendsSD", - "trendsCompare", - "trendsCompareTo", - "trendsCIwidth", - "pvalVS", - "trendsContrast" - ) - } else{ - dependenciesAdd <- - c( - "trendsVariables", - "trendsTrend", - "trendsSD", - "trendsCIwidth", - "trendsContrast" - ) - } - if (type == "LMM") { - dependenciesAdd <- - c(dependenciesAdd, "trendsDf", "trendsOverride") - } - trendsSummary$dependOn(c(dependencies, dependenciesAdd)) - EMTresults$dependOn(c(dependencies, dependenciesAdd)) - - if (options$trendsContrast) { - trendsSummary$addColumnInfo(name = "number", - title = gettext("Row"), - type = "integer") - } - - trendsVarNames <- colnames(emmTable)[1:(grep(".trend", colnames(emmTable), fixed = TRUE) - 1)] - - for (v in trendsVarNames) { - if (typeof(dataset[, .v(v)]) == "double") { - trendsSummary$addColumnInfo(name = v, - title = .unv(v), - type = "number") - } else{ - trendsSummary$addColumnInfo(name = v, - title = .unv(v), - type = "string") - } - } - trendsSummary$addColumnInfo( - name = "slope", - title = gettextf("%s (slope)",unlist(options$trendsTrend)), - type = "number" - ) - if (type %in% c("LMM", "GLMM")) { - trendsSummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - if(type == "LMM"){ - if(options$trendsDf != "asymptotic"){ - trendsSummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - } - } - trendsSummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) - ) - trendsSummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) - ) - if (options$trendsCompare) { - trendsSummary$addColumnInfo( - name = "stat", - title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), - type = "number" - ) - trendsSummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") - trendsSummary$addFootnote(.mmMessageTestNull(options$trendsCompareTo), symbol = "\u2020", colNames = "pval") - - if (options$pvalVS) { - trendsSummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") - trendsSummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") - } - } - } else if (type %in% c("BLMM", "BGLMM")) { - trendsSummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) - ) - trendsSummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) - ) - } - - jaspResults[["trendsSummary"]] <- trendsSummary - - - for (i in 1:nrow(emmTable)) { - tempRow <- list() - - if (options$trendsContrast) { - tempRow$number <- i - } - - for (vi in 1:length(trendsVarNames)) { - if (typeof(dataset[, .v(trendsVarNames[vi])]) == "double") { - tempRow[trendsVarNames[vi]] <- emmTable[i, vi] - } else{ - tempRow[trendsVarNames[vi]] <- - as.character(emmTable[i, vi]) - } - } - tempRow$slope <- emmTable[i, length(trendsVarNames) + 1] - - if (type %in% c("LMM", "GLMM")) { - # the estimate is before SE (names change for GLMM) - tempRow$se <- emmTable[i, "SE"] - if(type == "LMM"){ - if(options$trendsDf != "asymptotic"){ - tempRow$df <- emmTable[i, "df"] - } - } - - if (options$trendsCompare) { - tempRow$stat <- emmTest[i, grep("ratio", colnames(emmTest))] - tempRow$pval <- emmTest[i, "p.value"] - if (options$pvalVS) { - tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } - } - } - - tempRow$lowerCI <- emmTable[i, ncol(emmTable) - 1] - tempRow$upperCI <- emmTable[i, ncol(emmTable)] - - - trendsSummary$addRows(tempRow) - } - - - if (length(emm@misc$avgd.over) != 0) { - trendsSummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) - } - # add warning message - if (type == "LMM") { - if (options$trendsDf != attr(emm@dffun, "mesg")) { - # TODO: for GLMM - trendsSummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) - } - } - if (type == "GLMM") { - trendsSummary$addFootnote(.mmMessageNotResponse) - } - - - - - object <- list(emm = emm, - emmTable = emmTable) - EMTresults$object <- object - - jaspResults[["EMTresults"]] <- EMTresults - - return() -} -.mmContrasts <- function(jaspResults, options, type = "LMM", what = "Means") { - if (what == "Means") { - if (!is.null(jaspResults[["contrasts_Means"]])) - return() - emm <- jaspResults[["EMMresults"]]$object$emm - emmTable <- jaspResults[["EMMresults"]]$object$emmTable - } else if (what == "Trends") { - if (!is.null(jaspResults[["contrasts_Trends"]])) - return() - emm <- jaspResults[["EMTresults"]]$object$emm - emmTable <- jaspResults[["EMTresults"]]$object$emmTable - } - - - EMMCsummary <- createJaspTable(title = gettext("Contrasts")) - - EMMCsummary$position <- ifelse(what == "Means", 8, 10) - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- - c(.mmDependenciesGLMM, if (what == "Means") - "marginalMeansResponse") - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- - c(.mmDependenciesBGLMM, if (what == "Means") - "marginalMeansResponse") - } - if (what == "Means") { - if (type %in% c("LMM", "GLMM")) { - dependenciesAdd <- - c( - "marginalMeans", - "marginalMeansDf", - "marginalMeansSD", - "marginalMeansCompare", - "marginalMeansCompareTo", - "marginalMeansContrast", - "marginalMeansCIwidth", - "pvalVS", - "marginalMeansOverride", - "Contrasts", - "marginalMeansAdjustment" - ) - } else{ - dependenciesAdd <- - c( - "marginalMeans", - "marginalMeansSD", - "marginalMeansContrast", - "marginalMeansCIwidth", - "Contrasts" - ) - } - } else if (what == "Trends") { - if (type %in% c("LMM", "GLMM")) { - dependenciesAdd <- - c( - "trendsVariables", - "trendsTrend", - "trendsDf", - "trendsSD", - "trendsCompare", - "trendsCompareTo", - "trendsContrast", - "trendsContrasts", - "trendsCIwidth", - "pvalVS", - "trendsOverride", - "trendsAdjustment" - ) - } else{ - dependenciesAdd <- - c( - "trendsVariables", - "trendsTrend", - "trendsSD", - "trendsCIwidth", - "trendsContrast", - "trendsContrasts" - ) - } - } - - EMMCsummary$dependOn(c(dependencies, dependenciesAdd)) - - - if (type %in% c("LMM", "GLMM")) { - EMMCsummary$addColumnInfo(name = "contrast", - title = "", - type = "string") - EMMCsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMCsummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - EMMCsummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - EMMCsummary$addColumnInfo(name = "stat", - title = gettext("z"), - type = "number") - EMMCsummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") - if (options$pvalVS) { - EMMCsummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") - EMMCsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") - } - } else if (type %in% c("BLMM", "BGLMM")) { - EMMCsummary$addColumnInfo(name = "contrast", - title = "", - type = "string") - EMMCsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMCsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf( - "%s%% HPD", - 100 * if (what == "Means") - options$marginalMeansCIwidth - else - options$trendsCIwidth - ) - ) - EMMCsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf( - "%s%% HPD", - 100 * if (what == "Means") - options$marginalMeansCIwidth - else - options$trendsCIwidth - ) - ) - } - - # Columns have been specified, show to user - jaspResults[[paste0("contrasts_", what)]] <- EMMCsummary - - if (what == "Means") { - selectedContrasts <- options$Contrasts - selectedAdjustment <- options$marginalMeansAdjustment - - if (type %in% c("GLMM", "BGLMM")) { - selectedResponse <- options$marginalMeansResponse - } - - - } else if (what == "Trends") { - selectedContrasts <- options$trendsContrasts - selectedAdjustment <- options$trendsAdjustment - } - - contrs <- list() - i <- 0 - for (cont in selectedContrasts[sapply(selectedContrasts, function(x) - x$isContrast)]) { - if (all(cont$values == 0)) - next - i <- i + 1 - contrs[[cont$name]] <- - unname(sapply(cont$values, function(x) - eval(parse(text = x)))) - } - if (length(contrs) == 0) { - return() - } - - - # take care of the scale - if (type %in% c("LMM", "BLMM") || what == "Trends") { - emmContrast <- tryCatch( - as.data.frame( - emmeans::contrast(emm, contrs, - adjust = if (type %in% c("LMM", "GLMM")) - selectedAdjustment) - ), - error = function(e) - e - ) - } else if (type %in% c("GLMM", "BGLMM")) { - if (selectedResponse) { - emmContrast <- tryCatch( - as.data.frame( - emmeans::contrast( - emmeans::regrid(emm), - contrs, - adjust = if (type == "GLMM") - selectedAdjustment - ) - ), - error = function(e) - e - ) - } else{ - emmContrast <- tryCatch( - as.data.frame( - emmeans::contrast(emm, contrs, - adjust = if (type == "GLMM") - selectedAdjustment) - ), - error = function(e) - e - ) - } - } - - if (length(emmContrast) == 2) { - EMMCsummary$setError(emmContrast$message) - return() - } - - # fix the title name if there is a t-stats - if (type %in% c("LMM", "GLMM")) - if (colnames(emmContrast)[5] == "t.ratio") - EMMCsummary$setColumnTitle("stat", gettext("t")) - if (type %in% c("GLMM", "BGLMM")) { - if (type == "GLMM") { - tempEstName <- colnames(emmContrast)[ncol(emmContrast) - 4] - } else if (type == "BGLMM") { - tempEstName <- colnames(emmContrast)[ncol(emmContrast) - 2] - } - if (tempEstName == "odds.ratio") { - EMMCsummary$setColumnTitle("estimate", gettext("Odds Ratio")) - } else if (tempEstName == "ratio") { - EMMCsummary$setColumnTitle("estimate", gettext("Ratio")) - } else if (tempEstName == "estimate") { - EMMCsummary$setColumnTitle("estimate", gettext("Estimate")) - } else{ - EMMCsummary$setColumnTitle("estimate", tempEstName) - } - } - - for (i in 1:nrow(emmContrast)) { - if (type %in% c("LMM", "GLMM")) { - tempRow <- list( - contrast = names(contrs)[i], - estimate = emmContrast[i, ncol(emmContrast) - 4], - se = emmContrast[i, "SE"], - df = emmContrast[i, "df"], - stat = emmContrast[i, ncol(emmContrast) - 1], - pval = emmContrast[i, "p.value"] - ) - if (options$pvalVS) { - tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } - - EMMCsummary$addFootnote(.messagePvalAdjustment(selectedAdjustment), symbol = "\u2020", colNames = "pval") - if (options$pvalVS) { - tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } - - } else if (type %in% c("BLMM", "BGLMM")) { - tempRow <- list( - contrast = names(contrs)[i], - estimate = emmContrast[i, ncol(emmContrast) - 2], - lowerCI = emmContrast[i, "lower.HPD"], - upperCI = emmContrast[i, "upper.HPD"] - ) - } - - - if (type %in% c("GLMM", "BGLMM") && what == "Means") { - if (!selectedResponse) { - EMMCsummary$addFootnote(.mmMessageNotResponse) - } else{ - EMMCsummary$addFootnote(.mmMessageResponse) - } - } - - - EMMCsummary$addRows(tempRow) - - } -} - - -# specific Bayesian -.mmReadDataB <- function(dataset, options, type = "BLMM") { - if (!is.null(dataset)) { - return(dataset) - } else{ - if (type == "LMM") { - return( - readDataSetToEnd( - columns.as.numeric = options$dependentVariable, - columns.as.factor = c(options$fixedVariables, options$randomVariables) - ) - ) - } else if (type == "GLMM") { - if (options$dependentVariableAggregation == "") { - return(readDataSetToEnd( - columns = c( - options$dependentVariable, - options$fixedVariables, - options$randomVariables - ) - )) - } else{ - return(readDataSetToEnd( - columns = c( - options$dependentVariable, - options$fixedVariables, - options$randomVariables, - options$dependentVariableAggregation - ) - )) - } - } - } -} -.mmFitModelB <- function(jaspResults, dataset, options, type = "BLMM") { - # hopefully fixing the random errors - contr.bayes <<- stanova::contr.bayes - stan_glmer <- rstanarm::stan_glmer - if (!is.null(jaspResults[["mmModel"]])) - return() - - mmModel <- createJaspState() - - - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - mmModel$dependOn(dependencies) - - modelFormula <- .mmModelFormula(options, dataset) - - if (type == "BLMM") { - model <- tryCatch(stanova::stanova( - formula = as.formula(modelFormula$modelFormula), - check_contrasts = "contr.bayes", - data = dataset, - chains = options$chains, - iter = options$iteration, - warmup = options$warmup, - adapt_delta = options$adapt_delta, - control = list(maxTreedepth = options$max_treedepth), - seed = .getSeedJASP(options), - model_fun = "lmer" - ), error = function(e) e ) - - } else if (type == "BGLMM") { - # needs to be evaluated in the global environment - glmmLink <<- options$link - if (options$family == "neg_binomial_2") { - glmmFamily <<- rstanarm::neg_binomial_2(link = glmmLink) - } else if (options$family == "betar") { - glmmFamily <<- mgcv::betar(link = glmmLink) - } else if (options$family != "binomial_agg"){ - tempFamily <<- options$family - glmmFamily <<- eval(call(tempFamily, glmmLink)) - } - - # I wish there was a better way to do this - if (options$family == "binomial_agg") { - glmmWeight <<- dataset[, .v(options$dependentVariableAggregation)] - - model <- tryCatch(stanova::stanova( - formula = as.formula(modelFormula$modelFormula), - check_contrasts = "contr.bayes", - data = dataset, - chains = options$chains, - iter = options$iteration, - warmup = options$warmup, - adapt_delta = options$adapt_delta, - control = list(maxTreedepth = options$max_treedepth), - weights = glmmWeight, - family = eval(call("binomial", glmmLink)), - seed = .getSeedJASP(options), - model_fun = "glmer" - ), error = function(e) e ) - - } else{ - model <- tryCatch(stanova::stanova( - formula = as.formula(modelFormula$modelFormula), - check_contrasts = "contr.bayes", - data = dataset, - chains = options$chains, - iter = options$iteration, - warmup = options$warmup, - adapt_delta = options$adapt_delta, - control = list(maxTreedepth = options$max_treedepth), - family = glmmFamily, - seed = .getSeedJASP(options), - model_fun = "glmer" - ), error = function(e) e ) - - } - - } - - if (inherits(model, "error")) { - if (model$message == "Dropping columns failed to produce full column rank design matrix") - .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. A factor or combination of factors resulted in more levels than the effective sample size.")) - else - .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model$message)) - } - - object <- list( - model = model, - removedMe = modelFormula$removedMe, - removedTe = modelFormula$removedTe - ) - - mmModel$object <- object - jaspResults[["mmModel"]] <- mmModel - - return() -} -.mmFitStatsB <- function(jaspResults, options, type = "BLMM") { - if (!is.null(jaspResults[["fitStats"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - fitSummary <- createJaspContainer("Model summary") - fitSummary$position <- 2 - - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - - fitSummary$dependOn(c(dependencies, "fitStats")) - jaspResults[["fitSummary"]] <- fitSummary - - ### fit statistics - fitStats <- createJaspTable(title = gettext("Fit Statistics")) - fitStats$position <- 1 - - fitStats$addColumnInfo(name = "waic", title = gettext("WAIC"), type = "number") - fitStats$addColumnInfo(name = "waicSE", title = gettext("SE (WAIC)"), type = "number") - fitStats$addColumnInfo(name = "loo", title = gettext("LOO"), type = "number") - fitStats$addColumnInfo(name = "looSE", title = gettext("SE (LOO)"), type = "number") - - jaspResults[["fitSummary"]][["fitStats"]] <- fitStats - - waic <- loo::waic(model) - loo <- loo::loo(model) - - - nBadWAIC <- sum(waic$pointwise[,2] > 0.4) - nBadLOO <- length(loo::pareto_k_ids(loo, threshold = .7)) - - - if (nBadWAIC > 0) - fitStats$addFootnote(.mmMessageBadWAIC(nBadWAIC), symbol = gettext("Warning:")) - if (nBadLOO > 0) - fitStats$addFootnote(.mmMessageBadLOO(nBadLOO), symbol = gettext("Warning:")) - - - tempRow <- list( - waic = waic$estimates["waic", "Estimate"], - waicSE = waic$estimates["waic", "SE"], - loo = loo$estimates["looic", "Estimate"], - looSE = loo$estimates["looic", "SE"] - ) - - fitStats$addRows(tempRow) - - ### sample sizes - stanovaSummary <- stanova:::summary.stanova(model) - - fitSizes <- createJaspTable(title = gettext("Sample sizes")) - fitSizes$position <- 2 - - fitSizes$addColumnInfo(name = "observations", title = gettext("Observations"), type = "integer") - tempRow <- list( - observations = attr(stanovaSummary, "nobs") - ) - for (n in names(attr(stanovaSummary, "ngrps"))) { - fitSizes$addColumnInfo(name = n, title = .unv(n), type = "integer", overtitle = gettext("Levels of RE grouping factors")) - tempRow[[n]] <- attr(stanovaSummary, "ngrps")[[n]] - } - fitSizes$addRows(tempRow) - jaspResults[["fitSummary"]][["fitSizes"]] <- fitSizes - - return() -} -.mmSummaryREB <- function(jaspResults, options, type = "BLMM") { - if (!is.null(jaspResults[["REsummary"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - REsummary <- createJaspContainer(title = gettext("Variance/Correlation Estimates")) - - REsummary$position <- 4 - - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - REsummary$dependOn(c(dependencies, "showRE", "summaryCI")) - - ### keep this if we decide to change things - #modelSummary <- rstan::summary(model$stanfit, probs = c(.5-options$summaryCI/2, .5+options$summaryCI/2))$summary - #namesSummary <- rownames(modelSummary) - #re_names <- namesSummary[grepl("Sigma[", namesSummary, fixed = T)] - #re_groups <- sapply(re_names, function(x){ - # substr(x,7,regexpr(":", x, fixed = TRUE)[1]-1) - #}) - #re_summary <- modelSummary[namesSummary %in% re_names,] - #s_summary <- modelSummary[namesSummary == "sigma",] - - VarCorr <- rstanarm:::VarCorr.stanreg(model) - # go over each random effect grouping factor - for (gi in 1:length(VarCorr)) { - tempVarCorr <- VarCorr[[gi]] - - # add variance summary - REvar <- - createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) - - REvar$addColumnInfo(name = "variable", - title = gettext("Term"), - type = "string") - REvar$addColumnInfo(name = "std", - title = gettext("Std. Deviation"), - type = "number") - REvar$addColumnInfo(name = "var", - title = gettext("Variance"), - type = "number") - - tempStdDev <- attr(tempVarCorr, "stddev") - for (i in 1:length(tempStdDev)) { - if (names(tempStdDev)[i] == "(Intercept)") { - varName <- gettext("Intercept") - } else{ - varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) - } - - tempRow <- list( - variable = varName, - std = tempStdDev[i], - var = tempStdDev[i]^2 - ) - - REvar$addRows(tempRow) - } - - REvar$addFootnote(.mmMessageInterpretability) - - REsummary[[paste0("VE", gi)]] <- REvar - - - # add correlation summary - if (length(tempStdDev) > 1) { - tempCorr <- attr(tempVarCorr, "correlation") - REcor <- - createJaspTable(title = gettextf("%s: Correlation Estimates",.unv(names(VarCorr)[gi]))) - - # add columns - REcor$addColumnInfo(name = "variable", - title = gettext("Term"), - type = "string") - for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") { - varName <- gettext("Intercept") - } else{ - varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - } - REcor$addColumnInfo(name = paste0("v", i), - title = varName, - type = "number") - } - - # fill rows - for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") { - varName <- gettext("Intercept") - } else{ - varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - } - - tempRow <- list(variable = varName) - for (j in 1:i) { - # ncol(tempCorr) - tempRow[paste0("v", j)] <- tempCorr[i, j] - } - REcor$addRows(tempRow) - } - - REcor$addFootnote(.mmMessageInterpretability) - - REsummary[[paste0("CE", gi)]] <- REcor - - } - - } - - # add residual variance summary - REres <- - createJaspTable(title = gettext("Residual Variance Estimates")) - - REres$addColumnInfo(name = "std", title = gettext("Std. Deviation"), type = "number") - REres$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") - - jaspResults[["REsummary"]] <- REsummary - - tempRow <- list( - std = rstanarm:::sigma.stanreg(model), - var = rstanarm:::sigma.stanreg(model)^2 - ) - - REres$addRows(tempRow) - REsummary[["RES"]] <- REres - - return() -} -.mmSummaryFEB <- function(jaspResults, options, type = "BLMM") { - if (!is.null(jaspResults[["FEsummary"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - - FEsummary <- createJaspTable(title = "Fixed Effects Estimates") - FEsummary$position <- 3 - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - FEsummary$dependOn(c(dependencies, "showFE", "summaryCI")) - - FEsummary$addColumnInfo(name = "term", - title = "Term", - type = "string") - FEsummary$addColumnInfo(name = "estimate", - title = "Estimate", - type = "number") - FEsummary$addColumnInfo(name = "se", - title = "SE", - type = "number") - FEsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - FEsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - FEsummary$addColumnInfo(name = "rhat", - title = "R-hat", - type = "number") - FEsummary$addColumnInfo(name = "neff", - title = "ESS", - type = "number") - - jaspResults[["FEsummary"]] <- FEsummary - - modelSummary <- - rstan::summary(model$stanfit, - probs = c(.5 - options$summaryCI / 2, .5 + options$summaryCI / 2))$summary - namesSummary <- rownames(modelSummary) - feSummary <- - modelSummary[!grepl("b[", namesSummary, fixed = T) & - !namesSummary %in% c("mean_PPD", "log-posterior") & - namesSummary != "sigma" & - !grepl("Sigma[", namesSummary, fixed = T), ] - - for (i in 1:nrow(feSummary)) { - if (rownames(feSummary)[i] == "(Intercept)") { - effectName <- "Intercept" - } else{ - effectName <- .mmVariableNames(rownames(feSummary)[i], options$fixedVariables) - } - - tempRow <- list( - term = effectName, - estimate = feSummary[i, 1], - se = feSummary[i, 3], - lowerCI = feSummary[i, 4], - upperCI = feSummary[i, 5], - rhat = feSummary[i, 7], - neff = feSummary[i, 6] - ) - - FEsummary$addRows(tempRow) - } - - # add warning messages - FEsummary$addFootnote(.mmMessageInterpretability) -} -.mmSummaryStanova <- function(jaspResults, dataset, options, type = "BLMM") { - if (!is.null(jaspResults[["STANOVAsummary"]])) - return() - - model <- jaspResults[["mmModel"]]$object$model - if (!is.null(model) && !class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { - modelSummary <- - summary( - model, - probs = c(.50 - options$summaryCI / 2, .50, .50 + options$summaryCI / 2), - diff_intercept = options$show == "deviation" - ) - } else{ - # dummy object for creating empty summary - modelSummary <- - list("Model summary" = matrix(NA, nrow = 0, ncol = 0)) - } - - STANOVAsummary <- createJaspContainer(title = "") - jaspResults[["STANOVAsummary"]] <- STANOVAsummary - - STANOVAsummary$position <- 1 - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - STANOVAsummary$dependOn(c(dependencies, "summaryCI", "show")) - - # go over each random effect grouping factor - for (i in 1:length(modelSummary)) { - tempSummary <- modelSummary[[i]] - - if (names(modelSummary)[i] == "Model summary") { - varName <- gettext("Model summary") - tableName <- varName - } else if (names(modelSummary)[i] == "(Intercept)") { - varName <- gettext("Intercept") - tableName <- varName - } else{ - varName <- jaspBase::gsubInteractionSymbol(names(modelSummary)[i]) - if (options$show == "deviation") { - tableName <- - gettextf("%s (differences from intercept)",varName) - } else if (options$show == "mmeans") { - if (nrow(tempSummary) == 1) { - tableName <- gettextf("%s (trend)",varName) - } else{ - tableName <- gettextf("%s (marginal means)",varName) - } - } - } - - tempTable <- createJaspTable(title = tableName) - STANOVAsummary[[paste0("summary_", i)]] <- tempTable - - if (varName != "Intercept" && nrow(tempSummary) > 1) { - tempTable$addColumnInfo(name = "level", - title = gettext("Level"), - type = "string") - } - tempTable$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - tempTable$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - tempTable$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - tempTable$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - tempTable$addColumnInfo(name = "rhat", - title = gettext("R-hat"), - type = "number") - tempTable$addColumnInfo(name = "ess_bulk", - title = gettext("ESS (bulk)"), - type = "number") - tempTable$addColumnInfo(name = "ess_tail", - title = gettext("ESS (tail)"), - type = "number") - - if (tableName == gettext("Model summary")) { - if(options$dependentVariable != "" && - length(options$fixedVariables) > 0 && - length(options$randomVariables) == 0) { - tempTable$addFootnote(.mmMessageMissingRE) - } - if (type == "BGLMM") { - if (options$family == "binomial_agg" && - options$dependentVariableAggregation == "") { - tempTable$addFootnote(.mmMessageMissingAgg) - } - } - - if(class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { - STANOVAsummary$setError(gettext("The model could not be estimated. Please, check the options and dataset for errors.")) - } - return() - } - - for (j in 1:nrow(tempSummary)) { - tempRow <- list( - estimate = tempSummary$Mean[j], - se = tempSummary$MAD_SD[j], - lowerCI = tempSummary[j, paste0((.50 - options$summaryCI / 2) * - 100, "%")], - upperCI = tempSummary[j, paste0((.50 + options$summaryCI / 2) * - 100, "%")], - rhat = tempSummary$rhat[j], - ess_bulk = tempSummary$ess_bulk[j], - ess_tail = tempSummary$ess_tail[j] - ) - - if (varName != "Intercept" && nrow(tempSummary) > 1) { - varName <- - paste(.unv(unlist(strsplit( - as.character(tempSummary$Variable[j]), "," - ))), collapse = jaspBase::interactionSymbol) - varName <- gsub(" ", "", varName, fixed = TRUE) - if (grepl(jaspBase::interactionSymbol, names(modelSummary)[i], fixed = T)) { - for (n in unlist(strsplit(.unv(names( - modelSummary - )[i]), jaspBase::interactionSymbol))) { - varName <- gsub(n, "", varName, fixed = TRUE) - } - } else{ - varName <- - gsub(.unv(names(modelSummary)[i]), "", varName, fixed = TRUE) - } - tempRow$level <- varName - } - - tempTable$addRows(tempRow) - } - - # add message about (lack of) random effects grouping factors - tempTable$addFootnote(.mmMessageREgrouping(options$randomVariables)) - - # check model fit - divIterations <- rstan::get_num_divergent(model$stanfit) - lowBmfi <- rstan::get_low_bfmi_chains(model$stanfit) - maxTreedepth <- rstan::get_num_max_treedepth(model$stanfit) - if(any(is.infinite(rstan::summary(model$stanfit)$summary[, "Rhat"]))){ - maxRhat <- Inf - }else{ - maxRhat <- max(rstan::summary(model$stanfit)$summary[, "Rhat"]) - } - minESS <- - min(rstan::summary(model$stanfit)$summary[, "n_eff"]) - if (divIterations != 0) { - tempTable$addFootnote(.mmMessageDivergentIter(divIterations), symbol = gettext("Warning:")) - } - if (length(lowBmfi) != 0) { - tempTable$addFootnote(.mmMessageLowBMFI(length(lowBmfi)), symbol = gettext("Warning:")) - } - if (maxTreedepth != 0) { - tempTable$addFootnote(.mmMessageMaxTreedepth(max_treedepth)) - } - if (maxRhat > 1.01) { - tempTable$addFootnote(.mmMessageMaxRhat(maxRhat), symbol = gettext("Warning:")) - } - if (minESS < 100 * options$chains || is.nan(minESS)) { - tempTable$addFootnote(.mmMessageMinESS(minESS, 100 * options$chains), symbol = gettext("Warning:")) - } - - removedMe <- jaspResults[["mmModel"]]$object$removedMe - removedTe <- jaspResults[["mmModel"]]$object$removedTe - addedRe <- jaspResults[["mmModel"]]$object$addedRe - if (length(removedMe) > 0) { - for (j in 1:length(removedMe)) { - tempTable$addFootnote(.mmMessageOmmitedTerms1(removedMe[[j]], names(removedMe)[j]), - symbol = gettext("Note:")) - } - } - if (length(removedTe) > 0) { - for (j in 1:length(removedTe)) { - tempTable$addFootnote(.mmMessageOmmitedTerms2(removedTe[[j]], names(removedTe)[j]), - symbol = gettext("Note:")) - } - } - if (length(addedRe) > 0) { - for (i in 1:length(addedRe)) { - tempTable$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) - } - } - if (jaspResults[["n_missing"]]$object != 0) { - tempTable$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) - } - if (type == "BGLMM") { - tempTable$addFootnote(.mmMessageGLMMtype(options$family, options$link)) - } - - } - -} -.mmDiagnostics <- function(jaspResults, options, dataset, type = "BLMM") { - if (!is.null(jaspResults[["diagnosticPlots"]])) - return() - - - diagnosticPlots <- createJaspContainer(title = gettext("Sampling diagnostics")) - - diagnosticPlots$position <- 5 - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - diagnosticPlots$dependOn(c( - dependencies, - "samplingPlot", - "samplingVariable1", - "samplingVariable2" - )) - jaspResults[["diagnosticPlots"]] <- diagnosticPlots - - - if (options$samplingPlot == "stan_scat" && - length(options$samplingVariable2) == 0) { - diagnosticPlots[["emptyPlot"]] <- createJaspPlot() - return() - } - - model <- jaspResults[["mmModel"]]$object$model - - if (options$samplingPlot != "stan_scat") { - pars <- - paste0(.v(unlist(options$samplingVariable1)), collapse = ":") - } else{ - pars <- c(paste0(.v(unlist( - options$samplingVariable1 - )), collapse = ":"), - paste0(.v(unlist( - options$samplingVariable2 - )), collapse = ":")) - } - - plotData <- - .mmGetPlotSamples(model = model, - pars = pars, - options = options) - - - for (i in 1:length(plotData)) { - if (names(plotData)[i] == "Intercept") { - varName <- gettext("Intercept") - } else{ - varName <- strsplit(as.character(pars), ":") - varName <- - sapply(varName, function(x) - paste(.unv(unlist( - strsplit(x, ",") - )), collapse = ":")) - varName <- - sapply(varName, function(x) - gsub(" ", "", x, fixed = TRUE)) - varName <- - sapply(varName, function(x) - .mmVariableNames(x, options$fixedVariables)) - varName <- paste0(varName, collapse = " by ") - } - - plots <- - createJaspPlot( - title = varName, - width = 400, - height = 300 - ) - - if (options$samplingPlot == "stan_trace") { - p <- .rstanPlotTrace(plotData[[i]]) - } else if (options$samplingPlot == "stan_scat") { - p <- .rstanPlotScat(plotData[[i]]) - } else if (options$samplingPlot == "stan_hist") { - p <- .rstanPlotHist(plotData[[i]]) - } else if (options$samplingPlot == "stan_dens") { - p <- .rstanPlotDens(plotData[[i]]) - } else if (options$samplingPlot == "stan_ac") { - p <- .rstanPlotAcor(plotData[[i]]) - } - - - if (options$samplingPlot %in% c("stan_hist", "stan_dens")) { - p <- jaspGraphs::themeJasp(p, sides = "b") - p <- p + ggplot2::theme( - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank() - ) - p <- p + ggplot2::labs(x = varName) - } else{ - p <- jaspGraphs::themeJasp(p) - } - if (options$samplingPlot == "stan_trace") { - p <- p + ggplot2::theme(plot.margin = ggplot2::margin(r = 10 * (nchar(options$iteration - options$warmup) - 2))) - } - plots$plotObject <- p - - diagnosticPlots[[names(plotData)[i]]] <- plots - } - -} - -# helper functions -.mmVariableNames <- function(varName, variables) { - for (vn in variables) { - inf <- regexpr(vn, varName, fixed = TRUE) - if (inf[1] != -1) { - varName <- paste0( - substr(varName, 0, inf[1] - 1), - substr(varName, inf[1], inf[1] + attr(inf, "match.length") - 1), - " (", - substr( - varName, - inf[1] + attr(inf, "match.length"), - nchar(varName) - ) - ) - } - } - varName <- gsub(":", paste0(")", jaspBase::interactionSymbol), varName, fixed = TRUE) - varName <- paste0(varName, ")") - varName <- gsub(" ()", "", varName, fixed = TRUE) - return(varName) -} -.mmAddCoefNameStanova <- function(samples, par, coefs_name){ - # this is a mess but the stanova::stanova_samples returns an incomplete variable names - - coefs_trend <- attr(samples, "estimate") - coefs_trend <- gsub("trend ('", "", coefs_trend, fixed = TRUE) - coefs_trend <- gsub("')", "", coefs_trend, fixed = TRUE) - coefs_trend <- strsplit(coefs_trend, ",") - - for(cft in coefs_trend){ - if(cft %in% strsplit(par, ":")[[1]] && !grepl(.unv(cft), coefs_name)){ - coefs_name <- paste0(coefs_name, jaspBase::interactionSymbol, .unv(cft)) - } - } - - return(coefs_name) - -} -.mmGetPlotSamples <- function(model, pars, options) { - matrix_diff <- - stanova::stanova_samples(model, - return = "array", - diff_intercept = options$show == "deviation") - - if (length(pars) == 1) { - samples <- matrix_diff[[pars]] - coefs <- dim(matrix_diff[[pars]])[2] - - plotData <- list() - - for (cf in 1:coefs) { - - coefs_name <- - paste(.unv(unlist( - strsplit(dimnames(samples)$Parameter[cf], ",") - )), collapse = ":") - coefs_name <- gsub(" ", "", coefs_name, fixed = TRUE) - coefs_name <- .mmVariableNames(coefs_name, options$fixedVariables) - coefs_name <- .mmAddCoefNameStanova(samples, pars, coefs_name) - - - plotData[[dimnames(samples)$Parameter[cf]]] <- list( - samp = data.frame( - value = as.vector(samples[, cf,]), - parameter = as.factor(rep(coefs_name, length(as.vector(samples[, cf,])))), - chain = as.factor(c(unlist( - sapply(1:dim(samples)[3], function(x) - rep(x, dim(samples)[1])) - ))), - iteration = rep(1:dim(samples)[1], dim(samples)[3]) - ), - nchains = options$chains, - nparams = 1, - warmup = 0 - ) - } - - } else{ - samples1 <- matrix_diff[[pars[1]]] - samples2 <- matrix_diff[[pars[2]]] - coefs1 <- dim(matrix_diff[[pars[1]]])[2] - coefs2 <- dim(matrix_diff[[pars[2]]])[2] - - plotData <- list() - - for (cf1 in 1:coefs1) { - for (cf2 in 1:coefs2) { - - coefs1Name <- - paste(.unv(unlist( - strsplit(dimnames(samples1)$Parameter[cf1], ",") - )), collapse = ":") - coefs1Name <- gsub(" ", "", coefs1Name, fixed = TRUE) - coefs1Name <- .mmVariableNames(coefs1Name, options$fixedVariables) - coefs1Name <- .mmAddCoefNameStanova(samples1, pars[[1]], coefs1Name) - - coefs2Name <- - paste(.unv(unlist( - strsplit(dimnames(samples2)$Parameter[cf2], ",") - )), collapse = ":") - coefs2Name <- gsub(" ", "", coefs2Name, fixed = TRUE) - coefs2Name <- .mmVariableNames(coefs2Name, options$fixedVariables) - coefs2Name <- .mmAddCoefNameStanova(samples2, pars[[2]], coefs2Name) - - - plotData[[paste0(coefs1Name, ":", coefs2Name)]] <- list( - samp = data.frame( - value = c(as.vector(samples1[, cf1,]), - as.vector(samples2[, cf2,])), - parameter = factor(c( - rep(coefs1Name, dim(samples1)[1] * dim(samples1)[3]), - rep(coefs2Name, dim(samples2)[1] * dim(samples2)[3]) - ), levels = c(coefs1Name, coefs2Name)), - chain = as.factor(c( - unlist(sapply(1:dim(samples1)[3], function(x) - rep(x, dim(samples2)[1]))), - unlist(sapply(1:dim(samples2)[3], function(x) - rep(x, dim(samples2)[1]))) - )), - iteration = c(rep( - 1:dim(samples1)[1], dim(samples1)[3] - ), - rep( - 1:dim(samples2)[1], dim(samples2)[3] - )) - ), - nchains = options$chains, - nparams = 2, - warmup = 0 - ) - } - } - - } - - return(plotData) - -} -# as explained in ?is.integer -.is.wholenumber <- - function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol -# modified rstan plotting functions -.rstanPlotHist <- function(plotData) { - dots <- rstan:::.add_aesthetics(list(), c("fill", "color")) - thm <- rstan:::rstanvis_hist_theme() - base <- - ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) - graph <- base + do.call(ggplot2::geom_histogram, dots) + - ggplot2::xlab("") + thm + ggplot2::xlab(unique(plotData$samp$parameter)) - - return(graph) -} -.rstanPlotTrace <- function(plotData) { - thm <- rstan:::rstanvis_theme() - clrs <- - rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plotData$nchains) - base <- - ggplot2::ggplot(plotData$samp, - ggplot2::aes_string(x = "iteration", - y = "value", color = "chain")) - - graph <- - base + ggplot2::geom_path() + ggplot2::scale_color_manual(values = clrs) + - ggplot2::labs(x = "", y = levels(plotData$samp$parameter)) + thm - - graph <- graph + ggplot2::scale_x_continuous( - breaks = jaspGraphs::getPrettyAxisBreaks(c(1,max(plotData$samp$iteration)))) - - - graph -} -.rstanPlotDens <- function(plotData, separate_chains = TRUE) { - clrs <- - rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plotData$nchains) - thm <- rstan:::rstanvis_hist_theme() - base <- - ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) + - ggplot2::xlab("") - - if (!separate_chains) { - dots <- rstan:::.add_aesthetics(list(), c("fill", "color")) - graph <- base + do.call(ggplot2::geom_density, dots) + - thm - } else{ - dots <- rstan:::.add_aesthetics(list(), c("color", "alpha")) - dots$mapping <- ggplot2::aes_string(fill = "chain") - graph <- base + do.call(ggplot2::geom_density, dots) + - ggplot2::scale_fill_manual(values = clrs) + thm - } - - graph + ggplot2::xlab(unique(plotData$samp$parameter)) - -} -.rstanPlotScat <- function(plotData) { - thm <- rstan:::rstanvis_theme() - dots <- rstan:::.add_aesthetics(list(), c("fill", "pt_color", - "pt_size", "alpha", "shape")) - - p1 <- - plotData$samp$parameter == levels(plotData$samp$parameter)[1] - p2 <- - plotData$samp$parameter == levels(plotData$samp$parameter)[2] - val1 <- plotData$samp[p1, "value"] - val2 <- plotData$samp[p2, "value"] - df <- data.frame(x = val1, y = val2) - base <- ggplot2::ggplot(df, ggplot2::aes_string("x", "y")) - graph <- - base + do.call(ggplot2::geom_point, dots) + ggplot2::labs( - x = levels(plotData$samp$parameter)[1], - y = levels(plotData$samp$parameter)[2] - ) + thm - graph - -} -.rstanPlotAcor <- function(plotData, lags = 30) { - clrs <- - rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plotData$nchains) - thm <- rstan:::rstanvis_theme() - dots <- - rstan:::.add_aesthetics(list(), c("size", "color", "fill")) - ac_dat <- - rstan:::.ac_plotData(dat = plotData$samp, - lags = lags, - partial = FALSE) - - dots$position <- "dodge" - dots$stat <- "summary" - dots$fun.y <- "mean" - y_lab <- gettext("Avg. autocorrelation") - ac_labs <- ggplot2::labs(x = "Lag", y = y_lab) - y_scale <- - ggplot2::scale_y_continuous(breaks = seq(0, 1, 0.25)) - base <- - ggplot2::ggplot(ac_dat, ggplot2::aes_string(x = "lag", y = "ac")) - graph <- - base + do.call(ggplot2::geom_bar, dots) + y_scale + ac_labs + thm - - graph -} - - -.mmCustomChecks <- list( - collinCheck = function(dataset){ - cor_mat <- cor(apply(dataset,2,as.numeric)) - diag(cor_mat) <- 0 - cor_mat[lower.tri(cor_mat)] <- 0 - nearOne <- 1 - abs(cor_mat) < sqrt(.Machine$double.eps) - if(any(nearOne)){ - var_ind <- which(nearOne, arr.ind = TRUE) - varNames <- paste("'", .unv(rownames(cor_mat)[var_ind[,"row"]]),"' and '", .unv(colnames(cor_mat)[var_ind[,"col"]]),"'", sep = "", collapse = ", ") - return(gettextf("The following variables are a linear combination of each other, please, remove one of them from the analysis: %s", varNames)) - } - } -) -.mmDependenciesLMM <- - c( - "dependentVariable", - "fixedEffects", - "randomEffects", - "randomVariables", - "method", - "bootstrap_samples", - "test_intercept", - "type" - ) -.mmDependenciesGLMM <- c(.mmDependenciesLMM, - "dependentVariableAggregation", - "family", - "link") -.mmDependenciesBLMM <- - c( - "dependentVariable", - "fixedEffects", - "randomEffects", - "randomVariables", - "warmup", - "iteration", - "adapt_delta", - "max_treedepth", - "chains", - "seed", - "setSeed" - ) -.mmDependenciesBGLMM <- c(.mmDependenciesBLMM, - "dependentVariableAggregation", - "family", - "link") -# texts and messages -.mmMessageInterpretability <- - gettext("The intercept corresponds to the (unweighted) grand mean; for each factor with k levels, k - 1 parameters are estimated. Consequently, the estimates cannot be directly mapped to factor levels.") -.mmMessageSingularFit <- - gettext("Model fit is singular. Specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Carefully reduce the random effects structure, but this practice might inflate the reported p-value, and invalidates the analysis.") -.mmMessageVovkSellke <- - gettextf("Vovk-Sellke Maximum p-Ratio: Based on a two-sided p-value, the maximum possible odds in favor of H%1$s over H%2$s equals 1/(-e p log(p)) for p %3$s .37 (Sellke, Bayarri, & Berger, 2001).","\u2081","\u2080","\u2264") -.mmMessageNumericalProblems <- - gettext("Numerical problems with the maximum-likelihood estimate (e.g., gradients too large). This may indicate that the specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Consider carefully reducing the random effects structure, but be aware this may induce unknown risks of anti-conservative results (i.e., p-values might be lower than nominal).") -.mmMessageDFdisabled <- - gettext("Estimation of degrees of freedom disabled (i.e., asymptotic results shown), because the number of observations is large. To force estimation, check corresponding option.") -.mmMessageResponse <- gettext("Results are on the response scale.") -.mmMessageNotResponse <- - gettext("Results are not on the response scale and might be misleading.") -.mmMessageANOVAtype <- function(type) { - gettextf("Type %s Sum of Squares",type) -} -.mmMessageREgrouping <- function(RE_grouping_factors) { - sprintf( - ngettext( - length(RE_grouping_factors), - "The following variable is used as a random effects grouping factor: %s.", - "The following variables are used as random effects grouping factors: %s." - ), - paste0("'", RE_grouping_factors, "'", collapse = ", ") - ) -} -.mmMessageMissingRE <- gettext("This analysis requires at least one random effects grouping factor to run.") -.mmMessageMissingAgg <- gettext("The 'Binomial (aggregated)' family requires the 'Number of trials' to be specified to run.") -.mmMessageTestNull <- function(value) { - gettextf("P-values correspond to test of null hypothesis against %s.", value) -} -.mmMessageAveragedOver <- function(terms) { - gettextf("Results are averaged over the levels of: %s.",paste(terms, collapse = ", ")) -} -.mmMessageOmmitedTerms1 <- function(terms, grouping) { - sprintf( - ngettext( - length(terms), - "All random slopes involving ‘%s’ have been removed for the random effects grouping factor ‘%s’. -- Factor %s does not vary within the levels of random effects grouping factor '%s'.", - "All random slopes involving ‘%s’ have been removed for the random effects grouping factor ‘%s’. -- Factors %s do not vary within the levels of random effects grouping factor '%s'.", - ), - paste0("'", terms, "'", collapse = ", "), - grouping, - paste0("'", terms, "'", collapse = ", "), - grouping - ) -} -.mmMessageOmmitedTerms2 <- function(terms, grouping) { - sprintf( - ngettext( - length(terms), - "Random slopes of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slopes of '%s' for random effects grouping factor '%s'.", - "Random slope of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slope of '%s' for random effects grouping factor '%s'.", - ), - paste0("'", terms, "'", collapse = ", "), - grouping, - paste0("'", terms, "'", collapse = ", "), - grouping - ) -} -.mmMessageAddedTerms <- function(terms, grouping) { - sprintf( - ngettext( - length(terms), - "Lower order random effects terms need to be specified in presence of the higher order random effects terms. Therefore, the following random effects term was added to the '%s' random effects grouping factor: '%s.'", - "Lower order random effects terms need to be specified in presence of the higher order random effects terms. Therefore, the following random effects terms were added to the '%s' random effects grouping factor: '%s.'" - ), - grouping, - paste0("'", terms, "'", collapse = ", ") - ) -} -.mmMessageMissingRows <- function(value) { - sprintf( - ngettext( - value, - "%i observation was removed due to missing values.", - "%i observations were removed due to missing values." - ), - value - ) -} -.mmMessageGLMMtype <- function(family, link) { - family <- switch(family, - "binomial" = gettext("binomial"), - "binomial_agg" = gettext("binomial"), - "gaussian" = gettext("gaussian"), - "Gamma" = gettext("gamma"), - "inverse.gaussian" = gettext("inverse gaussian"), - "poisson" = gettext("poisson"), - "neg_binomial_2" = gettext("negative binomial"), - "betar" = gettext("beta"), - ) - gettextf("Generalized linear mixed model with %s family and %s link function.", - family, - link) -} -.mmMessageTermTest <- function(method) { - method <- switch(method, - "S" = gettext("Satterthwaite"), - "KR" = gettext("Kenward-Roger"), - "LRT" = gettext("likelihood ratio tests"), - "PB" = gettext("parametric bootstrap") - ) - gettextf("Model terms tested with %s method.",method) -} -.messagePvalAdjustment <- function(adjustment) { - if (adjustment == "none") { - return(gettext("P-values are not adjusted.")) - } - adjustment <- switch(adjustment, - "holm" = gettext("Holm"), - "hommel" = gettext("Homel"), - "hochberg" = gettext("Hochberg"), - "mvt" = gettext("Multivariate-t"), - "tukey" = gettext("Tukey"), - "BH" = gettext("Benjamini-Hochberg"), - "BY" = gettext("Benjamini-Yekutieli"), - "scheffe" = gettext("Scheffé"), - "sidak" = gettext("Sidak"), - "dunnettx" = gettext("Dunnett"), - "bonferroni" = gettext("Bonferroni") - ) - return(gettextf("P-values are adjusted using %s adjustment.",adjustment)) -} -.mmMessageDivergentIter <- function(iterations) { - sprintf( - ngettext( - iterations, - "The Hamiltonian Monte Carlo procedure might be invalid -- There was %i divergent transition after warmup. This can be solved by carefully increasing 'Adapt delta' until there are no divergent transitions.", - "The Hamiltonian Monte Carlo procedure might be invalid -- There were %i divergent transitions after warmup. This can be solved by carefully increasing 'Adapt delta' until there are no divergent transitions." - ), - iterations - ) -} -.mmMessageLowBMFI <- function(nChains) { - sprintf( - ngettext( - nChains, - "Bayesian Fraction of Missing Information (BFMI) that was too low in %i chain indicating that the posterior distribution was not explored efficiently. Try increasing number of 'Burnin' and 'Iterations'.", - "Bayesian Fraction of Missing Information (BFMI) that was too low in %i chains indicating that the posterior distribution was not explored efficiently. Try increasing number of 'Burnin' and 'Iterations'." - ), - nChains - ) -} -.mmMessageMaxTreedepth <- function(iterations) { - sprintf( - ngettext( - iterations, - "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transition exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth", - "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transitions exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth" - ), - iterations - ) -} -.mmMessageMaxRhat <- function(Rhat) { - gettextf( - "Inference possibly unreliable -- MCMC chains might not have converged; The largest R-hat is %.3f > 1.01. To lower R-hat please increase 'Iterations', or 'Adapt delta' in the Options section.", - Rhat - ) -} -.mmMessageMinESS <- function(ESS, treshold) { - gettextf( - "Low estimation accuracy -- The smallest Effective Sample Size (ESS) is %.2f < %1.0f. To increase accuracy please increase 'Iterations', or 'Adapt delta' in the Options section.", - ESS, - treshold - ) -} -.mmMessageBadWAIC <- function(n_bad) { - sprintf( - ngettext( - n_bad, - "WAIC estimate unreliable -- There was %1.0f p_waic estimate larger than 0.4. We recommend using LOO instead.", - "WAIC estimate unreliable -- There were %1.0f p_waic estimates larger than 0.4. We recommend using LOO instead." - ), - n_bad - ) -} -.mmMessageBadLOO <- function(n_bad) { - sprintf( - ngettext( - n_bad, - "LOO estimate unreliable -- There was %1.0f observation with the shape parameter (k) of the generalized Pareto distribution higher than > .5.", - "LOO estimate unreliable -- There were %1.0f observations with the shape parameter (k) of the generalized Pareto distribution higher than > .5." - ), - n_bad - ) -} -.mmMessageFitType <- function(REML) { - gettextf("The model was fitted using %1$s.%2$s", - ifelse(REML, gettext("restricted maximum likelihood"), gettext("maximum likelihood")), - ifelse(REML, gettext(" Please note that models with different fixed effects cannot be compared when REML is used. To use ML, switch 'Test model terms' to 'Likelihood ratio tests'."), "")) -} diff --git a/R/MixedModelsMessages.R b/R/MixedModelsMessages.R new file mode 100644 index 00000000..3afa67bc --- /dev/null +++ b/R/MixedModelsMessages.R @@ -0,0 +1,209 @@ +# +# Copyright (C) 2019 University of Amsterdam +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +# + +.mmMessageInterpretability <- + gettext("The intercept corresponds to the (unweighted) grand mean; for each factor with k levels, k - 1 parameters are estimated. Consequently, the estimates cannot be directly mapped to factor levels.") +.mmMessageSingularFit <- + gettext("Model fit is singular. Specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Carefully reduce the random effects structure, but this practice might inflate the reported p-value, and invalidates the analysis.") +.mmMessageVovkSellke <- + gettextf("Vovk-Sellke Maximum p-Ratio: Based on a two-sided p-value, the maximum possible odds in favor of H%1$s over H%2$s equals 1/(-e p log(p)) for p %3$s .37 (Sellke, Bayarri, & Berger, 2001).","\u2081","\u2080","\u2264") +.mmMessageNumericalProblems <- + gettext("Numerical problems with the maximum-likelihood estimate (e.g., gradients too large). This may indicate that the specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Consider carefully reducing the random effects structure, but be aware this may induce unknown risks of anti-conservative results (i.e., p-values might be lower than nominal).") +.mmMessageDFdisabled <- + gettext("Estimation of degrees of freedom disabled (i.e., asymptotic results shown), because the number of observations is large. To force estimation, check corresponding option.") +.mmMessageResponse <- gettext("Results are on the response scale.") +.mmMessageNotResponse <- + gettext("Results are not on the response scale and might be misleading.") +.mmMessageANOVAtype <- function(type) { + gettextf("Type %s Sum of Squares",type) +} +.mmMessageREgrouping <- function(RE_grouping_factors) { + sprintf( + ngettext( + length(RE_grouping_factors), + "The following variable is used as a random effects grouping factor: %s.", + "The following variables are used as random effects grouping factors: %s." + ), + paste0("'", RE_grouping_factors, "'", collapse = ", ") + ) +} +.mmMessageMissingRE <- gettext("This analysis requires at least one random effects grouping factor to run.") +.mmMessageMissingAgg <- gettext("The 'Binomial (aggregated)' family requires the 'Number of trials' to be specified to run.") +.mmMessageTestNull <- function(value) { + gettextf("P-values correspond to test of null hypothesis against %s.", value) +} +.mmMessageAveragedOver <- function(terms) { + gettextf("Results are averaged over the levels of: %s.",paste(terms, collapse = ", ")) +} +.mmMessageOmmitedTerms1 <- function(terms, grouping) { + sprintf( + ngettext( + length(terms), + "All random slopes involving ‘%s’ have been removed for the random effects grouping factor ‘%s’. -- Factor %s does not vary within the levels of random effects grouping factor '%s'.", + "All random slopes involving ‘%s’ have been removed for the random effects grouping factor ‘%s’. -- Factors %s do not vary within the levels of random effects grouping factor '%s'.", + ), + paste0("'", terms, "'", collapse = ", "), + grouping, + paste0("'", terms, "'", collapse = ", "), + grouping + ) +} +.mmMessageOmmitedTerms2 <- function(terms, grouping) { + sprintf( + ngettext( + length(terms), + "Random slopes of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slopes of '%s' for random effects grouping factor '%s'.", + "Random slope of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slope of '%s' for random effects grouping factor '%s'.", + ), + paste0("'", terms, "'", collapse = ", "), + grouping, + paste0("'", terms, "'", collapse = ", "), + grouping + ) +} +.mmMessageAddedTerms <- function(terms, grouping) { + sprintf( + ngettext( + length(terms), + "Lower order random effects terms need to be specified in presence of the higher order random effects terms. Therefore, the following random effects term was added to the '%s' random effects grouping factor: '%s.'", + "Lower order random effects terms need to be specified in presence of the higher order random effects terms. Therefore, the following random effects terms were added to the '%s' random effects grouping factor: '%s.'" + ), + grouping, + paste0("'", terms, "'", collapse = ", ") + ) +} +.mmMessageMissingRows <- function(value) { + sprintf( + ngettext( + value, + "%i observation was removed due to missing values.", + "%i observations were removed due to missing values." + ), + value + ) +} +.mmMessageGLMMtype <- function(family, link) { + family <- switch(family, + "binomial" = gettext("binomial"), + "binomial_agg" = gettext("binomial"), + "gaussian" = gettext("gaussian"), + "Gamma" = gettext("gamma"), + "inverse.gaussian" = gettext("inverse gaussian"), + "poisson" = gettext("poisson"), + "neg_binomial_2" = gettext("negative binomial"), + "betar" = gettext("beta"), + ) + gettextf("Generalized linear mixed model with %s family and %s link function.", + family, + link) +} +.mmMessageTermTest <- function(method) { + method <- switch(method, + "S" = gettext("Satterthwaite"), + "KR" = gettext("Kenward-Roger"), + "LRT" = gettext("likelihood ratio tests"), + "PB" = gettext("parametric bootstrap") + ) + gettextf("Model terms tested with %s method.",method) +} +.messagePvalAdjustment <- function(adjustment) { + if (adjustment == "none") { + return(gettext("P-values are not adjusted.")) + } + adjustment <- switch(adjustment, + "holm" = gettext("Holm"), + "hommel" = gettext("Homel"), + "hochberg" = gettext("Hochberg"), + "mvt" = gettext("Multivariate-t"), + "tukey" = gettext("Tukey"), + "BH" = gettext("Benjamini-Hochberg"), + "BY" = gettext("Benjamini-Yekutieli"), + "scheffe" = gettext("Scheffé"), + "sidak" = gettext("Sidak"), + "dunnettx" = gettext("Dunnett"), + "bonferroni" = gettext("Bonferroni") + ) + return(gettextf("P-values are adjusted using %s adjustment.",adjustment)) +} +.mmMessageDivergentIter <- function(iterations) { + sprintf( + ngettext( + iterations, + "The Hamiltonian Monte Carlo procedure might be invalid -- There was %i divergent transition after warmup. This can be solved by carefully increasing 'Adapt delta' until there are no divergent transitions.", + "The Hamiltonian Monte Carlo procedure might be invalid -- There were %i divergent transitions after warmup. This can be solved by carefully increasing 'Adapt delta' until there are no divergent transitions." + ), + iterations + ) +} +.mmMessageLowBMFI <- function(nChains) { + sprintf( + ngettext( + nChains, + "Bayesian Fraction of Missing Information (BFMI) that was too low in %i chain indicating that the posterior distribution was not explored efficiently. Try increasing number of 'Burnin' and 'Iterations'.", + "Bayesian Fraction of Missing Information (BFMI) that was too low in %i chains indicating that the posterior distribution was not explored efficiently. Try increasing number of 'Burnin' and 'Iterations'." + ), + nChains + ) +} +.mmMessageMaxTreedepth <- function(iterations) { + sprintf( + ngettext( + iterations, + "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transition exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth", + "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transitions exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth" + ), + iterations + ) +} +.mmMessageMaxRhat <- function(Rhat) { + gettextf( + "Inference possibly unreliable -- MCMC chains might not have converged; The largest R-hat is %.3f > 1.01. To lower R-hat please increase 'Iterations', or 'Adapt delta' in the Options section.", + Rhat + ) +} +.mmMessageMinESS <- function(ESS, treshold) { + gettextf( + "Low estimation accuracy -- The smallest Effective Sample Size (ESS) is %.2f < %1.0f. To increase accuracy please increase 'Iterations', or 'Adapt delta' in the Options section.", + ESS, + treshold + ) +} +.mmMessageBadWAIC <- function(n_bad) { + sprintf( + ngettext( + n_bad, + "WAIC estimate unreliable -- There was %1.0f p_waic estimate larger than 0.4. We recommend using LOO instead.", + "WAIC estimate unreliable -- There were %1.0f p_waic estimates larger than 0.4. We recommend using LOO instead." + ), + n_bad + ) +} +.mmMessageBadLOO <- function(n_bad) { + sprintf( + ngettext( + n_bad, + "LOO estimate unreliable -- There was %1.0f observation with the shape parameter (k) of the generalized Pareto distribution higher than > .5.", + "LOO estimate unreliable -- There were %1.0f observations with the shape parameter (k) of the generalized Pareto distribution higher than > .5." + ), + n_bad + ) +} +.mmMessageFitType <- function(REML) { + gettextf("The model was fitted using %1$s.%2$s", + ifelse(REML, gettext("restricted maximum likelihood"), gettext("maximum likelihood")), + ifelse(REML, gettext(" Please note that models with different fixed effects cannot be compared when REML is used. To use ML, switch 'Test model terms' to 'Likelihood ratio tests'."), "")) +} From 0b6609dd7538219371eb8b5cd91ea52de433d26d Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 30 Jun 2021 12:25:15 +0200 Subject: [PATCH 17/38] removing .v() and .unv() --- R/MixedModelsCommon.R | 190 +++++++++++++++++++++--------------------- 1 file changed, 95 insertions(+), 95 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 1f46ed12..d1e5b7cc 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -131,12 +131,12 @@ dataset <- data.frame(dataset) # check and use only the variables that actually used for modeling - used_variables <- .v(c( + used_variables <- c( options$dependentVariable, if(type %in% c("GLMM", "BGLMM")) if(options$dependentVariableAggregation != "") options$dependentVariableAggregation, unique(unlist(options$fixedEffects)), if(length(options$randomVariables) != 0) options$randomVariables - )) + ) dataset <- dataset[,used_variables] # omit NAs/NaN/Infs and store the number of omitted observations @@ -157,7 +157,7 @@ check_variables <- 1:ncol(dataset) if(type %in% c("GLMM", "BGLMM")) if(options$dependentVariableAggregation != "") - check_variables <- check_variables[-which(.v(options$dependentVariableAggregation) == colnames(dataset))] + check_variables <- check_variables[-which(options$dependentVariableAggregation == colnames(dataset))] .hasErrors( @@ -176,14 +176,14 @@ ) for(var in unlist(options$fixedEffects)) { - if(is.factor(dataset[,.v(var)]) || is.character(dataset[,.v(var)])){ - if(length(unique(dataset[,.v(var)])) == nrow(dataset)) + if(is.factor(dataset[,var]) || is.character(dataset[,var])){ + if(length(unique(dataset[,var])) == nrow(dataset)) .quitAnalysis(gettextf("The categorical fixed effect '%s' must have fewer levels than the overall number of observations.",var)) } } for(var in unlist(options$randomVariables)) { - if(length(unique(dataset[,.v(var)])) == nrow(dataset)) + if(length(unique(dataset[,var])) == nrow(dataset)) .quitAnalysis(gettextf("The random effects grouping factor '%s' must have fewer levels than the overall number of observations.",var)) } @@ -200,23 +200,23 @@ family_text <- substr(family_text, 1, nchar(family_text) - 1) if (options$family %in% c("Gamma", "inverse.gaussian")) { - if (any(dataset[, .v(options$dependentVariable)] <= 0)) + if (any(dataset[, options$dependentVariable] <= 0)) .quitAnalysis(gettextf("%s requires that the dependent variable is positive.",family_text)) } else if (options$family %in% c("neg_binomial_2", "poisson")) { - if (any(dataset[, .v(options$dependentVariable)] < 0 | any(!.is.wholenumber(dataset[, .v(options$dependentVariable)])))) + if (any(dataset[, options$dependentVariable] < 0 | any(!.is.wholenumber(dataset[, options$dependentVariable])))) .quitAnalysis(gettextf("%s requires that the dependent variable is an integer.",family_text)) } else if (options$family == "binomial") { - if (any(!dataset[, .v(options$dependentVariable)] %in% c(0, 1))) + if (any(!dataset[, options$dependentVariable] %in% c(0, 1))) .quitAnalysis(gettextf("%s requires that the dependent variable contains only 0 and 1.",family_text)) } else if (options$family == "binomial_agg") { - if (any(dataset[, .v(options$dependentVariable)] < 0 | dataset[, .v(options$dependentVariable)] > 1)) + if (any(dataset[, options$dependentVariable] < 0 | dataset[, options$dependentVariable] > 1)) .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",family_text)) - if (any(dataset[, .v(options$dependentVariableAggregation)] < 0) || any(!.is.wholenumber(dataset[, .v(options$dependentVariableAggregation)]))) + if (any(dataset[, options$dependentVariableAggregation] < 0) || any(!.is.wholenumber(dataset[, options$dependentVariableAggregation]))) .quitAnalysis(gettextf("%s requires that the number of trials variable is an integer.",family_text)) - if (any(!.is.wholenumber(dataset[, .v(options$dependentVariable)] * dataset[, .v(options$dependentVariableAggregation)]))) + if (any(!.is.wholenumber(dataset[, options$dependentVariable] * dataset[, options$dependentVariableAggregation]))) .quitAnalysis(gettextf("%s requires that the dependent variable is proportion of successes out of the number of trials.",family_text)) } else if (options$family == "betar") { - if (any(dataset[, .v(options$dependentVariable)] <= 0 | dataset[, .v(options$dependentVariable)] >= 1)) + if (any(dataset[, options$dependentVariable] <= 0 | dataset[, options$dependentVariable] >= 1)) .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",family_text)) } } @@ -251,7 +251,7 @@ # fixed effects feTerms <- sapply(options[["fixedEffects"]], function(x) - paste(.v(unlist(x)), collapse = "*")) + paste(unlist(x), collapse = "*")) # simplify the terms feTerms <- .mmSimplifyTerms(feTerms) # create the FE formula @@ -269,7 +269,7 @@ # unlist selected random effects tempVars <- sapply(tempRe$randomComponents, function(x) { if (x$randomSlopes) { - return(.v(unlist(x$value))) + return(unlist(x$value)) } else{ return(NA) } @@ -278,7 +278,7 @@ if (x$randomSlopes) { return(NA) } else{ - return(.v(unlist(x$value))) + return(unlist(x$value)) } }) tempVars <- tempVars[!is.na(tempVars)] @@ -295,7 +295,7 @@ # - and associated interactions meToRemove <- NULL for (me in tempVars[!grepl("\\*", tempVars)]) { - tempTable <- table(dataset[, c(.v(tempRe$value), me)]) + tempTable <- table(dataset[, c(tempRe$value, me)]) if (all(apply(tempTable, 1, function(x) sum(x > 0)) <= 1)) { meToRemove <- c(meToRemove, me) @@ -313,10 +313,10 @@ for (te in tempVars) { tempTerms <- unlist(strsplit(te, "\\*")) if (any(sapply(tempTerms, function(x) - typeof(dataset[, .v(x)]) == "double"))) + typeof(dataset[, x]) == "double"))) next tempTable <- - table(dataset[, c(.v(tempRe$value), tempTerms)]) + table(dataset[, c(tempRe$value, tempTerms)]) if (all(tempTable <= 1)) { teToRemove <- c(teToRemove, te) } @@ -339,19 +339,19 @@ ifelse(reTerms == "", 1, reTerms), ifelse(tempRe$correlation || reTerms == "", "|", "||"), - .v(tempRe$value), + tempRe$value, ")" ) randomEffects <- c(randomEffects, newRe) - removedMe[[tempRe$value]] <- .unv(meToRemove) - removedTe[[tempRe$value]] <- .unv(teToRemove) + removedMe[[tempRe$value]] <- meToRemove + removedTe[[tempRe$value]] <- teToRemove addedRe[[tempRe$value]] <- reAdded } randomEffects <- paste0(randomEffects, collapse = "+") modelFormula <- - paste0(.v(options$dependentVariable), + paste0(options$dependentVariable, "~", fixedEffects, "+", @@ -400,7 +400,7 @@ for (i in 1:length(removed)) { if (any(sapply(splitTerms, function(x) all(splitRemoved[[i]] %in% x)))) { - added <- c(added, paste0(.unv(splitRemoved[[i]]), collapse = "*")) + added <- c(added, paste0(splitRemoved[[i]], collapse = "*")) } } } @@ -454,7 +454,7 @@ # I wish there was a better way to do this if (options$family == "binomial_agg") { - glmmWeight <<- dataset[, .v(options$dependentVariableAggregation)] + glmmWeight <<- dataset[, options$dependentVariableAggregation] model <- tryCatch( afex::mixed( formula = as.formula(modelFormula$modelFormula), @@ -571,7 +571,7 @@ else - ANOVAsummary$setError(.unv(model$message)) + ANOVAsummary$setError(model$message) return() @@ -740,7 +740,7 @@ observations = nrow(full_model@frame) ) for (thisName in names(full_model@flist)) { - fitSizes$addColumnInfo(name = thisName, title = .unv(thisName), type = "integer", overtitle = gettext("Levels of RE grouping factors")) + fitSizes$addColumnInfo(name = thisName, title = thisName, type = "integer", overtitle = gettext("Levels of RE grouping factors")) tempRow[[thisName]] <- length(levels(full_model@flist[[thisName]])) } fitSizes$addRows(tempRow) @@ -782,7 +782,7 @@ tempVarCorr <- VarCorr[[gi]] # add variance summary - REvar <- createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) + REvar <- createJaspTable(title = gettextf("%s: Variance Estimates",names(VarCorr)[gi])) REvar$addColumnInfo(name = "variable", title = gettext("Term"), @@ -820,7 +820,7 @@ if (length(tempStdDev) > 1) { tempCorr <- attr(tempVarCorr, "correlation") REcor <- - createJaspTable(title = gettextf("%s: Correlation Estimates",.unv(names(VarCorr)[gi]))) + createJaspTable(title = gettextf("%s: Correlation Estimates",names(VarCorr)[gi])) # add columns REcor$addColumnInfo(name = "variable", @@ -987,14 +987,14 @@ # automatic size specification will somewhat work unless there is more than 2 variables in panel height <- 350 - width <- 150 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, .v(x)])) / 2)) + width <- 150 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, x])) / 2)) if (length(options$plotsPanel) > 0) { width <- - width * length(unique(dataset[, .v(unlist(options$plotsPanel)[1])])) + width * length(unique(dataset[, unlist(options$plotsPanel)[1]])) } else if (length(options$plotsPanel) > 1) { height <- - height * length(unique(dataset[, .v(unlist(options$plotsPanel)[2])])) + height * length(unique(dataset[, unlist(options$plotsPanel)[2]])) } if (options$plotLegendPosition %in% c("bottom", "top")) { height <- height + 50 @@ -1126,11 +1126,11 @@ p <- tryCatch( afex::afex_plot( model, - dv = .v(options$dependentVariable), - x = .v(unlist(options$plotsX)), - trace = if (length(options$plotsTrace) != 0) .v(unlist(options$plotsTrace)), - panel = if (length(options$plotsPanel) != 0) .v(unlist(options$plotsPanel)), - id = .v(options$plotsAgregatedOver), + dv = options$dependentVariable, + x = unlist(options$plotsX), + trace = if (length(options$plotsTrace) != 0) unlist(options$plotsTrace), + panel = if (length(options$plotsPanel) != 0) unlist(options$plotsPanel), + id = options$plotsAgregatedOver, data_geom = getFromNamespace(options$plotsGeom, geom_package), mapping = mapping, error = options$plotsCImethod, @@ -1143,7 +1143,7 @@ ), point_arg = list(size = 1.5 * options$plotRelativeSize), line_arg = list(size = .5 * options$plotRelativeSize), - legend_title = paste(.unv(unlist(options$plotsTrace)), collapse = "\n"), + legend_title = paste(unlist(options$plotsTrace), collapse = "\n"), dodge = options$plotDodge ), error = function(e) @@ -1155,7 +1155,7 @@ return() } - if (options$plotsGeom == "geom_violin" && (length(options$plotsAgregatedOver) == 1 && length(unique(dataset[, .v(options$plotsAgregatedOver)])) < 3)) { + if (options$plotsGeom == "geom_violin" && (length(options$plotsAgregatedOver) == 1 && length(unique(dataset[, options$plotsAgregatedOver])) < 3)) { plots$setError(gettext("Violin geom requires that the random effects grouping factors has at least 3 levels.")) return() } @@ -1205,13 +1205,13 @@ if (options$plotsEstimatesTable) { plotData <- afex::afex_plot( model, - x = .v(unlist(options$plotsX)), - dv = .v(options$dependentVariable), + x = unlist(options$plotsX), + dv = options$dependentVariable, trace = if (length(options$plotsTrace) != 0) - .v(unlist(options$plotsTrace)), + unlist(options$plotsTrace), panel = if (length(options$plotsPanel) != 0) - .v(unlist(options$plotsPanel)), - id = .v(options$plotsAgregatedOver), + unlist(options$plotsPanel), + id = options$plotsAgregatedOver, data_geom = getFromNamespace(options$plotsGeom, geom_package), error = options$plotsCImethod, error_level = options$plotsCIwidth, @@ -1240,7 +1240,7 @@ for (v in attr(plotData, "pri.vars")) { EstimatesTable$addColumnInfo(name = v, - title = .unv(v), + title = v, type = "string") } @@ -1297,11 +1297,11 @@ # deal with continuous predictors at <- NULL for (var in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(var)]) == "double") { - at[[.v(var)]] <- + if (typeof(dataset[, var]) == "double") { + at[[var]] <- c( - mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$marginalMeansSD * - sd(dataset[, .v(var)], na.rm = TRUE) + mean(dataset[, var], na.rm = TRUE) + c(-1, 0, 1) * options$marginalMeansSD * + sd(dataset[, var], na.rm = TRUE) ) } } @@ -1315,7 +1315,7 @@ } emm <- emmeans::emmeans( object = model, - specs = .v(unlist(options$marginalMeans)), + specs = unlist(options$marginalMeans), at = at, options = list(level = options$marginalMeansCIwidth), lmer.df = if (type == "LMM") @@ -1385,13 +1385,13 @@ type = "integer") } for (v in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(v)]) == "double") { - EMMsummary$addColumnInfo(name = .v(v), - title = .unv(v), + if (typeof(dataset[, v]) == "double") { + EMMsummary$addColumnInfo(name = v, + title = v, type = "number") } else{ - EMMsummary$addColumnInfo(name = .v(v), - title = .unv(v), + EMMsummary$addColumnInfo(name = v, + title = v, type = "string") } } @@ -1469,10 +1469,10 @@ } for (v in unlist(options$marginalMeans)) { - if (typeof(dataset[, .v(v)]) == "double") { - tempRow[.v(v)] <- emmTable[i, .v(v)] + if (typeof(dataset[, v]) == "double") { + tempRow[v] <- emmTable[i, v] } else{ - tempRow[.v(v)] <- as.character(emmTable[i, .v(v)]) + tempRow[v] <- as.character(emmTable[i, v]) } } @@ -1506,7 +1506,7 @@ if (length(emm@misc$avgd.over) != 0) { - EMMsummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) + EMMsummary$addFootnote(.mmMessageAveragedOver(emm@misc$avgd.over)) } # add warning message if (type == "LMM") { @@ -1543,11 +1543,11 @@ # deal with continuous predictors at <- NULL for (var in unlist(options$trendsVariables)) { - if (typeof(dataset[, .v(var)]) == "double") { - at[[.v(var)]] <- + if (typeof(dataset[, var]) == "double") { + at[[var]] <- c( - mean(dataset[, .v(var)], na.rm = TRUE) + c(-1, 0, 1) * options$trendsSD * - sd(dataset[, .v(var)], na.rm = TRUE) + mean(dataset[, var], na.rm = TRUE) + c(-1, 0, 1) * options$trendsSD * + sd(dataset[, var], na.rm = TRUE) ) } } @@ -1582,8 +1582,8 @@ emm <- emmeans::emtrends( object = trendsModel, data = trendsDataset, - specs = .v(unlist(options$trendsVariables)), - var = .v(unlist(options$trendsTrend)), + specs = unlist(options$trendsVariables), + var = unlist(options$trendsTrend), at = trendsAt, options = list(level = trendsCI), lmer.df = if (trendsType == "LMM") @@ -1648,13 +1648,13 @@ trendsVarNames <- colnames(emmTable)[1:(grep(".trend", colnames(emmTable), fixed = TRUE) - 1)] for (v in trendsVarNames) { - if (typeof(dataset[, .v(v)]) == "double") { + if (typeof(dataset[, v]) == "double") { trendsSummary$addColumnInfo(name = v, - title = .unv(v), + title = v, type = "number") } else{ trendsSummary$addColumnInfo(name = v, - title = .unv(v), + title = v, type = "string") } } @@ -1730,7 +1730,7 @@ } for (vi in 1:length(trendsVarNames)) { - if (typeof(dataset[, .v(trendsVarNames[vi])]) == "double") { + if (typeof(dataset[, trendsVarNames[vi]]) == "double") { tempRow[trendsVarNames[vi]] <- emmTable[i, vi] } else{ tempRow[trendsVarNames[vi]] <- @@ -1766,7 +1766,7 @@ if (length(emm@misc$avgd.over) != 0) { - trendsSummary$addFootnote(.mmMessageAveragedOver(.unv(emm@misc$avgd.over))) + trendsSummary$addFootnote(.mmMessageAveragedOver(emm@misc$avgd.over)) } # add warning message if (type == "LMM") { @@ -2159,7 +2159,7 @@ # I wish there was a better way to do this if (options$family == "binomial_agg") { - glmmWeight <<- dataset[, .v(options$dependentVariableAggregation)] + glmmWeight <<- dataset[, options$dependentVariableAggregation] model <- tryCatch(stanova::stanova( formula = as.formula(modelFormula$modelFormula), @@ -2276,7 +2276,7 @@ observations = attr(stanovaSummary, "nobs") ) for (n in names(attr(stanovaSummary, "ngrps"))) { - fitSizes$addColumnInfo(name = n, title = .unv(n), type = "integer", overtitle = gettext("Levels of RE grouping factors")) + fitSizes$addColumnInfo(name = n, title = n, type = "integer", overtitle = gettext("Levels of RE grouping factors")) tempRow[[n]] <- attr(stanovaSummary, "ngrps")[[n]] } fitSizes$addRows(tempRow) @@ -2318,7 +2318,7 @@ # add variance summary REvar <- - createJaspTable(title = gettextf("%s: Variance Estimates",.unv(names(VarCorr)[gi]))) + createJaspTable(title = gettextf("%s: Variance Estimates",names(VarCorr)[gi])) REvar$addColumnInfo(name = "variable", title = gettext("Term"), @@ -2356,7 +2356,7 @@ if (length(tempStdDev) > 1) { tempCorr <- attr(tempVarCorr, "correlation") REcor <- - createJaspTable(title = gettextf("%s: Correlation Estimates",.unv(names(VarCorr)[gi]))) + createJaspTable(title = gettextf("%s: Correlation Estimates",names(VarCorr)[gi])) # add columns REcor$addColumnInfo(name = "variable", @@ -2617,19 +2617,19 @@ if (varName != "Intercept" && nrow(tempSummary) > 1) { varName <- - paste(.unv(unlist(strsplit( + paste(unlist(strsplit( as.character(tempSummary$Variable[j]), "," - ))), collapse = jaspBase::interactionSymbol) + )), collapse = jaspBase::interactionSymbol) varName <- gsub(" ", "", varName, fixed = TRUE) if (grepl(jaspBase::interactionSymbol, names(modelSummary)[i], fixed = T)) { - for (n in unlist(strsplit(.unv(names( + for (n in unlist(strsplit(names( modelSummary - )[i]), jaspBase::interactionSymbol))) { + )[i], jaspBase::interactionSymbol))) { varName <- gsub(n, "", varName, fixed = TRUE) } } else{ varName <- - gsub(.unv(names(modelSummary)[i]), "", varName, fixed = TRUE) + gsub(names(modelSummary)[i], "", varName, fixed = TRUE) } tempRow$level <- varName } @@ -2729,14 +2729,14 @@ if (options$samplingPlot != "stan_scat") { pars <- - paste0(.v(unlist(options$samplingVariable1)), collapse = ":") + paste0(unlist(options$samplingVariable1), collapse = ":") } else{ - pars <- c(paste0(.v(unlist( + pars <- c(paste0(unlist( options$samplingVariable1 - )), collapse = ":"), - paste0(.v(unlist( + ), collapse = ":"), + paste0(unlist( options$samplingVariable2 - )), collapse = ":")) + ), collapse = ":")) } plotData <- @@ -2752,9 +2752,9 @@ varName <- strsplit(as.character(pars), ":") varName <- sapply(varName, function(x) - paste(.unv(unlist( + paste(unlist( strsplit(x, ",") - )), collapse = ":")) + ), collapse = ":")) varName <- sapply(varName, function(x) gsub(" ", "", x, fixed = TRUE)) @@ -2836,8 +2836,8 @@ coefs_trend <- strsplit(coefs_trend, ",") for(cft in coefs_trend){ - if(cft %in% strsplit(par, ":")[[1]] && !grepl(.unv(cft), coefs_name)){ - coefs_name <- paste0(coefs_name, jaspBase::interactionSymbol, .unv(cft)) + if(cft %in% strsplit(par, ":")[[1]] && !grepl(cft, coefs_name)){ + coefs_name <- paste0(coefs_name, jaspBase::interactionSymbol, cft) } } @@ -2859,9 +2859,9 @@ for (cf in 1:coefs) { coefs_name <- - paste(.unv(unlist( + paste(unlist( strsplit(dimnames(samples)$Parameter[cf], ",") - )), collapse = ":") + ), collapse = ":") coefs_name <- gsub(" ", "", coefs_name, fixed = TRUE) coefs_name <- .mmVariableNames(coefs_name, options$fixedVariables) coefs_name <- .mmAddCoefNameStanova(samples, pars, coefs_name) @@ -2895,17 +2895,17 @@ for (cf2 in 1:coefs2) { coefs1Name <- - paste(.unv(unlist( + paste(unlist( strsplit(dimnames(samples1)$Parameter[cf1], ",") - )), collapse = ":") + ), collapse = ":") coefs1Name <- gsub(" ", "", coefs1Name, fixed = TRUE) coefs1Name <- .mmVariableNames(coefs1Name, options$fixedVariables) coefs1Name <- .mmAddCoefNameStanova(samples1, pars[[1]], coefs1Name) coefs2Name <- - paste(.unv(unlist( + paste(unlist( strsplit(dimnames(samples2)$Parameter[cf2], ",") - )), collapse = ":") + ), collapse = ":") coefs2Name <- gsub(" ", "", coefs2Name, fixed = TRUE) coefs2Name <- .mmVariableNames(coefs2Name, options$fixedVariables) coefs2Name <- .mmAddCoefNameStanova(samples2, pars[[2]], coefs2Name) @@ -3058,7 +3058,7 @@ nearOne <- 1 - abs(cor_mat) < sqrt(.Machine$double.eps) if(any(nearOne)){ var_ind <- which(nearOne, arr.ind = TRUE) - varNames <- paste("'", .unv(rownames(cor_mat)[var_ind[,"row"]]),"' and '", .unv(colnames(cor_mat)[var_ind[,"col"]]),"'", sep = "", collapse = ", ") + varNames <- paste("'", rownames(cor_mat)[var_ind[,"row"]],"' and '", colnames(cor_mat)[var_ind[,"col"]],"'", sep = "", collapse = ", ") return(gettextf("The following variables are a linear combination of each other, please, remove one of them from the analysis: %s", varNames)) } } From aa9ba6735f7a6f6f4297e26cbd8297b78b0ef4e4 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 30 Jun 2021 15:16:04 +0200 Subject: [PATCH 18/38] simplifying for translation --- R/MixedModelsMessages.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/MixedModelsMessages.R b/R/MixedModelsMessages.R index 3afa67bc..4ef8455b 100644 --- a/R/MixedModelsMessages.R +++ b/R/MixedModelsMessages.R @@ -203,7 +203,9 @@ ) } .mmMessageFitType <- function(REML) { - gettextf("The model was fitted using %1$s.%2$s", - ifelse(REML, gettext("restricted maximum likelihood"), gettext("maximum likelihood")), - ifelse(REML, gettext(" Please note that models with different fixed effects cannot be compared when REML is used. To use ML, switch 'Test model terms' to 'Likelihood ratio tests'."), "")) + if (REML) { + return(gettext("The model was fitted using restricted maximum likelihood. Please note that models with different fixed effects cannot be compared when REML is used. To use ML, switch 'Test model terms' to 'Likelihood ratio tests'.")) + } else { + return(gettext("The model was fitted using maximum likelihood.")) + } } From 23c623ecc67df1cc349cbbbaf37b34be8677ae06 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 30 Jun 2021 15:09:13 +0200 Subject: [PATCH 19/38] additional style changes --- R/MixedModelsCommon.R | 2248 +++++++---------- R/MixedModelsMessages.R | 2 +- dataset.RDS | Bin 0 -> 2452 bytes inst/qml/MixedModelsBGLMM.qml | 2 +- inst/qml/MixedModelsGLMM.qml | 6 +- inst/qml/common/MixedModelsOptions.qml | 2 +- options.RDS | Bin 0 -> 913 bytes .../_snaps/mixedmodelsglmm/plot-glmm-1.svg | 4 +- .../_snaps/mixedmodelslmm/plot-lmm-1.svg | 4 +- tests/testthat/test-mixedmodelsglmm.R | 105 +- tests/testthat/test-mixedmodelslmm.R | 784 +++--- 11 files changed, 1410 insertions(+), 1747 deletions(-) create mode 100644 dataset.RDS create mode 100644 options.RDS diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index d1e5b7cc..e4fa0a53 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -19,50 +19,50 @@ # TODO: Expose priors specification to users in Bxxx? # TODO: Add 3rd level random effects grouping factors ;) (not that difficult actually) -.mmRunAnalysis <- function(jaspResults, dataset, options, type){ +.mmRunAnalysis <- function(jaspResults, dataset, options, type) { if (.mmReady(options, type)) dataset <- .mmReadData(jaspResults, dataset, options, type) + if (.mmReady(options, type)) .mmCheckData(dataset, options, type) # fit the model - if (.mmReady(options, type)){ - if(type %in% c("LMM", "GLMM")).mmFitModel(jaspResults, dataset, options, type) - if(type %in% c("BLMM", "BGLMM")).mmFitModelB(jaspResults, dataset, options, type) + if (.mmReady(options, type)) { + if (type %in% c("LMM", "GLMM")).mmFitModel(jaspResults, dataset, options, type) + if (type %in% c("BLMM", "BGLMM")).mmFitModelB(jaspResults, dataset, options, type) } # create (default) summary tables - if(type %in% c("LMM", "GLMM")).mmSummaryAnova(jaspResults, dataset, options, type) - if(type %in% c("BLMM", "BGLMM")).mmSummaryStanova(jaspResults, dataset, options, type) + if (type %in% c("LMM", "GLMM")).mmSummaryAnova(jaspResults, dataset, options, type) + if (type %in% c("BLMM", "BGLMM")).mmSummaryStanova(jaspResults, dataset, options, type) - if (!is.null(jaspResults[["mmModel"]]) && - !jaspResults[[ifelse(type %in% c("LMM", "GLMM"), "ANOVAsummary", "STANOVAsummary")]]$getError()) { + if (!is.null(jaspResults[["mmModel"]]) && !jaspResults[[ifelse(type %in% c("LMM", "GLMM"), "ANOVAsummary", "STANOVAsummary")]]$getError()) { # show fit statistics if (options$fitStats) { - if(type %in% c("LMM", "GLMM")).mmFitStats(jaspResults, options, type) - if(type %in% c("BLMM", "BGLMM")).mmFitStatsB(jaspResults, options, type) + if (type %in% c("LMM", "GLMM")).mmFitStats(jaspResults, options, type) + if (type %in% c("BLMM", "BGLMM")).mmFitStatsB(jaspResults, options, type) } # show fixed / random effects summary - if (options$showFE){ - if(type %in% c("LMM", "GLMM")).mmSummaryFE(jaspResults, options, type) - if(type %in% c("BLMM", "BGLMM")).mmSummaryFEB(jaspResults, options, type) + if (options$showFE) { + if (type %in% c("LMM", "GLMM")).mmSummaryFE(jaspResults, options, type) + if (type %in% c("BLMM", "BGLMM")).mmSummaryFEB(jaspResults, options, type) } - if (options$showRE){ - if(type %in% c("LMM", "GLMM")).mmSummaryRE(jaspResults, options, type) - if(type %in% c("BLMM", "BGLMM")).mmSummaryREB(jaspResults, options, type) + if (options$showRE) { + if (type %in% c("LMM", "GLMM")).mmSummaryRE(jaspResults, options, type) + if (type %in% c("BLMM", "BGLMM")).mmSummaryREB(jaspResults, options, type) } # sampling diagnostics - if(type %in% c("BLMM", "BGLMM")){ + if (type %in% c("BLMM", "BGLMM")) { if (length(options$samplingVariable1) != 0) .mmDiagnostics(jaspResults, options, dataset, type) } @@ -76,21 +76,18 @@ # marginal means if (length(options$marginalMeans) > 0) .mmMarginalMeans(jaspResults, dataset, options, type) - if (length(options$marginalMeans) > 0 && - options$marginalMeansContrast && - !is.null(jaspResults[["EMMresults"]])) + + if (length(options$marginalMeans) > 0 && options$marginalMeansContrast && !is.null(jaspResults[["EMMresults"]])) .mmContrasts(jaspResults, options, type, what = "Means") # trends - if (length(options$trendsTrend) > 0 && - length(options$trendsVariables) > 0) + if (length(options$trendsTrend) > 0 && length(options$trendsVariables) > 0) .mmTrends(jaspResults, dataset, options, type) - if (options$trendsContrast && - length(options$trendsTrend) > 0 && - length(options$trendsVariables) > 0 && - !is.null(jaspResults[["EMTresults"]])) + + if (options$trendsContrast && length(options$trendsTrend) > 0 && length(options$trendsVariables) > 0 && !is.null(jaspResults[["EMTresults"]])) .mmContrasts(jaspResults, options, type, what = "Trends") + } return() @@ -98,6 +95,7 @@ ### common mixed-models functions .mmReadData <- function(jaspResults, dataset, options, type = "LMM") { + if (is.null(dataset)) { if (type %in% c("LMM","BLMM")) { dataset <- readDataSetToEnd( @@ -108,7 +106,7 @@ ) ) } else if (type %in% c("GLMM","BGLMM")) { - if (options$family == "binomial_agg"){ + if (options$family == "binomialAgg") { dataset <- readDataSetToEnd( columns.as.numeric = c(options$dependentVariable, options$dependentVariableAggregation), columns = c( @@ -131,33 +129,34 @@ dataset <- data.frame(dataset) # check and use only the variables that actually used for modeling - used_variables <- c( + usedVariables <- c( options$dependentVariable, - if(type %in% c("GLMM", "BGLMM")) if(options$dependentVariableAggregation != "") options$dependentVariableAggregation, + if (type %in% c("GLMM", "BGLMM")) if (options$dependentVariableAggregation != "") options$dependentVariableAggregation, unique(unlist(options$fixedEffects)), - if(length(options$randomVariables) != 0) options$randomVariables + if (length(options$randomVariables) != 0) options$randomVariables ) - dataset <- dataset[,used_variables] + dataset <- dataset[, usedVariables] # omit NAs/NaN/Infs and store the number of omitted observations - all_rows <- nrow(dataset) - dataset <- na.omit(dataset) + allRows <- nrow(dataset) + dataset <- na.omit(dataset) # store the number of missing values into a jaspState object - n_missing <- createJaspState() - n_missing$object <- all_rows - nrow(dataset) - jaspResults[["n_missing"]] <- n_missing + nMissing <- createJaspState() + nMissing$object <- allRows - nrow(dataset) + jaspResults[["nMissing"]] <- nMissing return(dataset) } .mmCheckData <- function(dataset, options, type = "LMM") { - if(nrow(dataset) < length(options$fixedEffects)).quitAnalysis("The dataset contains fewer observations than predictors (after excluding NAs/NaN/Inf).") + if (nrow(dataset) < length(options$fixedEffects)) + .quitAnalysis("The dataset contains fewer observations than predictors (after excluding NAs/NaN/Inf).") - check_variables <- 1:ncol(dataset) - if(type %in% c("GLMM", "BGLMM")) - if(options$dependentVariableAggregation != "") - check_variables <- check_variables[-which(options$dependentVariableAggregation == colnames(dataset))] + checkVariables <- 1:ncol(dataset) + if (type %in% c("GLMM", "BGLMM")) + if (options$dependentVariableAggregation != "") + checkVariables <- checkVariables[-which(options$dependentVariableAggregation == colnames(dataset))] .hasErrors( @@ -168,7 +167,7 @@ # the aggregation variable for binomial can have zero variance and can be without factor levels .hasErrors( - dataset[,check_variables], + dataset[, checkVariables], type = c('variance', 'factorLevels'), factorLevels.amount = "< 2", exitAnalysisIfErrors = TRUE, @@ -176,82 +175,104 @@ ) for(var in unlist(options$fixedEffects)) { - if(is.factor(dataset[,var]) || is.character(dataset[,var])){ - if(length(unique(dataset[,var])) == nrow(dataset)) - .quitAnalysis(gettextf("The categorical fixed effect '%s' must have fewer levels than the overall number of observations.",var)) - } + + if ((is.factor(dataset[, var]) || is.character(dataset[, var])) && length(unique(dataset[, var])) == nrow(dataset)) + .quitAnalysis(gettextf("The categorical fixed effect '%s' must have fewer levels than the overall number of observations.", var)) + } for(var in unlist(options$randomVariables)) { - if(length(unique(dataset[,var])) == nrow(dataset)) - .quitAnalysis(gettextf("The random effects grouping factor '%s' must have fewer levels than the overall number of observations.",var)) + + if (length(unique(dataset[, var])) == nrow(dataset)) + .quitAnalysis(gettextf("The random effects grouping factor '%s' must have fewer levels than the overall number of observations.", var)) + } # check hack-able options if (type %in% c("BLMM", "BGLMM")) { - if (options$iteration - 1 <= options$warmup) { + + if (options$iteration - 1 <= options$warmup) .quitAnalysis(gettext("The number of iterations must be at least 2 iterations higher than the burnin")) - } + } # check families if (type %in% c("GLMM","BGLMM")) { - family_text <- .mmMessageGLMMtype(options$family, options$link) - family_text <- substr(family_text, 1, nchar(family_text) - 1) + + familyText <- .mmMessageGLMMtype(options$family, options$link) + familyText <- substr(familyText, 1, nchar(familyText) - 1) if (options$family %in% c("Gamma", "inverse.gaussian")) { + if (any(dataset[, options$dependentVariable] <= 0)) - .quitAnalysis(gettextf("%s requires that the dependent variable is positive.",family_text)) + .quitAnalysis(gettextf("%s requires that the dependent variable is positive.",familyText)) + } else if (options$family %in% c("neg_binomial_2", "poisson")) { + if (any(dataset[, options$dependentVariable] < 0 | any(!.is.wholenumber(dataset[, options$dependentVariable])))) - .quitAnalysis(gettextf("%s requires that the dependent variable is an integer.",family_text)) + .quitAnalysis(gettextf("%s requires that the dependent variable is an integer.",familyText)) + } else if (options$family == "binomial") { + if (any(!dataset[, options$dependentVariable] %in% c(0, 1))) - .quitAnalysis(gettextf("%s requires that the dependent variable contains only 0 and 1.",family_text)) - } else if (options$family == "binomial_agg") { + .quitAnalysis(gettextf("%s requires that the dependent variable contains only 0 and 1.",familyText)) + + } else if (options$family == "binomialAgg") { + if (any(dataset[, options$dependentVariable] < 0 | dataset[, options$dependentVariable] > 1)) - .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",family_text)) + .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",familyText)) + if (any(dataset[, options$dependentVariableAggregation] < 0) || any(!.is.wholenumber(dataset[, options$dependentVariableAggregation]))) - .quitAnalysis(gettextf("%s requires that the number of trials variable is an integer.",family_text)) + .quitAnalysis(gettextf("%s requires that the number of trials variable is an integer.",familyText)) + if (any(!.is.wholenumber(dataset[, options$dependentVariable] * dataset[, options$dependentVariableAggregation]))) - .quitAnalysis(gettextf("%s requires that the dependent variable is proportion of successes out of the number of trials.",family_text)) + .quitAnalysis(gettextf("%s requires that the dependent variable is proportion of successes out of the number of trials.",familyText)) + } else if (options$family == "betar") { + if (any(dataset[, options$dependentVariable] <= 0 | dataset[, options$dependentVariable] >= 1)) - .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",family_text)) + .quitAnalysis(gettextf("%s requires that the dependent variable is higher than 0 and lower than 1.",familyText)) + } } + + return() } .mmReady <- function(options, type = "LMM") { + if (type %in% c("LMM","BLMM")) { + if (options$dependentVariable == "" || length(options$randomVariables) == 0 || - length(options$fixedEffects) == 0) { + length(options$fixedEffects) == 0) return(FALSE) - } + + } else if (type %in% c("GLMM","BGLMM")) { - if (options$family == "binomial_agg"){ + + if (options$family == "binomialAgg") { if (options$dependentVariable == "" || options$dependentVariableAggregation == "" || length(options$randomVariables) == 0 || - length(options$fixedEffects) == 0) { + length(options$fixedEffects) == 0) return(FALSE) - } - }else{ + + }else { + if (options$dependentVariable == "" || length(options$randomVariables) == 0 || - length(options$fixedEffects) == 0) { + length(options$fixedEffects) == 0) return(FALSE) - } - } + } } + return(TRUE) } .mmModelFormula <- function(options, dataset) { + # fixed effects - feTerms <- - sapply(options[["fixedEffects"]], function(x) - paste(unlist(x), collapse = "*")) + feTerms <- sapply(options[["fixedEffects"]], function(x) paste(unlist(x), collapse = "*")) # simplify the terms feTerms <- .mmSimplifyTerms(feTerms) # create the FE formula @@ -265,67 +286,65 @@ removedMe <- list() removedTe <- list() addedRe <- list() + for (tempRe in options[["randomEffects"]]) { # unlist selected random effects tempVars <- sapply(tempRe$randomComponents, function(x) { - if (x$randomSlopes) { + if (x$randomSlopes) return(unlist(x$value)) - } else{ + else return(NA) - } }) tempVarsRem <- sapply(tempRe$randomComponents, function(x) { - if (x$randomSlopes) { + if (x$randomSlopes) return(NA) - } else{ + else return(unlist(x$value)) - } }) tempVars <- tempVars[!is.na(tempVars)] - tempVars <- - sapply(tempVars, function(x) - paste(unlist(x), collapse = "*")) - tempVarsRem <- tempVarsRem[!is.na(tempVarsRem)] - tempVarsRem <- - sapply(tempVarsRem, function(x) - paste(unlist(x), collapse = "*")) + tempVars <- sapply(tempVars, function(x) paste(unlist(x), collapse = "*")) + tempVarsRem <- tempVarsRem[!is.na(tempVarsRem)] + tempVarsRem <- sapply(tempVarsRem, function(x) paste(unlist(x), collapse = "*")) + ### test sensibility of random slopes # main effect check #1 # - remove main effects that have only one level of selected variable for the random effect grouping factor (eg only between subject variables) # - and associated interactions meToRemove <- NULL for (me in tempVars[!grepl("\\*", tempVars)]) { + tempTable <- table(dataset[, c(tempRe$value, me)]) - if (all(apply(tempTable, 1, function(x) - sum(x > 0)) <= 1)) { + + if (all(apply(tempTable, 1, function(x) sum(x > 0)) <= 1)) meToRemove <- c(meToRemove, me) - } - } - if (!is.null(meToRemove)) { - tempVars <- - tempVars[!tempVars %in% unique(as.vector(sapply(meToRemove, function(x) - tempVars[grepl(x, tempVars, fixed = TRUE)])))] + } + + if (!is.null(meToRemove)) + tempVars <- tempVars[!tempVars %in% unique(as.vector(sapply(meToRemove, function(x) + tempVars[grepl(x, tempVars, fixed = TRUE)])))] + tempVars <- na.omit(tempVars) + # terms check #2 # - remove terms that have at maximum one measure across the level of variables (targeted at interactions of between subject variables) teToRemove <- NULL for (te in tempVars) { + tempTerms <- unlist(strsplit(te, "\\*")) - if (any(sapply(tempTerms, function(x) - typeof(dataset[, x]) == "double"))) + + if (any(sapply(tempTerms, function(x) typeof(dataset[, x]) == "double"))) next - tempTable <- - table(dataset[, c(tempRe$value, tempTerms)]) - if (all(tempTable <= 1)) { + + tempTable <- table(dataset[, c(tempRe$value, tempTerms)]) + + if (all(tempTable <= 1)) teToRemove <- c(teToRemove, te) - } + } if (!is.null(teToRemove)) { - teToRemove <- - unique(as.vector(sapply(teToRemove, function(x) - tempVars[grepl(x, tempVars, fixed = TRUE)]))) - tempVars <- tempVars[!tempVars %in% teToRemove] + teToRemove <- unique(as.vector(sapply(teToRemove, function(x) tempVars[grepl(x, tempVars, fixed = TRUE)]))) + tempVars <- tempVars[!tempVars %in% teToRemove] } # simplify the formula @@ -337,8 +356,7 @@ paste0( "(", ifelse(reTerms == "", 1, reTerms), - ifelse(tempRe$correlation || - reTerms == "", "|", "||"), + ifelse(tempRe$correlation || reTerms == "", "|", "||"), tempRe$value, ")" ) @@ -367,46 +385,46 @@ ) } .mmSimplifyTerms <- function(terms) { + if (length(terms) > 1) { - splitTerms <- sapply(terms, strsplit, "\\*") - splitTerms <- - sapply(splitTerms, function(x) - trimws(x, which = c("both"))) + splitTerms <- sapply(terms, strsplit, "\\*") + splitTerms <- sapply(splitTerms, function(x) trimws(x, which = c("both"))) termsToRemove <- rep(NA, length(splitTerms)) + for (i in 1:length(terms)) { - termsToRemove[i] <- - any(sapply(splitTerms[-i], function(x) - all(splitTerms[[i]] %in% x))) + termsToRemove[i] <- any(sapply(splitTerms[-i], function(x) all(splitTerms[[i]] %in% x))) } + terms <- terms[!termsToRemove] } + return(terms) } .mmAddedRETerms <- function(terms, removed) { + added <- NULL if (length(terms) > 1 && length(removed) >= 1) { splitTerms <- sapply(terms, strsplit, "\\*") - splitTerms <- - sapply(splitTerms, function(x) - trimws(x, which = c("both"))) + splitTerms <- sapply(splitTerms, function(x) trimws(x, which = c("both"))) splitRemoved <- sapply(removed, strsplit, "\\*") - splitRemoved <- - sapply(splitRemoved, function(x) - trimws(x, which = c("both"))) + splitRemoved <- sapply(splitRemoved, function(x) trimws(x, which = c("both"))) termsToRemove <- rep(NA, length(splitTerms)) + for (i in 1:length(removed)) { - if (any(sapply(splitTerms, function(x) - all(splitRemoved[[i]] %in% x)))) { + + if (any(sapply(splitTerms, function(x) all(splitRemoved[[i]] %in% x)))) added <- c(added, paste0(splitRemoved[[i]], collapse = "*")) - } + } } + return(added) } .mmFitModel <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["mmModel"]])) return() @@ -417,14 +435,12 @@ if (options$method == "PB") { seedDependencies <- c("seed", "setSeed") .setSeedJASP(options) - } else{ + } else { seedDependencies <- NULL } - if (type == "LMM") { - dependencies <- c(.mmDependenciesLMM, seedDependencies) - } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM, seedDependencies) - } + + dependencies <- c(.mmSwichDependencies(type), seedDependencies) + mmModel$dependOn(dependencies) @@ -437,15 +453,11 @@ data = dataset, type = options$type, method = options$method, - test_intercept = if (options$method %in% c("LRT", "PB")) - options$test_intercept - else - FALSE, - args_test = list(nsim = options$bootstrap_samples), + test_intercept = if (options$method %in% c("LRT", "PB")) options$test_intercept else FALSE, + args_test = list(nsim = options$bootstrapSamples), check_contrasts = TRUE ), - error = function(e) - return(e) + error = function(e) return(e) ) } else if (type == "GLMM") { # needs to be avaluated in the global environment @@ -453,7 +465,7 @@ glmmLink <<- options$link # I wish there was a better way to do this - if (options$family == "binomial_agg") { + if (options$family == "binomialAgg") { glmmWeight <<- dataset[, options$dependentVariableAggregation] model <- tryCatch( afex::mixed( @@ -461,43 +473,35 @@ data = dataset, type = options$type, method = options$method, - test_intercept = if (options$method %in% c("LRT", "PB")) - options$test_intercept - else - FALSE, - args_test = list(nsim = options$bootstrap_samples), + test_intercept = if (options$method %in% c("LRT", "PB")) options$test_intercept else FALSE, + args_test = list(nsim = options$bootstrapSamples), check_contrasts = TRUE, family = eval(call("binomial", glmmLink)), weights = glmmWeight ), - error = function(e) - return(e) + error = function(e) return(e) ) - } else{ + } else { model <- tryCatch( afex::mixed( formula = as.formula(modelFormula$modelFormula), data = dataset, type = options$type, method = options$method, - test_intercept = if (options$method %in% c("LRT", "PB")) - options$test_intercept - else - FALSE, - args_test = list(nsim = options$bootstrap_samples), + test_intercept = if (options$method %in% c("LRT", "PB")) options$test_intercept else FALSE, + args_test = list(nsim = options$bootstrapSamples), check_contrasts = TRUE, #start = start, family = eval(call(glmmFamily, glmmLink)) ), - error = function(e) - return(e) + error = function(e) return(e) ) } } object <- list( - model = model, + model = model, removedMe = modelFormula$removedMe, removedTe = modelFormula$removedTe, addedRe = modelFormula$addedRe @@ -508,6 +512,7 @@ return() } .mmSummaryAnova <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["ANOVAsummary"]])) return() @@ -515,20 +520,26 @@ ANOVAsummary <- createJaspTable(title = gettext("ANOVA Summary")) #defining columns first to give the user something nice to look at - ANOVAsummary$addColumnInfo(name = "effect", title = gettext("Effect"), type = "string") + ANOVAsummary$addColumnInfo(name = "effect", title = gettext("Effect"), type = "string") + if (options$method %in% c("S", "KR")) { - ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "string") - ANOVAsummary$addColumnInfo(name = "stat", title = gettext("F"), type = "number") - } else if - (options$method %in% c("PB", "LRT")) { - ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "integer") - ANOVAsummary$addColumnInfo(name = "stat", title = gettext("ChiSq"), type = "number") + ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "string") + ANOVAsummary$addColumnInfo(name = "stat", title = gettext("F"), type = "number") + } else if (options$method %in% c("PB", "LRT")) { + ANOVAsummary$addColumnInfo(name = "df", title = gettext("df"), type = "integer") + ANOVAsummary$addColumnInfo(name = "stat", title = gettext("ChiSq"), type = "number") } - ANOVAsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") - if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBoot", title = gettext("p (bootstrap)"), type = "pvalue") + + ANOVAsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") + + if (options$method == "PB") + ANOVAsummary$addColumnInfo(name = "pvalBoot", title = gettext("p (bootstrap)"), type = "pvalue") + if (options$pvalVS) { - ANOVAsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") - if (options$method == "PB") ANOVAsummary$addColumnInfo(name = "pvalBootVS", title = gettext("VS-MPR (bootstrap)"), type = "number") + ANOVAsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") + + if (options$method == "PB") + ANOVAsummary$addColumnInfo(name = "pvalBootVS", title = gettext("VS-MPR (bootstrap)"), type = "number") ANOVAsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = c("pvalVS", "pvalBootVS")) } @@ -536,16 +547,13 @@ jaspResults[["ANOVAsummary"]] <- ANOVAsummary ANOVAsummary$position <- 1 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- .mmDependenciesGLMM - } - if (options$method == "PB") { + dependencies <- .mmSwichDependencies(type) + + if (options$method == "PB") seedDependencies <- c("seed", "setSeed") - } else{ + else seedDependencies <- NULL - } + ANOVAsummary$dependOn(c(dependencies, seedDependencies, "pvalVS")) # some error managment for GLMMS - and oh boy, they can fail really easily @@ -581,30 +589,25 @@ if (is.null(model)) { - if (options$dependentVariable != "" && - length(options$fixedVariables) > 0 && - length(options$randomVariables) == 0) { + + if (options$dependentVariable != "" && length(options$fixedVariables) > 0 && length(options$randomVariables) == 0) ANOVAsummary$addFootnote(.mmMessageMissingRE) - } - if (type == "GLMM") { - if (options$family == "binomial_agg" && - options$dependentVariableAggregation == "") { - ANOVAsummary$addFootnote(.mmMessageMissingAgg) - } - } + + if (type == "GLMM" && options$family == "binomialAgg" && options$dependentVariableAggregation == "") + ANOVAsummary$addFootnote(.mmMessageMissingAgg) + return() } for (i in 1:nrow(model$anova_table)) { - if (rownames(model$anova_table)[i] == "(Intercept)") { + + if (rownames(model$anova_table)[i] == "(Intercept)") effectName <- gettext("Intercept") - } else{ + else effectName <- jaspBase::gsubInteractionSymbol(rownames(model$anova_table)[i]) - } - tempRow <- list(effect = effectName, - df = afex::nice(model)$df[i]) + tempRow <- list(effect = effectName, df = afex::nice(model)$df[i]) if (options$method %in% c("S", "KR")) { tempRow$stat = model$anova_table$`F`[i] @@ -619,10 +622,8 @@ } if (options$pvalVS) { tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - if (options$method == "PB") { - tempRow$pvalBootVS <- - VovkSellkeMPR(tempRow$pvalBoot) - } + if (options$method == "PB") + tempRow$pvalBootVS <- VovkSellkeMPR(tempRow$pvalBoot) } ANOVAsummary$addRows(tempRow) @@ -634,20 +635,22 @@ # add warning messages # deal with type II multiple models stuff if (is.list(model$full_model)) { - if (lme4::isSingular(model$full_model[[length(model$full_model)]])) { + + if (lme4::isSingular(model$full_model[[length(model$full_model)]])) ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) - } else if (!is.null(model$full_model[[length(model$full_model)]]@optinfo$conv$lme4$messages)) { + else if (!is.null(model$full_model[[length(model$full_model)]]@optinfo$conv$lme4$messages)) ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) - } - } else{ - if (lme4::isSingular(model$full_model)) { + + } else { + + if (lme4::isSingular(model$full_model)) ANOVAsummary$addFootnote(.mmMessageSingularFit, symbol = gettext("Warning:")) - } else if (!is.null(model$full_model@optinfo$conv$lme4$messages)) { + else if (!is.null(model$full_model@optinfo$conv$lme4$messages)) ANOVAsummary$addFootnote(.mmMessageNumericalProblems, symbol = gettext("Warning:")) - } + } - if (jaspResults[["n_missing"]]$object != 0) { - ANOVAsummary$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) + if (jaspResults[["nMissing"]]$object != 0) { + ANOVAsummary$addFootnote(.mmMessageMissingRows(jaspResults[["nMissing"]]$object)) } removedMe <- jaspResults[["mmModel"]]$object$removedMe @@ -664,7 +667,6 @@ ANOVAsummary$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) - ANOVAsummary$addFootnote(.mmMessageANOVAtype(ifelse(options$type == 3, gettext("III"), gettext("II")))) if (type == "GLMM") ANOVAsummary$addFootnote(.mmMessageGLMMtype(options$family, options$link)) @@ -675,24 +677,22 @@ return() } .mmFitStats <- function(jaspResults, options, type = "LMM") { + if (!is.null(jaspResults[["fitStats"]])) return() model <- jaspResults[["mmModel"]]$object$model - if (is.list(model$full_model)) { + if (is.list(model$full_model)) full_model <- model$full_model[[length(model$full_model)]] - } else{ + else full_model <- model$full_model - } + fitSummary <- createJaspContainer("Model summary") fitSummary$position <- 2 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- .mmDependenciesGLMM - } + dependencies <- .mmSwichDependencies(type) + if (options$method == "PB") dependencies <- c(dependencies, "seed", "setSeed") @@ -708,6 +708,7 @@ fitStats$addColumnInfo(name = "deviance", title = gettext("Deviance"), type = "number") if (lme4::isREML(full_model)) fitStats$addColumnInfo(name = "devianceREML", title = gettext("Deviance (REML)"), type = "number") + fitStats$addColumnInfo(name = "loglik", title = gettext("log Lik."), type = "number") fitStats$addColumnInfo(name = "df", title = gettext("df"), type = "integer") fitStats$addColumnInfo(name = "aic", title = gettext("AIC"), type = "number") @@ -724,9 +725,10 @@ if (!lme4::isREML(full_model)) tempRow$deviance <- deviance(full_model, REML = FALSE) - if (lme4::isREML(full_model)) + else tempRow$devianceREML <- lme4::REMLcrit(full_model) + fitStats$addRows(tempRow) fitStats$addFootnote(.mmMessageFitType(lme4::isREML(full_model))) @@ -749,6 +751,7 @@ return() } .mmSummaryRE <- function(jaspResults, options, type = "LMM") { + if (!is.null(jaspResults[["REsummary"]])) return() @@ -758,25 +761,21 @@ REsummary$position <- 4 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- .mmDependenciesGLMM - } - if (options$method == "PB") { + dependencies <- .mmSwichDependencies(type) + + if (options$method == "PB") seedDependencies <- c("seed", "setSeed") - } else{ + else seedDependencies <- NULL - } + REsummary$dependOn(c(dependencies, seedDependencies, "showRE")) # deal with SS type II stuff - if (is.list(model$full_model)) { - VarCorr <- - lme4::VarCorr(model$full_model[[length(model$full_model)]]) - } else{ + if (is.list(model$full_model)) + VarCorr <- lme4::VarCorr(model$full_model[[length(model$full_model)]]) + else VarCorr <- lme4::VarCorr(model$full_model) - } + # go over each random effect grouping factor for (gi in 1:length(VarCorr)) { tempVarCorr <- VarCorr[[gi]] @@ -784,23 +783,18 @@ # add variance summary REvar <- createJaspTable(title = gettextf("%s: Variance Estimates",names(VarCorr)[gi])) - REvar$addColumnInfo(name = "variable", - title = gettext("Term"), - type = "string") - REvar$addColumnInfo(name = "std", - title = gettext("Std. Deviation"), - type = "number") - REvar$addColumnInfo(name = "var", - title = gettext("Variance"), - type = "number") + REvar$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") + REvar$addColumnInfo(name = "std", title = gettext("Std. Deviation"), type = "number") + REvar$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") tempStdDev <- attr(tempVarCorr, "stddev") + for (i in 1:length(tempStdDev)) { - if (names(tempStdDev)[i] == "(Intercept)") { + + if (names(tempStdDev)[i] == "(Intercept)") varName <- gettext("Intercept") - } else{ + else varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) - } tempRow <- list( variable = varName, @@ -819,36 +813,34 @@ # add correlation summary if (length(tempStdDev) > 1) { tempCorr <- attr(tempVarCorr, "correlation") - REcor <- - createJaspTable(title = gettextf("%s: Correlation Estimates",names(VarCorr)[gi])) + REcor <- createJaspTable(title = gettextf("%s: Correlation Estimates",names(VarCorr)[gi])) # add columns - REcor$addColumnInfo(name = "variable", - title = gettext("Term"), - type = "string") + REcor$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") { + + if (rownames(tempCorr)[i] == "(Intercept)") varName <- gettext("Intercept") - } else{ + else varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - } - REcor$addColumnInfo(name = paste0("v", i), - title = varName, - type = "number") + + REcor$addColumnInfo(name = paste0("v", i), title = varName, type = "number") } # fill rows for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") { + + if (rownames(tempCorr)[i] == "(Intercept)") varName <- gettext("Intercept") - } else{ + else varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - } + tempRow <- list(variable = varName) for (j in 1:i) { tempRow[paste0("v", j)] <- tempCorr[i, j] } + REcor$addRows(tempRow) } @@ -857,70 +849,65 @@ REsummary[[paste0("CE", gi)]] <- REcor } - } # add residual variance summary - REres <- - createJaspTable(title = gettext("Residual Variance Estimates")) + REres <- createJaspTable(title = gettext("Residual Variance Estimates")) - REres$addColumnInfo(name = "std", - title = gettext("Std. Deviation"), - type = "number") - REres$addColumnInfo(name = "var", - title = gettext("Variance"), - type = "number") + REres$addColumnInfo(name = "std", title = gettext("Std. Deviation"), type = "number") + REres$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") - if (is.list(model$full_model)) { - tempRow <- - list(std = sigma(model$full_model[[length(model$full_model)]]), - var = sqrt(sigma(model$full_model[[length(model$full_model)]]))) - } else{ - tempRow <- list(std = sigma(model$full_model), - var = sigma(model$full_model)^2) - } + if (is.list(model$full_model)) + tempRow <- list( + std = sigma(model$full_model[[length(model$full_model)]]), + var = sqrt(sigma(model$full_model[[length(model$full_model)]])) + ) + else + tempRow <- list( + std = sigma(model$full_model), + var = sigma(model$full_model)^2 + ) REres$addRows(tempRow) REsummary[[paste0("RES", gi)]] <- REres - jaspResults[["REsummary"]] <- REsummary + return() } .mmSummaryFE <- function(jaspResults, options, type = "LMM") { + if (!is.null(jaspResults[["FEsummary"]])) return() model <- jaspResults[["mmModel"]]$object$model - if (is.list(model$full_model)) { - FEcoef <- - summary(model$full_model[[length(model$full_model)]])$coeff - } else{ + if (is.list(model$full_model)) + FEcoef <- summary(model$full_model[[length(model$full_model)]])$coeff + else FEcoef <- summary(model$full_model)$coeff - } FEsummary <- createJaspTable(title = gettext("Fixed Effects Estimates")) FEsummary$position <- 3 - if (type == "LMM") dependencies <- .mmDependenciesLMM - else if (type == "GLMM") dependencies <- .mmDependenciesGLMM + dependencies <- .mmSwichDependencies(type) - if(options$method == "PB"){ + if (options$method == "PB") seedDependencies <- c("seed", "setSeed") - }else{ + else seedDependencies <- NULL - } - FEsummary$dependOn(c(dependencies, seedDependencies, "showFE", "pvalVS")) FEsummary$addColumnInfo(name = "term", title = gettext("Term"), type = "string") FEsummary$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") FEsummary$addColumnInfo(name = "se", title = gettext("SE"), type = "number") - if (type == "LMM") FEsummary$addColumnInfo(name = "df", title = gettext("df"), type = "number") + if (type == "LMM") + FEsummary$addColumnInfo(name = "df", title = gettext("df"), type = "number") + FEsummary$addColumnInfo(name = "stat", title = gettext("t"), type = "number") - if (ncol(FEcoef) >= 4) FEsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") + if (ncol(FEcoef) >= 4) + FEsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") if (options$pvalVS) { FEsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") @@ -930,13 +917,15 @@ jaspResults[["FEsummary"]] <- FEsummary for (i in 1:nrow(FEcoef)) { - if (rownames(FEcoef)[i] == "(Intercept)") { + + if (rownames(FEcoef)[i] == "(Intercept)") effectName <- gettext("Intercept") - } else{ + else effectName <- .mmVariableNames(rownames(FEcoef)[i], options$fixedVariables) - } + if (type == "LMM") { + tempRow <- list( term = effectName, estimate = FEcoef[i, 1], @@ -945,21 +934,23 @@ stat = FEcoef[i, 4], pval = FEcoef[i, 5] ) + } else if (type == "GLMM") { + tempRow <- list( term = effectName, estimate = FEcoef[i, 1], se = FEcoef[i, 2], stat = FEcoef[i, 3] ) - if (ncol(FEcoef) >= 4) { + + if (ncol(FEcoef) >= 4) tempRow$pval <- FEcoef[i, 4] - } + } - if (options$pvalVS) { + if (options$pvalVS) tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } FEsummary$addRows(tempRow) } @@ -967,16 +958,18 @@ # add warning messages FEsummary$addFootnote(.mmMessageInterpretability) - + return() } -.mmFixPlotAxis <- function(p){ +.mmFixPlotAxis <- function(p) { yTicks <- jaspGraphs::getPrettyAxisBreaks(ggplot2::layer_scales(p)$y$range$range) yRange <- range(yTicks) xTicks <- ggplot2::layer_scales(p)$x$range$range - p + ggplot2::scale_y_continuous(breaks = yTicks, limits = yRange) + + p <- p + ggplot2::scale_y_continuous(breaks = yTicks, limits = yRange) + ggplot2::scale_x_discrete(breaks = xTicks) + + return(p) } .mmPlot <- function(jaspResults, dataset, options, type = "LMM") { @@ -989,29 +982,22 @@ height <- 350 width <- 150 * prod(sapply(unlist(options$plotsX), function(x) length(unique(dataset[, x])) / 2)) - if (length(options$plotsPanel) > 0) { - width <- - width * length(unique(dataset[, unlist(options$plotsPanel)[1]])) - } else if (length(options$plotsPanel) > 1) { - height <- - height * length(unique(dataset[, unlist(options$plotsPanel)[2]])) - } - if (options$plotLegendPosition %in% c("bottom", "top")) { + if (length(options$plotsPanel) > 0) + width <- width * length(unique(dataset[, unlist(options$plotsPanel)[1]])) + else if (length(options$plotsPanel) > 1) + height <- height * length(unique(dataset[, unlist(options$plotsPanel)[2]])) + + if (options$plotLegendPosition %in% c("bottom", "top")) height <- height + 50 - } else if (options$plotLegendPosition %in% c("left", "right")) { + else if (options$plotLegendPosition %in% c("left", "right")) width <- width + 100 - } + width <- width + 150 plots <- createJaspPlot(title = gettext("Plot"), width = width, height = height) plots$position <- 5 - switch(type, - LMM = dependencies <- .mmDependenciesLMM, - GLMM = dependencies <- .mmDependenciesGLMM, - BLMM = dependencies <- .mmDependenciesBLMM, - BGLMM = dependencies <- .mmDependenciesBGLMM - ) + dependencies <- .mmSwichDependencies(type) plots$dependOn( c( @@ -1049,47 +1035,31 @@ # stop with message if there is no random effects grouping factor selected if (length(options$plotsAgregatedOver) == 0) { - plots$setError( - gettext("At least one random effects grouping factor needs to be selected in field 'Background data show'.") - ) + plots$setError(gettext("At least one random effects grouping factor needs to be selected in field 'Background data show'.")) return() } - if (all( - !c( - options$plotsMappingColor, - options$plotsMappingShape, - options$plotsMappingLineType, - options$plotsMappingFill - ) - )) { - plots$setError( - gettext("Factor levels need to be distinguished by at least one feature. Please, check one of the 'Distinguish factor levels' options.") - ) + if (all(!c(options$plotsMappingColor, options$plotsMappingShape, options$plotsMappingLineType, options$plotsMappingFill))) { + plots$setError(gettext("Factor levels need to be distinguished by at least one feature. Please, check one of the 'Distinguish factor levels' options.")) return() } # select geom - if (options$plotsGeom %in% c("geom_jitter", "geom_violin", "geom_boxplot", "geom_count")) { - geom_package <- "ggplot2" - } else if (options$plotsGeom == "geom_beeswarm") { - geom_package <- "ggbeeswarm" - } else if (options$plotsGeom == "geom_boxjitter") { - geom_package <- "ggpol" - } + if (options$plotsGeom %in% c("geom_jitter", "geom_violin", "geom_boxplot", "geom_count")) + geomPackage <- "ggplot2" + else if (options$plotsGeom == "geom_beeswarm") + geomPackage <- "ggbeeswarm" + else if (options$plotsGeom == "geom_boxjitter") + geomPackage <- "ggpol" + # select mapping - mapping <- - c("color", "shape", "linetype", "fill")[c( - options$plotsMappingColor, - options$plotsMappingShape, - options$plotsMappingLineType, - options$plotsMappingFill - )] + mapping <- c("color", "shape", "linetype", "fill")[c(options$plotsMappingColor, options$plotsMappingShape, options$plotsMappingLineType, options$plotsMappingFill)] + if (length(mapping) == 0) mapping <- "" # specify data_arg - if (options$plotsGeom == "geom_jitter") { + if (options$plotsGeom == "geom_jitter") data_arg <- list( position = ggplot2::position_jitterdodge( @@ -1098,29 +1068,28 @@ dodge.width = options$plotDodge ) ) - } else if (options$plotsGeom == "geom_violin") { + else if (options$plotsGeom == "geom_violin") data_arg <- list(width = options$plotGeomWidth) - } else if (options$plotsGeom == "geom_boxplot") { + else if (options$plotsGeom == "geom_boxplot") data_arg <- list(width = options$plotGeomWidth) - } else if (options$plotsGeom == "geom_count") { + else if (options$plotsGeom == "geom_count") data_arg <- list() - } else if (options$plotsGeom == "geom_beeswarm") { + else if (options$plotsGeom == "geom_beeswarm") data_arg <- list(dodge.width = options$plotDodge) - } else if (options$plotsGeom == "geom_boxjitter") { + else if (options$plotsGeom == "geom_boxjitter") data_arg <- list( width = options$plotGeomWidth, jitter.width = options$plotJitterWidth, jitter.height = options$plotJitterHeight, outlier.intersect = TRUE ) - } + if (options$plotsBackgroundColor != "none" && options$plotsGeom != "geom_jitter" && "color" %in% mapping) data_arg$color <- options$plotsBackgroundColor # fixing afex issues with bootstrap and LRT type II SS - hopefully removeable in the future - if (type %in% c("LMM", "GLMM")) - if (options$method %in% c("LRT", "PB") && options$type == 2) - model <- model$full_model[[length(model$full_model)]] + if (type %in% c("LMM", "GLMM") && options$method %in% c("LRT", "PB") && options$type == 2) + model <- model$full_model[[length(model$full_model)]] .setSeedJASP(options) p <- tryCatch( @@ -1131,7 +1100,7 @@ trace = if (length(options$plotsTrace) != 0) unlist(options$plotsTrace), panel = if (length(options$plotsPanel) != 0) unlist(options$plotsPanel), id = options$plotsAgregatedOver, - data_geom = getFromNamespace(options$plotsGeom, geom_package), + data_geom = getFromNamespace(options$plotsGeom, geomPackage), mapping = mapping, error = options$plotsCImethod, error_level = options$plotsCIwidth, @@ -1146,11 +1115,10 @@ legend_title = paste(unlist(options$plotsTrace), collapse = "\n"), dodge = options$plotDodge ), - error = function(e) - e + error = function(e) e ) - if (any(class(p) %in% c("simpleError", "error"))) { + if (inherits(p, "error")) { plots$setError(p$message) return() } @@ -1181,11 +1149,11 @@ "theme_pubr" = jaspGraphs::themePubrRaw(legend = options$plotLegendPosition), "theme_apa" = jaspGraphs::themeApaRaw(legend.pos = switch( options$plotLegendPosition, - "none" = "none", - "botom" = "bottommiddle", - "right" = "bottomright", - "top" = "topmiddle", - "left" = "bottomleft" + "none" = "none", + "bottom" = "bottommiddle", + "right" = "bottomright", + "top" = "topmiddle", + "left" = "bottomleft" )) ) @@ -1212,15 +1180,13 @@ panel = if (length(options$plotsPanel) != 0) unlist(options$plotsPanel), id = options$plotsAgregatedOver, - data_geom = getFromNamespace(options$plotsGeom, geom_package), + data_geom = getFromNamespace(options$plotsGeom, geomPackage), error = options$plotsCImethod, error_level = options$plotsCIwidth, return = "data" )$means - - EstimatesTable <- - createJaspTable(title = gettext("Estimated Means and Confidence Intervals")) + EstimatesTable <- createJaspTable(title = gettext("Estimated Means and Confidence Intervals")) EstimatesTable$position <- 5 EstimatesTable$dependOn( c( @@ -1237,41 +1203,24 @@ ) ) - - for (v in attr(plotData, "pri.vars")) { - EstimatesTable$addColumnInfo(name = v, - title = v, - type = "string") + for (variable in attr(plotData, "pri.vars")) { + EstimatesTable$addColumnInfo(name = variable, title = variable, type = "string") } - for (v in options$marginalMeans) { - - } + EstimatesTable$addColumnInfo(name = "mean", title = gettext("Mean"), type = "number") - EstimatesTable$addColumnInfo(name = "mean", - title = gettext("Mean"), - type = "number") if (options$plotsCImethod != "none") { - EstimatesTable$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) - ) - EstimatesTable$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) - ) + EstimatesTable$addColumnInfo(name = "lowerCI", title = gettext("Lower"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) ) + EstimatesTable$addColumnInfo(name = "upperCI", title = gettext("Upper"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$plotsCIwidth) ) } jaspResults[["EstimatesTable"]] <- EstimatesTable for (i in 1:nrow(plotData)) { + tempRow <- list() - for (v in attr(plotData, "pri.vars")) { - tempRow[v] <- as.character(plotData[i, v]) + for (variable in attr(plotData, "pri.vars")) { + tempRow[variable] <- as.character(plotData[i, variable]) } tempRow$mean <- plotData[i, "y"] @@ -1283,12 +1232,12 @@ EstimatesTable$addRows(tempRow) } - } return() } .mmMarginalMeans <- function(jaspResults, dataset, options, type = "LMM") { + if (!is.null(jaspResults[["EMMresults"]])) return() @@ -1298,21 +1247,16 @@ at <- NULL for (var in unlist(options$marginalMeans)) { if (typeof(dataset[, var]) == "double") { - at[[var]] <- - c( - mean(dataset[, var], na.rm = TRUE) + c(-1, 0, 1) * options$marginalMeansSD * - sd(dataset[, var], na.rm = TRUE) - ) + at[[var]] <-c(mean(dataset[, var], na.rm = TRUE) + c(-1, 0, 1) * options$marginalMeansSD * sd(dataset[, var], na.rm = TRUE)) } } # compute the results - if (type == "LMM") { - emmeans::emm_options(pbkrtest.limit = if (options$marginalMeansOverride) - Inf, - mmrTest.limit = if (options$marginalMeansOverride) - Inf) - } + if (type == "LMM") + emmeans::emm_options( + pbkrtest.limit = if (options$marginalMeansOverride) Inf, + mmrTest.limit = if (options$marginalMeansOverride) Inf) + emm <- emmeans::emmeans( object = model, specs = unlist(options$marginalMeans), @@ -1320,143 +1264,90 @@ options = list(level = options$marginalMeansCIwidth), lmer.df = if (type == "LMM") options$marginalMeansDf - else if (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity") + else if (type == "GLMM" && options$family == "gaussian" && options$link == "identity") "asymptotic", - type = if (type %in% c("GLMM", "BGLMM")) - if (options$marginalMeansResponse) - "response" + type = if (type %in% c("GLMM", "BGLMM") && options$marginalMeansResponse) "response" ) emmTable <- as.data.frame(emm) - if (type %in% c("LMM", "GLMM")) { - if (options$marginalMeansCompare) { - emmTest <- - as.data.frame(emmeans::test(emm, null = options$marginalMeansCompareTo)) - } - } + if (type %in% c("LMM", "GLMM") && options$marginalMeansCompare) + emmTest <- as.data.frame(emmeans::test(emm, null = options$marginalMeansCompareTo)) EMMsummary <- createJaspTable(title = gettext("Estimated Marginal Means")) EMMresults <- createJaspState() EMMsummary$position <- 7 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { + + dependencies <- .mmSwichDependencies(type) + if (type %in% c("GLMM", "BGLMM")) dependencies <- c(.mmDependenciesGLMM, "marginalMeansResponse") - } - if (type %in% c("LMM", "GLMM")) { - dependenciesAdd <- - c( - "marginalMeans", - "marginalMeansSD", - "marginalMeansCompare", - "marginalMeansCompareTo", - "marginalMeansCIwidth", - "pvalVS", - "marginalMeansContrast" - ) - } else{ - dependenciesAdd <- - c( - "marginalMeans", - "marginalMeansSD", - "marginalMeansCIwidth", - "marginalMeansContrast" - ) - } - if (type == "LMM") { - dependenciesAdd <- - c(dependenciesAdd, - "marginalMeansOverride", - "marginalMeansDf") - } + + if (type %in% c("LMM", "GLMM")) + dependenciesAdd <- c( + "marginalMeans", + "marginalMeansSD", + "marginalMeansCompare", + "marginalMeansCompareTo", + "marginalMeansCIwidth", + "pvalVS", + "marginalMeansContrast" + ) + else + dependenciesAdd <- c( + "marginalMeans", + "marginalMeansSD", + "marginalMeansCIwidth", + "marginalMeansContrast" + ) + + if (type == "LMM") + dependenciesAdd <- c( + dependenciesAdd, + "marginalMeansOverride", + "marginalMeansDf") + EMMsummary$dependOn(c(dependencies, dependenciesAdd)) EMMresults$dependOn(c(dependencies, dependenciesAdd)) - if (options$marginalMeansContrast) { - EMMsummary$addColumnInfo(name = "number", - title = gettext("Row"), - type = "integer") - } - for (v in unlist(options$marginalMeans)) { - if (typeof(dataset[, v]) == "double") { - EMMsummary$addColumnInfo(name = v, - title = v, - type = "number") - } else{ - EMMsummary$addColumnInfo(name = v, - title = v, - type = "string") - } + if (options$marginalMeansContrast) + EMMsummary$addColumnInfo(name = "number", title = gettext("Row"), type = "integer") + + for (variable in unlist(options$marginalMeans)) { + + if (typeof(dataset[, variable]) == "double") + EMMsummary$addColumnInfo(name = variable, title = variable, type = "number") + else + EMMsummary$addColumnInfo(name = variable, title = variable, type = "string") + } if (type %in% c("LMM", "GLMM")) { - EMMsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMsummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - if(type == "LMM"){ - if(options$marginalMeansDf != "asymptotic"){ - EMMsummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - } - } - EMMsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) - ) - EMMsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth) - ) + + EMMsummary$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") + EMMsummary$addColumnInfo(name = "se", title = gettext("SE"), type = "number") + if (type == "LMM" && options$marginalMeansDf != "asymptotic") + EMMsummary$addColumnInfo(name = "df", title = gettext("df"), type = "number") + + EMMsummary$addColumnInfo(name = "lowerCI", title = gettext("Lower"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth)) + EMMsummary$addColumnInfo(name = "upperCI", title = gettext("Upper"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$marginalMeansCIwidth)) + if (options$marginalMeansCompare) { - EMMsummary$addColumnInfo( - name = "stat", - title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), - type = "number" - ) - EMMsummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") - EMMsummary$addFootnote(.mmMessageTestNull(options$marginalMeansCompareTo), - symbol = "\u2020", colNames = "pval") + EMMsummary$addColumnInfo(name = "stat", title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), type = "number") + EMMsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") + EMMsummary$addFootnote(.mmMessageTestNull(options$marginalMeansCompareTo), symbol = "\u2020", colNames = "pval") if (options$pvalVS) { - EMMsummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") + EMMsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") EMMsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") } } + } else if (type %in% c("BLMM", "BGLMM")) { - EMMsummary$addColumnInfo(name = "estimate", - title = gettext("Median"), - type = "number") - EMMsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) - ) - EMMsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) - ) + + EMMsummary$addColumnInfo(name = "estimate", title = gettext("Median"), type = "number") + EMMsummary$addColumnInfo(name = "lowerCI", title = gettext("Lower"), type = "number", overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth)) + EMMsummary$addColumnInfo(name = "upperCI", title = gettext("Upper"), type = "number", overtitle = gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth)) + } jaspResults[["EMMsummary"]] <- EMMsummary @@ -1464,34 +1355,32 @@ for (i in 1:nrow(emmTable)) { tempRow <- list() - if (options$marginalMeansContrast) { + if (options$marginalMeansContrast) tempRow$number <- i - } - for (v in unlist(options$marginalMeans)) { - if (typeof(dataset[, v]) == "double") { - tempRow[v] <- emmTable[i, v] - } else{ - tempRow[v] <- as.character(emmTable[i, v]) - } + + for (variable in unlist(options$marginalMeans)) { + + if (typeof(dataset[, variable]) == "double") + tempRow[variable] <- emmTable[i, variable] + else + tempRow[variable] <- as.character(emmTable[i, variable]) + } if (type %in% c("LMM", "GLMM")) { # the estimate is before SE (names change for GLMM) - tempRow$estimate <- - emmTable[i, grep("SE", colnames(emmTable)) - 1] + tempRow$estimate <- emmTable[i, grep("SE", colnames(emmTable)) - 1] tempRow$se <- emmTable[i, "SE"] - if(type == "LMM"){ - if(options$marginalMeansDf != "asymptotic"){ - tempRow$df <- emmTable[i, "df"] - } - } + if (type == "LMM" && options$marginalMeansDf != "asymptotic") + tempRow$df <- emmTable[i, "df"] + if (options$marginalMeansCompare) { tempRow$stat <- emmTest[i, grep("ratio", colnames(emmTest))] tempRow$pval <- emmTest[i, "p.value"] - if (options$pvalVS) { + if (options$pvalVS) tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } + } } else if (type %in% c("BLMM", "BGLMM")) { tempRow$estimate <- emmTable[i, ncol(emmTable) - 2] @@ -1505,37 +1394,30 @@ } - if (length(emm@misc$avgd.over) != 0) { + if (length(emm@misc$avgd.over) != 0) EMMsummary$addFootnote(.mmMessageAveragedOver(emm@misc$avgd.over)) - } + # add warning message - if (type == "LMM") { - if (options$marginalMeansDf != attr(emm@dffun, "mesg")) { - EMMsummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) - } - } - if (type %in% c("GLMM","BGLMM")) { - EMMsummary$addFootnote( - ifelse( - options$marginalMeansResponse, - .mmMessageResponse, - .mmMessageNotResponse - ) - ) - } + if (type == "LMM" && options$marginalMeansDf != attr(emm@dffun, "mesg")) + EMMsummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) + if (type %in% c("GLMM","BGLMM")) + EMMsummary$addFootnote(ifelse(options$marginalMeansResponse, .mmMessageResponse, .mmMessageNotResponse)) + object <- list( + emm = emm, + emmTable = emmTable + ) - object <- list(emm = emm, - emmTable = emmTable) EMMresults$object <- object jaspResults[["EMMresults"]] <- EMMresults return() } .mmTrends <- function(jaspResults, dataset, options, type = "LMM") { - if (!is.null(jaspResults[["contrasts_Trends"]])) + + if (!is.null(jaspResults[["contrastsTrends"]])) return() model <- jaspResults[["mmModel"]]$object$model @@ -1543,41 +1425,35 @@ # deal with continuous predictors at <- NULL for (var in unlist(options$trendsVariables)) { - if (typeof(dataset[, var]) == "double") { - at[[var]] <- - c( - mean(dataset[, var], na.rm = TRUE) + c(-1, 0, 1) * options$trendsSD * - sd(dataset[, var], na.rm = TRUE) - ) - } + + if (typeof(dataset[, var]) == "double") + at[[var]] <-mean(dataset[, var], na.rm = TRUE) + c(-1, 0, 1) * options$trendsSD * sd(dataset[, var], na.rm = TRUE) + } # compute the results - if (type %in% c("LMM")) { - emmeans::emm_options(pbkrtest.limit = if (options$trendsOverride) - Inf, - mmrTest.limit = if (options$trendsOverride) - Inf) - } + if (type == "LMM") + emmeans::emm_options( + pbkrtest.limit = if (options$trendsOverride) Inf, + mmrTest.limit = if (options$trendsOverride) Inf) + # TODO: deal with the emtrends scoping problems trendsCI <<- options$trendsCIwidth trendsAt <<- at - trendsType <<- if (type == "LMM" || (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity")) - "LMM" + + if (type == "LMM" || (type == "GLMM" && options$family == "gaussian" && options$link == "identity")) + trendsType <- "LMM" else - type + trendsType <- type + trendsDataset <<- dataset trendsModel <<- model - trendsDf <<- - if (type == "LMM") - options$trendsDf - else if (type == "GLMM" && - options$family == "gaussian" && - options$link == "identity") - "asymptotic" + + if (type == "LMM") + trendsDf <<- options$trendsDf + else if (type == "GLMM" && options$family == "gaussian" && options$link == "identity") + trendsDf <<- "asymptotic" emm <- emmeans::emtrends( object = trendsModel, @@ -1586,137 +1462,81 @@ var = unlist(options$trendsTrend), at = trendsAt, options = list(level = trendsCI), - lmer.df = if (trendsType == "LMM") - trendsDf + lmer.df = if (trendsType == "LMM") trendsDf ) emmTable <- as.data.frame(emm) - if (type %in% c("LMM", "GLMM")) { - if (options$trendsCompare) { - emmTest <- - as.data.frame(emmeans::test(emm, null = options$trendsCompareTo)) - } - } + if (type %in% c("LMM", "GLMM") && options$trendsCompare) + emmTest <- as.data.frame(emmeans::test(emm, null = options$trendsCompareTo)) + trendsSummary <- createJaspTable(title = gettext("Estimated Trends")) - EMTresults <- createJaspState() + EMTresults <- createJaspState() trendsSummary$position <- 9 - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- c(.mmDependenciesGLMM) - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- c(.mmDependenciesBGLMM) - } - if (type %in% c("LMM", "GLMM")) { - dependenciesAdd <- - c( - "trendsVariables", - "trendsTrend", - "trendsSD", - "trendsCompare", - "trendsCompareTo", - "trendsCIwidth", - "pvalVS", - "trendsContrast" - ) - } else{ - dependenciesAdd <- - c( - "trendsVariables", - "trendsTrend", - "trendsSD", - "trendsCIwidth", - "trendsContrast" - ) - } - if (type == "LMM") { - dependenciesAdd <- - c(dependenciesAdd, "trendsDf", "trendsOverride") - } + dependencies <- .mmSwichDependencies(type) + + if (type %in% c("LMM", "GLMM")) + dependenciesAdd <- c( + "trendsVariables", + "trendsTrend", + "trendsSD", + "trendsCompare", + "trendsCompareTo", + "trendsCIwidth", + "pvalVS", + "trendsContrast" + ) + else + dependenciesAdd <- c( + "trendsVariables", + "trendsTrend", + "trendsSD", + "trendsCIwidth", + "trendsContrast" + ) + + if (type == "LMM") + dependenciesAdd <-c(dependenciesAdd, "trendsDf", "trendsOverride") + trendsSummary$dependOn(c(dependencies, dependenciesAdd)) EMTresults$dependOn(c(dependencies, dependenciesAdd)) - if (options$trendsContrast) { - trendsSummary$addColumnInfo(name = "number", - title = gettext("Row"), - type = "integer") - } + if (options$trendsContrast) + trendsSummary$addColumnInfo(name = "number", title = gettext("Row"), type = "integer") trendsVarNames <- colnames(emmTable)[1:(grep(".trend", colnames(emmTable), fixed = TRUE) - 1)] - for (v in trendsVarNames) { - if (typeof(dataset[, v]) == "double") { - trendsSummary$addColumnInfo(name = v, - title = v, - type = "number") - } else{ - trendsSummary$addColumnInfo(name = v, - title = v, - type = "string") - } + for (variable in trendsVarNames) { + + if (typeof(dataset[, variable]) == "double") + trendsSummary$addColumnInfo(name = variable, title = variable, type = "number") + else + trendsSummary$addColumnInfo(name = variable, title = variable, type = "string") + } - trendsSummary$addColumnInfo( - name = "slope", - title = gettextf("%s (slope)",unlist(options$trendsTrend)), - type = "number" - ) + trendsSummary$addColumnInfo(name = "slope", title = gettextf("%s (slope)",unlist(options$trendsTrend)), type = "number") if (type %in% c("LMM", "GLMM")) { - trendsSummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - if(type == "LMM"){ - if(options$trendsDf != "asymptotic"){ - trendsSummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - } - } - trendsSummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) - ) - trendsSummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth) - ) + + trendsSummary$addColumnInfo(name = "se", title = gettext("SE"), type = "number") + if (type == "LMM" && options$trendsDf != "asymptotic") + trendsSummary$addColumnInfo(name = "df", title = gettext("df"), type = "number") + + trendsSummary$addColumnInfo(name = "lowerCI", title = gettext("Lower"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth)) + trendsSummary$addColumnInfo(name = "upperCI", title = gettext("Upper"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$trendsCIwidth)) + if (options$trendsCompare) { - trendsSummary$addColumnInfo( - name = "stat", - title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), - type = "number" - ) - trendsSummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") + trendsSummary$addColumnInfo(name = "stat", title = ifelse(colnames(emmTest)[ncol(emmTest) - 1] == "t.ratio", gettext("t"), gettext("z")), type = "number") + trendsSummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") trendsSummary$addFootnote(.mmMessageTestNull(options$trendsCompareTo), symbol = "\u2020", colNames = "pval") if (options$pvalVS) { - trendsSummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") + trendsSummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") trendsSummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") } } } else if (type %in% c("BLMM", "BGLMM")) { - trendsSummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) - ) - trendsSummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth) - ) + trendsSummary$addColumnInfo(name = "lowerCI", title = gettext("Lower"), type = "number", overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth)) + trendsSummary$addColumnInfo(name = "upperCI", title = gettext("Upper"), type = "number", overtitle = gettextf("%s%% HPD", 100 * options$trendsCIwidth)) } jaspResults[["trendsSummary"]] <- trendsSummary @@ -1730,60 +1550,52 @@ } for (vi in 1:length(trendsVarNames)) { - if (typeof(dataset[, trendsVarNames[vi]]) == "double") { + + if (typeof(dataset[, trendsVarNames[vi]]) == "double") tempRow[trendsVarNames[vi]] <- emmTable[i, vi] - } else{ - tempRow[trendsVarNames[vi]] <- - as.character(emmTable[i, vi]) - } + else + tempRow[trendsVarNames[vi]] <- as.character(emmTable[i, vi]) + } tempRow$slope <- emmTable[i, length(trendsVarNames) + 1] if (type %in% c("LMM", "GLMM")) { # the estimate is before SE (names change for GLMM) tempRow$se <- emmTable[i, "SE"] - if(type == "LMM"){ - if(options$trendsDf != "asymptotic"){ - tempRow$df <- emmTable[i, "df"] - } - } + if (type == "LMM" && options$trendsDf != "asymptotic") + tempRow$df <- emmTable[i, "df"] if (options$trendsCompare) { tempRow$stat <- emmTest[i, grep("ratio", colnames(emmTest))] tempRow$pval <- emmTest[i, "p.value"] - if (options$pvalVS) { + if (options$pvalVS) tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } + } } tempRow$lowerCI <- emmTable[i, ncol(emmTable) - 1] tempRow$upperCI <- emmTable[i, ncol(emmTable)] - trendsSummary$addRows(tempRow) } - if (length(emm@misc$avgd.over) != 0) { + if (length(emm@misc$avgd.over) != 0) trendsSummary$addFootnote(.mmMessageAveragedOver(emm@misc$avgd.over)) - } - # add warning message - if (type == "LMM") { - if (options$trendsDf != attr(emm@dffun, "mesg")) { - # TODO: for GLMM - trendsSummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) - } - } - if (type == "GLMM") { - trendsSummary$addFootnote(.mmMessageNotResponse) - } + # add warning message + if (type == "LMM" && options$trendsDf != attr(emm@dffun, "mesg")) + trendsSummary$addFootnote(.mmMessageDFdisabled, symbol = gettext("Warning:")) + if (type == "GLMM") + trendsSummary$addFootnote(.mmMessageNotResponse) - object <- list(emm = emm, - emmTable = emmTable) + object <- list( + emm = emm, + emmTable = emmTable + ) EMTresults$object <- object jaspResults[["EMTresults"]] <- EMTresults @@ -1791,162 +1603,127 @@ return() } .mmContrasts <- function(jaspResults, options, type = "LMM", what = "Means") { + if (what == "Means") { - if (!is.null(jaspResults[["contrasts_Means"]])) + + if (!is.null(jaspResults[["contrastsMeans"]])) return() + emm <- jaspResults[["EMMresults"]]$object$emm - emmTable <- jaspResults[["EMMresults"]]$object$emmTable + emmTable <- jaspResults[["EMMresults"]]$object$emmTable + } else if (what == "Trends") { - if (!is.null(jaspResults[["contrasts_Trends"]])) + + if (!is.null(jaspResults[["contrastsTrends"]])) return() - emm <- jaspResults[["EMTresults"]]$object$emm + + emm <- jaspResults[["EMTresults"]]$object$emm emmTable <- jaspResults[["EMTresults"]]$object$emmTable + } EMMCsummary <- createJaspTable(title = gettext("Contrasts")) EMMCsummary$position <- ifelse(what == "Means", 8, 10) - if (type == "LMM") { - dependencies <- .mmDependenciesLMM - } else if (type == "GLMM") { - dependencies <- - c(.mmDependenciesGLMM, if (what == "Means") - "marginalMeansResponse") - } else if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- - c(.mmDependenciesBGLMM, if (what == "Means") - "marginalMeansResponse") - } + + dependencies <- .mmSwichDependencies(type) + if (type %in% c("GLMM", "BGLMM") && what == "Means") + dependencies <- c(dependencies, "marginalMeansResponse") + if (what == "Means") { - if (type %in% c("LMM", "GLMM")) { - dependenciesAdd <- - c( - "marginalMeans", - "marginalMeansDf", - "marginalMeansSD", - "marginalMeansCompare", - "marginalMeansCompareTo", - "marginalMeansContrast", - "marginalMeansCIwidth", - "pvalVS", - "marginalMeansOverride", - "Contrasts", - "marginalMeansAdjustment" - ) - } else{ - dependenciesAdd <- - c( - "marginalMeans", - "marginalMeansSD", - "marginalMeansContrast", - "marginalMeansCIwidth", - "Contrasts" - ) - } + if (type %in% c("LMM", "GLMM")) + dependenciesAdd <- c( + "marginalMeans", + "marginalMeansDf", + "marginalMeansSD", + "marginalMeansCompare", + "marginalMeansCompareTo", + "marginalMeansContrast", + "marginalMeansCIwidth", + "pvalVS", + "marginalMeansOverride", + "Contrasts", + "marginalMeansAdjustment" + ) + else + dependenciesAdd <- c( + "marginalMeans", + "marginalMeansSD", + "marginalMeansContrast", + "marginalMeansCIwidth", + "Contrasts" + ) + } else if (what == "Trends") { - if (type %in% c("LMM", "GLMM")) { - dependenciesAdd <- - c( - "trendsVariables", - "trendsTrend", - "trendsDf", - "trendsSD", - "trendsCompare", - "trendsCompareTo", - "trendsContrast", - "trendsContrasts", - "trendsCIwidth", - "pvalVS", - "trendsOverride", - "trendsAdjustment" - ) - } else{ - dependenciesAdd <- - c( - "trendsVariables", - "trendsTrend", - "trendsSD", - "trendsCIwidth", - "trendsContrast", - "trendsContrasts" - ) - } + if (type %in% c("LMM", "GLMM")) + dependenciesAdd <- c( + "trendsVariables", + "trendsTrend", + "trendsDf", + "trendsSD", + "trendsCompare", + "trendsCompareTo", + "trendsContrast", + "trendsContrasts", + "trendsCIwidth", + "pvalVS", + "trendsOverride", + "trendsAdjustment" + ) + else + dependenciesAdd <-c( + "trendsVariables", + "trendsTrend", + "trendsSD", + "trendsCIwidth", + "trendsContrast", + "trendsContrasts" + ) + } EMMCsummary$dependOn(c(dependencies, dependenciesAdd)) if (type %in% c("LMM", "GLMM")) { - EMMCsummary$addColumnInfo(name = "contrast", - title = "", - type = "string") - EMMCsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMCsummary$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - EMMCsummary$addColumnInfo(name = "df", - title = gettext("df"), - type = "number") - EMMCsummary$addColumnInfo(name = "stat", - title = gettext("z"), - type = "number") - EMMCsummary$addColumnInfo(name = "pval", - title = gettext("p"), - type = "pvalue") + + EMMCsummary$addColumnInfo(name = "contrast", title = "", type = "string") + EMMCsummary$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") + EMMCsummary$addColumnInfo(name = "se", title = gettext("SE"), type = "number") + EMMCsummary$addColumnInfo(name = "df", title = gettext("df"), type = "number") + EMMCsummary$addColumnInfo(name = "stat", title = gettext("z"), type = "number") + EMMCsummary$addColumnInfo(name = "pval", title = gettext("p"), type = "pvalue") + if (options$pvalVS) { - EMMCsummary$addColumnInfo(name = "pvalVS", - title = gettext("VS-MPR"), - type = "number") + EMMCsummary$addColumnInfo(name = "pvalVS", title = gettext("VS-MPR"), type = "number") EMMCsummary$addFootnote(.mmMessageVovkSellke, symbol = "\u002A", colNames = "pvalVS") } + } else if (type %in% c("BLMM", "BGLMM")) { - EMMCsummary$addColumnInfo(name = "contrast", - title = "", - type = "string") - EMMCsummary$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - EMMCsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf( - "%s%% HPD", - 100 * if (what == "Means") - options$marginalMeansCIwidth - else - options$trendsCIwidth - ) - ) - EMMCsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf( - "%s%% HPD", - 100 * if (what == "Means") - options$marginalMeansCIwidth - else - options$trendsCIwidth - ) - ) + + if (what == "Means") + overtitle <- gettextf("%s%% HPD", 100 * options$marginalMeansCIwidth) + else + overtitle <- gettextf("%s%% HPD", 100 * options$trendsCIwidth) + + EMMCsummary$addColumnInfo(name = "contrast", title = "", type = "string") + EMMCsummary$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") + EMMCsummary$addColumnInfo(name = "lowerCI", title = gettext("Lower"), type = "number", overtitle = overtitle) + EMMCsummary$addColumnInfo(name = "upperCI", title = gettext("Upper"), type = "number", overtitle = overtitle) + } # Columns have been specified, show to user - jaspResults[[paste0("contrasts_", what)]] <- EMMCsummary + jaspResults[[paste0("contrasts", what)]] <- EMMCsummary if (what == "Means") { selectedContrasts <- options$Contrasts selectedAdjustment <- options$marginalMeansAdjustment - if (type %in% c("GLMM", "BGLMM")) { + if (type %in% c("GLMM", "BGLMM")) selectedResponse <- options$marginalMeansResponse - } + } else if (what == "Trends") { @@ -1956,30 +1733,30 @@ contrs <- list() i <- 0 - for (cont in selectedContrasts[sapply(selectedContrasts, function(x) - x$isContrast)]) { + for (cont in selectedContrasts[sapply(selectedContrasts, function(x) x$isContrast)]) { + if (all(cont$values == 0)) next + i <- i + 1 - contrs[[cont$name]] <- - unname(sapply(cont$values, function(x) - eval(parse(text = x)))) + contrs[[cont$name]] <- unname(sapply(cont$values, function(x) eval(parse(text = x)))) + } - if (length(contrs) == 0) { + + if (length(contrs) == 0) return() - } # take care of the scale if (type %in% c("LMM", "BLMM") || what == "Trends") { emmContrast <- tryCatch( as.data.frame( - emmeans::contrast(emm, contrs, - adjust = if (type %in% c("LMM", "GLMM")) - selectedAdjustment) + emmeans::contrast( + emm, + contrs, + adjust = if (type %in% c("LMM", "GLMM")) selectedAdjustment) ), - error = function(e) - e + error = function(e) e ) } else if (type %in% c("GLMM", "BGLMM")) { if (selectedResponse) { @@ -1988,54 +1765,57 @@ emmeans::contrast( emmeans::regrid(emm), contrs, - adjust = if (type == "GLMM") - selectedAdjustment + adjust = if (type == "GLMM") selectedAdjustment ) ), - error = function(e) - e + error = function(e) e ) - } else{ + } else { emmContrast <- tryCatch( as.data.frame( - emmeans::contrast(emm, contrs, - adjust = if (type == "GLMM") - selectedAdjustment) + emmeans::contrast( + emm, + contrs, + adjust = if (type == "GLMM") selectedAdjustment) ), - error = function(e) - e + error = function(e) e ) } } - if (length(emmContrast) == 2) { + if (inherits(emmContrast, "error")) { EMMCsummary$setError(emmContrast$message) return() } # fix the title name if there is a t-stats if (type %in% c("LMM", "GLMM")) + if (colnames(emmContrast)[5] == "t.ratio") EMMCsummary$setColumnTitle("stat", gettext("t")) + if (type %in% c("GLMM", "BGLMM")) { - if (type == "GLMM") { + + if (type == "GLMM") tempEstName <- colnames(emmContrast)[ncol(emmContrast) - 4] - } else if (type == "BGLMM") { + else if (type == "BGLMM") tempEstName <- colnames(emmContrast)[ncol(emmContrast) - 2] - } - if (tempEstName == "odds.ratio") { + + if (tempEstName == "odds.ratio") EMMCsummary$setColumnTitle("estimate", gettext("Odds Ratio")) - } else if (tempEstName == "ratio") { + else if (tempEstName == "ratio") EMMCsummary$setColumnTitle("estimate", gettext("Ratio")) - } else if (tempEstName == "estimate") { + else if (tempEstName == "estimate") EMMCsummary$setColumnTitle("estimate", gettext("Estimate")) - } else{ + else EMMCsummary$setColumnTitle("estimate", tempEstName) - } + } for (i in 1:nrow(emmContrast)) { + if (type %in% c("LMM", "GLMM")) { + tempRow <- list( contrast = names(contrs)[i], estimate = emmContrast[i, ncol(emmContrast) - 4], @@ -2044,94 +1824,96 @@ stat = emmContrast[i, ncol(emmContrast) - 1], pval = emmContrast[i, "p.value"] ) - if (options$pvalVS) { + + if (options$pvalVS) tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } EMMCsummary$addFootnote(.messagePvalAdjustment(selectedAdjustment), symbol = "\u2020", colNames = "pval") - if (options$pvalVS) { - tempRow$pvalVS <- VovkSellkeMPR(tempRow$pval) - } } else if (type %in% c("BLMM", "BGLMM")) { + tempRow <- list( contrast = names(contrs)[i], estimate = emmContrast[i, ncol(emmContrast) - 2], lowerCI = emmContrast[i, "lower.HPD"], upperCI = emmContrast[i, "upper.HPD"] ) + } if (type %in% c("GLMM", "BGLMM") && what == "Means") { - if (!selectedResponse) { + + if (!selectedResponse) EMMCsummary$addFootnote(.mmMessageNotResponse) - } else{ + else EMMCsummary$addFootnote(.mmMessageResponse) - } - } + } EMMCsummary$addRows(tempRow) - } + + return() } # specific Bayesian .mmReadDataB <- function(dataset, options, type = "BLMM") { - if (!is.null(dataset)) { + + if (!is.null(dataset)) return(dataset) - } else{ - if (type == "LMM") { - return( - readDataSetToEnd( - columns.as.numeric = options$dependentVariable, - columns.as.factor = c(options$fixedVariables, options$randomVariables) - ) + + if (type == "LMM") { + + return( + readDataSetToEnd( + columns.as.numeric = options$dependentVariable, + columns.as.factor = c(options$fixedVariables, options$randomVariables) ) - } else if (type == "GLMM") { - if (options$dependentVariableAggregation == "") { - return(readDataSetToEnd( - columns = c( - options$dependentVariable, - options$fixedVariables, - options$randomVariables - ) - )) - } else{ - return(readDataSetToEnd( - columns = c( - options$dependentVariable, - options$fixedVariables, - options$randomVariables, - options$dependentVariableAggregation - ) - )) - } + ) + + } else if (type == "GLMM") { + if (options$dependentVariableAggregation == "") { + + return(readDataSetToEnd( + columns = c( + options$dependentVariable, + options$fixedVariables, + options$randomVariables + ) + )) + + } else { + + return(readDataSetToEnd( + columns = c( + options$dependentVariable, + options$fixedVariables, + options$randomVariables, + options$dependentVariableAggregation + ) + )) + } } } .mmFitModelB <- function(jaspResults, dataset, options, type = "BLMM") { + # hopefully fixing the random errors contr.bayes <<- stanova::contr.bayes stan_glmer <- rstanarm::stan_glmer + if (!is.null(jaspResults[["mmModel"]])) return() mmModel <- createJaspState() - - - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - mmModel$dependOn(dependencies) + mmModel$dependOn(.mmSwichDependencies(type)) modelFormula <- .mmModelFormula(options, dataset) if (type == "BLMM") { + model <- tryCatch(stanova::stanova( formula = as.formula(modelFormula$modelFormula), check_contrasts = "contr.bayes", @@ -2140,25 +1922,26 @@ iter = options$iteration, warmup = options$warmup, adapt_delta = options$adapt_delta, - control = list(maxTreedepth = options$max_treedepth), + control = list(max_treedepth = options$max_treedepth), seed = .getSeedJASP(options), model_fun = "lmer" ), error = function(e) e ) } else if (type == "BGLMM") { + # needs to be evaluated in the global environment glmmLink <<- options$link if (options$family == "neg_binomial_2") { glmmFamily <<- rstanarm::neg_binomial_2(link = glmmLink) } else if (options$family == "betar") { glmmFamily <<- mgcv::betar(link = glmmLink) - } else if (options$family != "binomial_agg"){ + } else if (options$family != "binomialAgg") { tempFamily <<- options$family glmmFamily <<- eval(call(tempFamily, glmmLink)) } # I wish there was a better way to do this - if (options$family == "binomial_agg") { + if (options$family == "binomialAgg") { glmmWeight <<- dataset[, options$dependentVariableAggregation] model <- tryCatch(stanova::stanova( @@ -2169,14 +1952,15 @@ iter = options$iteration, warmup = options$warmup, adapt_delta = options$adapt_delta, - control = list(maxTreedepth = options$max_treedepth), + control = list(max_treedepth = options$max_treedepth), weights = glmmWeight, family = eval(call("binomial", glmmLink)), seed = .getSeedJASP(options), model_fun = "glmer" ), error = function(e) e ) - } else{ + } else { + model <- tryCatch(stanova::stanova( formula = as.formula(modelFormula$modelFormula), check_contrasts = "contr.bayes", @@ -2185,7 +1969,7 @@ iter = options$iteration, warmup = options$warmup, adapt_delta = options$adapt_delta, - control = list(maxTreedepth = options$max_treedepth), + control = list(max_treedepth = options$max_treedepth), family = glmmFamily, seed = .getSeedJASP(options), model_fun = "glmer" @@ -2203,7 +1987,7 @@ } object <- list( - model = model, + model = model, removedMe = modelFormula$removedMe, removedTe = modelFormula$removedTe ) @@ -2214,6 +1998,7 @@ return() } .mmFitStatsB <- function(jaspResults, options, type = "BLMM") { + if (!is.null(jaspResults[["fitStats"]])) return() @@ -2221,14 +2006,8 @@ fitSummary <- createJaspContainer("Model summary") fitSummary$position <- 2 + fitSummary$dependOn(c(.mmSwichDependencies(type), "fitStats")) - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - - fitSummary$dependOn(c(dependencies, "fitStats")) jaspResults[["fitSummary"]] <- fitSummary ### fit statistics @@ -2275,37 +2054,33 @@ tempRow <- list( observations = attr(stanovaSummary, "nobs") ) + for (n in names(attr(stanovaSummary, "ngrps"))) { fitSizes$addColumnInfo(name = n, title = n, type = "integer", overtitle = gettext("Levels of RE grouping factors")) tempRow[[n]] <- attr(stanovaSummary, "ngrps")[[n]] } + fitSizes$addRows(tempRow) jaspResults[["fitSummary"]][["fitSizes"]] <- fitSizes return() } .mmSummaryREB <- function(jaspResults, options, type = "BLMM") { + if (!is.null(jaspResults[["REsummary"]])) return() model <- jaspResults[["mmModel"]]$object$model REsummary <- createJaspContainer(title = gettext("Variance/Correlation Estimates")) - REsummary$position <- 4 - - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - REsummary$dependOn(c(dependencies, "showRE", "summaryCI")) + REsummary$dependOn(c(.mmSwichDependencies(type), "showRE", "summaryCI")) ### keep this if we decide to change things #modelSummary <- rstan::summary(model$stanfit, probs = c(.5-options$summaryCI/2, .5+options$summaryCI/2))$summary #namesSummary <- rownames(modelSummary) #re_names <- namesSummary[grepl("Sigma[", namesSummary, fixed = T)] - #re_groups <- sapply(re_names, function(x){ + #re_groups <- sapply(re_names, function(x) { # substr(x,7,regexpr(":", x, fixed = TRUE)[1]-1) #}) #re_summary <- modelSummary[namesSummary %in% re_names,] @@ -2317,26 +2092,20 @@ tempVarCorr <- VarCorr[[gi]] # add variance summary - REvar <- - createJaspTable(title = gettextf("%s: Variance Estimates",names(VarCorr)[gi])) - - REvar$addColumnInfo(name = "variable", - title = gettext("Term"), - type = "string") - REvar$addColumnInfo(name = "std", - title = gettext("Std. Deviation"), - type = "number") - REvar$addColumnInfo(name = "var", - title = gettext("Variance"), - type = "number") + REvar <- createJaspTable(title = gettextf("%s: Variance Estimates",names(VarCorr)[gi])) + + REvar$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") + REvar$addColumnInfo(name = "std", title = gettext("Std. Deviation"), type = "number") + REvar$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") tempStdDev <- attr(tempVarCorr, "stddev") + for (i in 1:length(tempStdDev)) { - if (names(tempStdDev)[i] == "(Intercept)") { + + if (names(tempStdDev)[i] == "(Intercept)") varName <- gettext("Intercept") - } else{ + else varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) - } tempRow <- list( variable = varName, @@ -2355,37 +2124,36 @@ # add correlation summary if (length(tempStdDev) > 1) { tempCorr <- attr(tempVarCorr, "correlation") - REcor <- - createJaspTable(title = gettextf("%s: Correlation Estimates",names(VarCorr)[gi])) + REcor <- createJaspTable(title = gettextf("%s: Correlation Estimates",names(VarCorr)[gi])) # add columns - REcor$addColumnInfo(name = "variable", - title = gettext("Term"), - type = "string") + REcor$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") + for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") { + + if (rownames(tempCorr)[i] == "(Intercept)") varName <- gettext("Intercept") - } else{ + else varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - } - REcor$addColumnInfo(name = paste0("v", i), - title = varName, - type = "number") + + REcor$addColumnInfo(name = paste0("v", i), title = varName, type = "number") + } # fill rows for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") { + + if (rownames(tempCorr)[i] == "(Intercept)") varName <- gettext("Intercept") - } else{ + else varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - } tempRow <- list(variable = varName) + for (j in 1:i) { - # ncol(tempCorr) tempRow[paste0("v", j)] <- tempCorr[i, j] } + REcor$addRows(tempRow) } @@ -2398,8 +2166,7 @@ } # add residual variance summary - REres <- - createJaspTable(title = gettext("Residual Variance Estimates")) + REres <- createJaspTable(title = gettext("Residual Variance Estimates")) REres$addColumnInfo(name = "std", title = gettext("Std. Deviation"), type = "number") REres$addColumnInfo(name = "var", title = gettext("Variance"), type = "number") @@ -2417,6 +2184,7 @@ return() } .mmSummaryFEB <- function(jaspResults, options, type = "BLMM") { + if (!is.null(jaspResults[["FEsummary"]])) return() @@ -2424,59 +2192,31 @@ FEsummary <- createJaspTable(title = "Fixed Effects Estimates") FEsummary$position <- 3 - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - FEsummary$dependOn(c(dependencies, "showFE", "summaryCI")) - - FEsummary$addColumnInfo(name = "term", - title = "Term", - type = "string") - FEsummary$addColumnInfo(name = "estimate", - title = "Estimate", - type = "number") - FEsummary$addColumnInfo(name = "se", - title = "SE", - type = "number") - FEsummary$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - FEsummary$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - FEsummary$addColumnInfo(name = "rhat", - title = "R-hat", - type = "number") - FEsummary$addColumnInfo(name = "neff", - title = "ESS", - type = "number") + FEsummary$dependOn(c(.mmSwichDependencies(type), "showFE", "summaryCI")) + + FEsummary$addColumnInfo(name = "term", title = "Term", type = "string") + FEsummary$addColumnInfo(name = "estimate", title = "Estimate", type = "number") + FEsummary$addColumnInfo(name = "se", title = "SE", type = "number") + FEsummary$addColumnInfo(name = "lowerCI", title = gettext("Lower"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$summaryCI)) + FEsummary$addColumnInfo(name = "upperCI", title = gettext("Upper"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$summaryCI)) + FEsummary$addColumnInfo(name = "rhat", title = "R-hat", type = "number") + FEsummary$addColumnInfo(name = "neff", title = "ESS", type = "number") jaspResults[["FEsummary"]] <- FEsummary - modelSummary <- - rstan::summary(model$stanfit, - probs = c(.5 - options$summaryCI / 2, .5 + options$summaryCI / 2))$summary + modelSummary <- rstan::summary( + model$stanfit, + probs = c(.5 - options$summaryCI / 2, .5 + options$summaryCI / 2) + )$summary namesSummary <- rownames(modelSummary) - feSummary <- - modelSummary[!grepl("b[", namesSummary, fixed = T) & - !namesSummary %in% c("mean_PPD", "log-posterior") & - namesSummary != "sigma" & - !grepl("Sigma[", namesSummary, fixed = T), ] + feSummary <- modelSummary[!grepl("b[", namesSummary, fixed = T) & !namesSummary %in% c("mean_PPD", "log-posterior") & namesSummary != "sigma" & !grepl("Sigma[", namesSummary, fixed = TRUE), ] for (i in 1:nrow(feSummary)) { - if (rownames(feSummary)[i] == "(Intercept)") { + + if (rownames(feSummary)[i] == "(Intercept)") effectName <- "Intercept" - } else{ + else effectName <- .mmVariableNames(rownames(feSummary)[i], options$fixedVariables) - } tempRow <- list( term = effectName, @@ -2493,8 +2233,11 @@ # add warning messages FEsummary$addFootnote(.mmMessageInterpretability) + + return() } .mmSummaryStanova <- function(jaspResults, dataset, options, type = "BLMM") { + if (!is.null(jaspResults[["STANOVAsummary"]])) return() @@ -2506,103 +2249,79 @@ probs = c(.50 - options$summaryCI / 2, .50, .50 + options$summaryCI / 2), diff_intercept = options$show == "deviation" ) - } else{ + } else { # dummy object for creating empty summary - modelSummary <- - list("Model summary" = matrix(NA, nrow = 0, ncol = 0)) + modelSummary <- list("Model summary" = matrix(NA, nrow = 0, ncol = 0)) } STANOVAsummary <- createJaspContainer(title = "") - jaspResults[["STANOVAsummary"]] <- STANOVAsummary - STANOVAsummary$position <- 1 - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - STANOVAsummary$dependOn(c(dependencies, "summaryCI", "show")) + STANOVAsummary$dependOn(c(.mmSwichDependencies(type), "summaryCI", "show")) + + jaspResults[["STANOVAsummary"]] <- STANOVAsummary # go over each random effect grouping factor for (i in 1:length(modelSummary)) { tempSummary <- modelSummary[[i]] if (names(modelSummary)[i] == "Model summary") { + varName <- gettext("Model summary") tableName <- varName + } else if (names(modelSummary)[i] == "(Intercept)") { + varName <- gettext("Intercept") tableName <- varName - } else{ + + } else { + varName <- jaspBase::gsubInteractionSymbol(names(modelSummary)[i]) + if (options$show == "deviation") { - tableName <- - gettextf("%s (differences from intercept)",varName) + tableName <- gettextf("%s (differences from intercept)",varName) + } else if (options$show == "mmeans") { - if (nrow(tempSummary) == 1) { + + if (nrow(tempSummary) == 1) tableName <- gettextf("%s (trend)",varName) - } else{ + else tableName <- gettextf("%s (marginal means)",varName) - } + } } tempTable <- createJaspTable(title = tableName) STANOVAsummary[[paste0("summary_", i)]] <- tempTable - if (varName != "Intercept" && nrow(tempSummary) > 1) { - tempTable$addColumnInfo(name = "level", - title = gettext("Level"), - type = "string") - } - tempTable$addColumnInfo(name = "estimate", - title = gettext("Estimate"), - type = "number") - tempTable$addColumnInfo(name = "se", - title = gettext("SE"), - type = "number") - tempTable$addColumnInfo( - name = "lowerCI", - title = gettext("Lower"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - tempTable$addColumnInfo( - name = "upperCI", - title = gettext("Upper"), - type = "number", - overtitle = gettextf("%s%% CI", 100 * options$summaryCI) - ) - tempTable$addColumnInfo(name = "rhat", - title = gettext("R-hat"), - type = "number") - tempTable$addColumnInfo(name = "ess_bulk", - title = gettext("ESS (bulk)"), - type = "number") - tempTable$addColumnInfo(name = "ess_tail", - title = gettext("ESS (tail)"), - type = "number") - - if (tableName == gettext("Model summary")) { - if(options$dependentVariable != "" && - length(options$fixedVariables) > 0 && - length(options$randomVariables) == 0) { + if (varName != "Intercept" && nrow(tempSummary) > 1) + tempTable$addColumnInfo(name = "level", title = gettext("Level"), type = "string") + + tempTable$addColumnInfo(name = "estimate", title = gettext("Estimate"), type = "number") + tempTable$addColumnInfo(name = "se", title = gettext("SE"), type = "number") + tempTable$addColumnInfo(name = "lowerCI", title = gettext("Lower"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$summaryCI)) + tempTable$addColumnInfo(name = "upperCI", title = gettext("Upper"), type = "number", overtitle = gettextf("%s%% CI", 100 * options$summaryCI)) + tempTable$addColumnInfo(name = "rhat", title = gettext("R-hat"), type = "number") + tempTable$addColumnInfo(name = "ess_bulk", title = gettext("ESS (bulk)"), type = "number") + tempTable$addColumnInfo(name = "ess_tail", title = gettext("ESS (tail)"), type = "number") + + if (tableName == "Model summary") { + + if (options$dependentVariable != "" && length(options$fixedVariables) > 0 && length(options$randomVariables) == 0) tempTable$addFootnote(.mmMessageMissingRE) - } - if (type == "BGLMM") { - if (options$family == "binomial_agg" && - options$dependentVariableAggregation == "") { - tempTable$addFootnote(.mmMessageMissingAgg) - } - } - if(class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { + if (type == "BGLMM" && options$family == "binomialAgg" && options$dependentVariableAggregation == "") + tempTable$addFootnote(.mmMessageMissingAgg) + + + if (inherits(jaspResults[["mmModel"]]$object$model, "error")) STANOVAsummary$setError(gettext("The model could not be estimated. Please, check the options and dataset for errors.")) - } + return() } for (j in 1:nrow(tempSummary)) { + tempRow <- list( estimate = tempSummary$Mean[j], se = tempSummary$MAD_SD[j], @@ -2616,21 +2335,22 @@ ) if (varName != "Intercept" && nrow(tempSummary) > 1) { - varName <- - paste(unlist(strsplit( - as.character(tempSummary$Variable[j]), "," - )), collapse = jaspBase::interactionSymbol) + + varName <- paste(unlist(strsplit(as.character(tempSummary$Variable[j]), ",")), collapse = jaspBase::interactionSymbol) varName <- gsub(" ", "", varName, fixed = TRUE) - if (grepl(jaspBase::interactionSymbol, names(modelSummary)[i], fixed = T)) { - for (n in unlist(strsplit(names( - modelSummary - )[i], jaspBase::interactionSymbol))) { + + if (grepl(jaspBase::interactionSymbol, names(modelSummary)[i], fixed = TRUE)) { + + for (n in unlist(strsplit(names(modelSummary)[i], jaspBase::interactionSymbol))) { varName <- gsub(n, "", varName, fixed = TRUE) } - } else{ - varName <- - gsub(names(modelSummary)[i], "", varName, fixed = TRUE) + + } else { + + varName <- gsub(names(modelSummary)[i], "", varName, fixed = TRUE) + } + tempRow$level <- varName } @@ -2644,145 +2364,105 @@ divIterations <- rstan::get_num_divergent(model$stanfit) lowBmfi <- rstan::get_low_bfmi_chains(model$stanfit) maxTreedepth <- rstan::get_num_max_treedepth(model$stanfit) - if(any(is.infinite(rstan::summary(model$stanfit)$summary[, "Rhat"]))){ + minESS <- min(rstan::summary(model$stanfit)$summary[, "n_eff"]) + + if (any(is.infinite(rstan::summary(model$stanfit)$summary[, "Rhat"]))) maxRhat <- Inf - }else{ + else maxRhat <- max(rstan::summary(model$stanfit)$summary[, "Rhat"]) - } - minESS <- - min(rstan::summary(model$stanfit)$summary[, "n_eff"]) - if (divIterations != 0) { + + + if (divIterations != 0) tempTable$addFootnote(.mmMessageDivergentIter(divIterations), symbol = gettext("Warning:")) - } - if (length(lowBmfi) != 0) { + + if (length(lowBmfi) != 0) tempTable$addFootnote(.mmMessageLowBMFI(length(lowBmfi)), symbol = gettext("Warning:")) - } - if (maxTreedepth != 0) { + + if (maxTreedepth != 0) tempTable$addFootnote(.mmMessageMaxTreedepth(max_treedepth)) - } - if (maxRhat > 1.01) { + + if (maxRhat > 1.01) tempTable$addFootnote(.mmMessageMaxRhat(maxRhat), symbol = gettext("Warning:")) - } - if (minESS < 100 * options$chains || is.nan(minESS)) { + + if (minESS < 100 * options$chains || is.nan(minESS)) tempTable$addFootnote(.mmMessageMinESS(minESS, 100 * options$chains), symbol = gettext("Warning:")) - } + removedMe <- jaspResults[["mmModel"]]$object$removedMe removedTe <- jaspResults[["mmModel"]]$object$removedTe addedRe <- jaspResults[["mmModel"]]$object$addedRe - if (length(removedMe) > 0) { - for (j in 1:length(removedMe)) { - tempTable$addFootnote(.mmMessageOmmitedTerms1(removedMe[[j]], names(removedMe)[j]), - symbol = gettext("Note:")) - } + + for (j in seq_along(removedMe)) { + tempTable$addFootnote(.mmMessageOmmitedTerms1(removedMe[[j]], names(removedMe)[j]), symbol = gettext("Note:")) } - if (length(removedTe) > 0) { - for (j in 1:length(removedTe)) { - tempTable$addFootnote(.mmMessageOmmitedTerms2(removedTe[[j]], names(removedTe)[j]), - symbol = gettext("Note:")) - } + for (j in seq_along(removedTe)) { + tempTable$addFootnote(.mmMessageOmmitedTerms2(removedTe[[j]], names(removedTe)[j]), symbol = gettext("Note:")) } - if (length(addedRe) > 0) { - for (i in 1:length(addedRe)) { - tempTable$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) - } + for (i in seq_along(addedRe)) { + tempTable$addFootnote(.mmMessageAddedTerms(addedRe[[i]], names(addedRe)[i]), symbol = gettext("Note:")) } - if (jaspResults[["n_missing"]]$object != 0) { - tempTable$addFootnote(.mmMessageMissingRows(jaspResults[["n_missing"]]$object)) - } - if (type == "BGLMM") { + + if (jaspResults[["nMissing"]]$object != 0) + tempTable$addFootnote(.mmMessageMissingRows(jaspResults[["nMissing"]]$object)) + + if (type == "BGLMM") tempTable$addFootnote(.mmMessageGLMMtype(options$family, options$link)) - } } + return() } .mmDiagnostics <- function(jaspResults, options, dataset, type = "BLMM") { + if (!is.null(jaspResults[["diagnosticPlots"]])) return() - diagnosticPlots <- createJaspContainer(title = gettext("Sampling diagnostics")) - diagnosticPlots$position <- 5 - if (type == "BLMM") { - dependencies <- .mmDependenciesBLMM - } else if (type == "BGLMM") { - dependencies <- .mmDependenciesBGLMM - } - diagnosticPlots$dependOn(c( - dependencies, - "samplingPlot", - "samplingVariable1", - "samplingVariable2" - )) + diagnosticPlots$dependOn(c(.mmSwichDependencies(type), "samplingPlot", "samplingVariable1", "samplingVariable2")) jaspResults[["diagnosticPlots"]] <- diagnosticPlots - if (options$samplingPlot == "stan_scat" && - length(options$samplingVariable2) == 0) { + if (options$samplingPlot == "stan_scat" && length(options$samplingVariable2) == 0) { diagnosticPlots[["emptyPlot"]] <- createJaspPlot() return() } model <- jaspResults[["mmModel"]]$object$model - if (options$samplingPlot != "stan_scat") { - pars <- - paste0(unlist(options$samplingVariable1), collapse = ":") - } else{ - pars <- c(paste0(unlist( - options$samplingVariable1 - ), collapse = ":"), - paste0(unlist( - options$samplingVariable2 - ), collapse = ":")) - } + if (options$samplingPlot != "stan_scat") + pars <- paste0(unlist(options$samplingVariable1), collapse = ":") + else + pars <- c( + paste0(unlist(options$samplingVariable1), collapse = ":"), + paste0(unlist(options$samplingVariable2), collapse = ":") + ) - plotData <- - .mmGetPlotSamples(model = model, - pars = pars, - options = options) + plotData <- .mmGetPlotSamples(model = model, pars = pars, options = options) for (i in 1:length(plotData)) { + if (names(plotData)[i] == "Intercept") { varName <- gettext("Intercept") - } else{ + } else { varName <- strsplit(as.character(pars), ":") - varName <- - sapply(varName, function(x) - paste(unlist( - strsplit(x, ",") - ), collapse = ":")) - varName <- - sapply(varName, function(x) - gsub(" ", "", x, fixed = TRUE)) - varName <- - sapply(varName, function(x) - .mmVariableNames(x, options$fixedVariables)) + varName <- sapply(varName, function(x) paste(unlist(strsplit(x, ",")), collapse = ":")) + varName <- sapply(varName, function(x) gsub(" ", "", x, fixed = TRUE)) + varName <- sapply(varName, function(x) .mmVariableNames(x, options$fixedVariables)) varName <- paste0(varName, collapse = " by ") } - plots <- - createJaspPlot( - title = varName, - width = 400, - height = 300 - ) - - if (options$samplingPlot == "stan_trace") { - p <- .rstanPlotTrace(plotData[[i]]) - } else if (options$samplingPlot == "stan_scat") { - p <- .rstanPlotScat(plotData[[i]]) - } else if (options$samplingPlot == "stan_hist") { - p <- .rstanPlotHist(plotData[[i]]) - } else if (options$samplingPlot == "stan_dens") { - p <- .rstanPlotDens(plotData[[i]]) - } else if (options$samplingPlot == "stan_ac") { - p <- .rstanPlotAcor(plotData[[i]]) - } + plots <- createJaspPlot(title = varName, width = 400, height = 300) + p <- switch( + options$samplingPlot, + "stan_trace" = .rstanPlotTrace(plotData[[i]]), + "stan_scat" = .rstanPlotScat(plotData[[i]]), + "stan_hist" = .rstanPlotHist(plotData[[i]]), + "stan_dens" = .rstanPlotDens(plotData[[i]]), + "stan_ac" = .rstanPlotAcor(plotData[[i]]) + ) if (options$samplingPlot %in% c("stan_hist", "stan_dens")) { p <- jaspGraphs::themeJasp(p, sides = "b") @@ -2792,85 +2472,82 @@ axis.ticks.y = ggplot2::element_blank() ) p <- p + ggplot2::labs(x = varName) - } else{ + } else { p <- jaspGraphs::themeJasp(p) } - if (options$samplingPlot == "stan_trace") { + + if (options$samplingPlot == "stan_trace") p <- p + ggplot2::theme(plot.margin = ggplot2::margin(r = 10 * (nchar(options$iteration - options$warmup) - 2))) - } + plots$plotObject <- p diagnosticPlots[[names(plotData)[i]]] <- plots } + return() } # helper functions .mmVariableNames <- function(varName, variables) { + for (vn in variables) { inf <- regexpr(vn, varName, fixed = TRUE) + if (inf[1] != -1) { varName <- paste0( substr(varName, 0, inf[1] - 1), substr(varName, inf[1], inf[1] + attr(inf, "match.length") - 1), " (", - substr( - varName, - inf[1] + attr(inf, "match.length"), - nchar(varName) - ) + substr(varName, inf[1] + attr(inf, "match.length"), nchar(varName)) ) } + } + varName <- gsub(":", paste0(")", jaspBase::interactionSymbol), varName, fixed = TRUE) varName <- paste0(varName, ")") varName <- gsub(" ()", "", varName, fixed = TRUE) + return(varName) } -.mmAddCoefNameStanova <- function(samples, par, coefs_name){ +.mmAddCoefNameStanova <- function(samples, par, coefsName) { # this is a mess but the stanova::stanova_samples returns an incomplete variable names - coefs_trend <- attr(samples, "estimate") - coefs_trend <- gsub("trend ('", "", coefs_trend, fixed = TRUE) - coefs_trend <- gsub("')", "", coefs_trend, fixed = TRUE) - coefs_trend <- strsplit(coefs_trend, ",") + coefsTrend <- attr(samples, "estimate") + coefsTrend <- gsub("trend ('", "", coefsTrend, fixed = TRUE) + coefsTrend <- gsub("')", "", coefsTrend, fixed = TRUE) + coefsTrend <- strsplit(coefsTrend, ",") - for(cft in coefs_trend){ - if(cft %in% strsplit(par, ":")[[1]] && !grepl(cft, coefs_name)){ - coefs_name <- paste0(coefs_name, jaspBase::interactionSymbol, cft) + for(cft in coefsTrend) { + if (cft %in% strsplit(par, ":")[[1]] && !grepl(cft, coefsName)) { + coefsName <- paste0(coefsName, jaspBase::interactionSymbol, cft) } } - return(coefs_name) - + return(coefsName) } .mmGetPlotSamples <- function(model, pars, options) { - matrix_diff <- - stanova::stanova_samples(model, - return = "array", - diff_intercept = options$show == "deviation") + + matrixDiff <- stanova::stanova_samples(model, return = "array", diff_intercept = options$show == "deviation") if (length(pars) == 1) { - samples <- matrix_diff[[pars]] - coefs <- dim(matrix_diff[[pars]])[2] + samples <- matrixDiff[[pars]] + coefs <- dim(matrixDiff[[pars]])[2] plotData <- list() - for (cf in 1:coefs) { + for (coef in 1:coefs) { - coefs_name <- - paste(unlist( - strsplit(dimnames(samples)$Parameter[cf], ",") - ), collapse = ":") - coefs_name <- gsub(" ", "", coefs_name, fixed = TRUE) - coefs_name <- .mmVariableNames(coefs_name, options$fixedVariables) - coefs_name <- .mmAddCoefNameStanova(samples, pars, coefs_name) + coefsName <- paste(unlist(strsplit(dimnames(samples)$Parameter[coef], ",")), collapse = ":") + coefsName <- gsub(" ", "", coefsName, fixed = TRUE) + coefsName <- .mmVariableNames(coefsName, options$fixedVariables) + coefsName <- .mmAddCoefNameStanova(samples, pars, coefsName) - plotData[[dimnames(samples)$Parameter[cf]]] <- list( + plotData[[dimnames(samples)$Parameter[coef]]] <- list( samp = data.frame( - value = as.vector(samples[, cf,]), - parameter = as.factor(rep(coefs_name, length(as.vector(samples[, cf,])))), + value = as.vector(samples[, coef,]), + parameter = as.factor(rep(coefsName, length(as.vector(samples[, coef,])))), chain = as.factor(c(unlist( sapply(1:dim(samples)[3], function(x) rep(x, dim(samples)[1])) @@ -2883,29 +2560,23 @@ ) } - } else{ - samples1 <- matrix_diff[[pars[1]]] - samples2 <- matrix_diff[[pars[2]]] - coefs1 <- dim(matrix_diff[[pars[1]]])[2] - coefs2 <- dim(matrix_diff[[pars[2]]])[2] + } else { + samples1 <- matrixDiff[[pars[1]]] + samples2 <- matrixDiff[[pars[2]]] + coefs1 <- dim(matrixDiff[[pars[1]]])[2] + coefs2 <- dim(matrixDiff[[pars[2]]])[2] plotData <- list() for (cf1 in 1:coefs1) { for (cf2 in 1:coefs2) { - coefs1Name <- - paste(unlist( - strsplit(dimnames(samples1)$Parameter[cf1], ",") - ), collapse = ":") + coefs1Name <- paste(unlist(strsplit(dimnames(samples1)$Parameter[cf1], ",")), collapse = ":") coefs1Name <- gsub(" ", "", coefs1Name, fixed = TRUE) coefs1Name <- .mmVariableNames(coefs1Name, options$fixedVariables) coefs1Name <- .mmAddCoefNameStanova(samples1, pars[[1]], coefs1Name) - coefs2Name <- - paste(unlist( - strsplit(dimnames(samples2)$Parameter[cf2], ",") - ), collapse = ":") + coefs2Name <- paste(unlist(strsplit(dimnames(samples2)$Parameter[cf2], ",")), collapse = ":") coefs2Name <- gsub(" ", "", coefs2Name, fixed = TRUE) coefs2Name <- .mmVariableNames(coefs2Name, options$fixedVariables) coefs2Name <- .mmAddCoefNameStanova(samples2, pars[[2]], coefs2Name) @@ -2942,127 +2613,116 @@ } return(plotData) - } # as explained in ?is.integer -.is.wholenumber <- - function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol +.is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol # modified rstan plotting functions .rstanPlotHist <- function(plotData) { + dots <- rstan:::.add_aesthetics(list(), c("fill", "color")) thm <- rstan:::rstanvis_hist_theme() - base <- - ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) + base <- ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) graph <- base + do.call(ggplot2::geom_histogram, dots) + ggplot2::xlab("") + thm + ggplot2::xlab(unique(plotData$samp$parameter)) return(graph) } .rstanPlotTrace <- function(plotData) { + thm <- rstan:::rstanvis_theme() - clrs <- - rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plotData$nchains) - base <- - ggplot2::ggplot(plotData$samp, - ggplot2::aes_string(x = "iteration", - y = "value", color = "chain")) - - graph <- - base + ggplot2::geom_path() + ggplot2::scale_color_manual(values = clrs) + + clrs <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), plotData$nchains) + base <- ggplot2::ggplot(plotData$samp,ggplot2::aes_string(x = "iteration", y = "value", color = "chain")) + + graph <- base + ggplot2::geom_path() + ggplot2::scale_color_manual(values = clrs) + ggplot2::labs(x = "", y = levels(plotData$samp$parameter)) + thm graph <- graph + ggplot2::scale_x_continuous( breaks = jaspGraphs::getPrettyAxisBreaks(c(1,max(plotData$samp$iteration)))) - - graph + return(graph) } .rstanPlotDens <- function(plotData, separate_chains = TRUE) { - clrs <- - rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plotData$nchains) + + clrs <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), plotData$nchains) thm <- rstan:::rstanvis_hist_theme() - base <- - ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) + + base <- ggplot2::ggplot(plotData$samp, ggplot2::aes_string(x = "value")) + ggplot2::xlab("") if (!separate_chains) { dots <- rstan:::.add_aesthetics(list(), c("fill", "color")) - graph <- base + do.call(ggplot2::geom_density, dots) + - thm - } else{ + graph <- base + do.call(ggplot2::geom_density, dots) + thm + } else { dots <- rstan:::.add_aesthetics(list(), c("color", "alpha")) dots$mapping <- ggplot2::aes_string(fill = "chain") graph <- base + do.call(ggplot2::geom_density, dots) + ggplot2::scale_fill_manual(values = clrs) + thm } - graph + ggplot2::xlab(unique(plotData$samp$parameter)) + graph <- graph + ggplot2::xlab(unique(plotData$samp$parameter)) + return(graph) } .rstanPlotScat <- function(plotData) { + thm <- rstan:::rstanvis_theme() - dots <- rstan:::.add_aesthetics(list(), c("fill", "pt_color", - "pt_size", "alpha", "shape")) + dots <- rstan:::.add_aesthetics(list(), c("fill", "pt_color", "pt_size", "alpha", "shape")) - p1 <- - plotData$samp$parameter == levels(plotData$samp$parameter)[1] - p2 <- - plotData$samp$parameter == levels(plotData$samp$parameter)[2] + p1 <- plotData$samp$parameter == levels(plotData$samp$parameter)[1] + p2 <- plotData$samp$parameter == levels(plotData$samp$parameter)[2] val1 <- plotData$samp[p1, "value"] val2 <- plotData$samp[p2, "value"] df <- data.frame(x = val1, y = val2) base <- ggplot2::ggplot(df, ggplot2::aes_string("x", "y")) - graph <- - base + do.call(ggplot2::geom_point, dots) + ggplot2::labs( - x = levels(plotData$samp$parameter)[1], - y = levels(plotData$samp$parameter)[2] - ) + thm - graph + graph <- base + do.call(ggplot2::geom_point, dots) + ggplot2::labs( + x = levels(plotData$samp$parameter)[1], + y = levels(plotData$samp$parameter)[2] + ) + thm + return(graph) } .rstanPlotAcor <- function(plotData, lags = 30) { - clrs <- - rep_len(rstan:::rstanvis_aes_ops("chain_colors"), - plotData$nchains) + + clrs <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), plotData$nchains) thm <- rstan:::rstanvis_theme() - dots <- - rstan:::.add_aesthetics(list(), c("size", "color", "fill")) - ac_dat <- - rstan:::.ac_plotData(dat = plotData$samp, - lags = lags, - partial = FALSE) + dots <- rstan:::.add_aesthetics(list(), c("size", "color", "fill")) + acDat <- rstan:::.ac_plotData(dat = plotData$samp, lags = lags, partial = FALSE) dots$position <- "dodge" dots$stat <- "summary" dots$fun.y <- "mean" - y_lab <- gettext("Avg. autocorrelation") - ac_labs <- ggplot2::labs(x = "Lag", y = y_lab) - y_scale <- - ggplot2::scale_y_continuous(breaks = seq(0, 1, 0.25)) - base <- - ggplot2::ggplot(ac_dat, ggplot2::aes_string(x = "lag", y = "ac")) - graph <- - base + do.call(ggplot2::geom_bar, dots) + y_scale + ac_labs + thm - - graph + + graph <- ggplot2::ggplot(acDat, ggplot2::aes_string(x = "lag", y = "ac")) + + do.call(ggplot2::geom_bar, dots) + + ggplot2::scale_y_continuous(breaks = seq(0, 1, 0.25)) + + ggplot2::labs(x = "Lag", y = gettext("Avg. autocorrelation")) + thm + + return(graph) } .mmCustomChecks <- list( - collinCheck = function(dataset){ - cor_mat <- cor(apply(dataset,2,as.numeric)) - diag(cor_mat) <- 0 - cor_mat[lower.tri(cor_mat)] <- 0 - nearOne <- 1 - abs(cor_mat) < sqrt(.Machine$double.eps) - if(any(nearOne)){ - var_ind <- which(nearOne, arr.ind = TRUE) - varNames <- paste("'", rownames(cor_mat)[var_ind[,"row"]],"' and '", colnames(cor_mat)[var_ind[,"col"]],"'", sep = "", collapse = ", ") + collinCheck = function(dataset) { + corMat <- cor(apply(dataset,2,as.numeric)) + diag(corMat) <- 0 + corMat[lower.tri(corMat)] <- 0 + nearOne <- 1 - abs(corMat) < sqrt(.Machine$double.eps) + + if (any(nearOne)) { + varInd <- which(nearOne, arr.ind = TRUE) + varNames <- paste("'", rownames(corMat)[varInd[,"row"]],"' and '", colnames(corMat)[varInd[,"col"]],"'", sep = "", collapse = ", ") return(gettextf("The following variables are a linear combination of each other, please, remove one of them from the analysis: %s", varNames)) } } ) +.mmSwichDependencies <- function(type) { + return(switch( + type, + "LMM" = .mmDependenciesLMM, + "GLMM" = .mmDependenciesGLMM, + "BLMM" = .mmDependenciesBLMM, + "BGLMM" = .mmDependenciesBGLMM, + )) +} .mmDependenciesLMM <- c( "dependentVariable", @@ -3070,14 +2730,16 @@ "randomEffects", "randomVariables", "method", - "bootstrap_samples", + "bootstrapSamples", "test_intercept", "type" ) -.mmDependenciesGLMM <- c(.mmDependenciesLMM, - "dependentVariableAggregation", - "family", - "link") +.mmDependenciesGLMM <- c( + .mmDependenciesLMM, + "dependentVariableAggregation", + "family", + "link" +) .mmDependenciesBLMM <- c( "dependentVariable", @@ -3092,7 +2754,9 @@ "seed", "setSeed" ) -.mmDependenciesBGLMM <- c(.mmDependenciesBLMM, - "dependentVariableAggregation", - "family", - "link") +.mmDependenciesBGLMM <- c( + .mmDependenciesBLMM, + "dependentVariableAggregation", + "family", + "link" +) diff --git a/R/MixedModelsMessages.R b/R/MixedModelsMessages.R index 4ef8455b..7af3c965 100644 --- a/R/MixedModelsMessages.R +++ b/R/MixedModelsMessages.R @@ -99,7 +99,7 @@ .mmMessageGLMMtype <- function(family, link) { family <- switch(family, "binomial" = gettext("binomial"), - "binomial_agg" = gettext("binomial"), + "binomialAgg" = gettext("binomial"), "gaussian" = gettext("gaussian"), "Gamma" = gettext("gamma"), "inverse.gaussian" = gettext("inverse gaussian"), diff --git a/dataset.RDS b/dataset.RDS new file mode 100644 index 0000000000000000000000000000000000000000..c81981ec9b780e36de54f7e905d276e34bab9fce GIT binary patch literal 2452 zcmV;F32XKriwFP!000002JKd9R8&V6uD5`)BQ6Mnt%tDao?AyQInt;fjByGSI}URaa@Q>+NgvmsDMcKH2Q8msHVY* zp7}AyKIiMN)_ZT=d+XMVvP1}Rh-VD{W`-s*4~~>8d=!RmS3{3Cz!o895XM=}vj_*F zXRJo8`!EkY2(@N`Vinc*6#0)P*iGa551M+~?Ci-wb zg~&etqZs@UNHL5<y_B+kqR9{Zn0}OSGt_PsMAGIFxlg?wXADfWZQGEuc z;|u4d?WXHK=nXP4E>L}l2jmCDk4DvjvecmEN9?GzqwUmzds5aq(psP2PZrs^ihHx*y7ldfBkPxc~% z{?3%W;9oClUr<(SdqF?=mG%?#As=BseIH<){@!q<&I|q{^+{xP>v<%8??FeXi*KBf zF!_$~B=-Ox)9aqlG~&V4)&BW{&aq4vkzp_BL-NkJ-_Z;D!bz6VLvLd>{T-p~1PK4wpivU_i{CFa8Qp~dVR%-v0Xx5_U`;_Bg+p2}Lx zk9N=8zE}lJ?73@YWtDzb5Nh|{^@;dvzVOh!EFm&_y-;^$UAL&ITA`u-qLA+IA~cHY zo}>)>x~N<)G^tnlj*It_>^*hCBXwITW^TCsrOT!Cc;neDf~3m}@wI$2xV#eCXaeTaSfFdb>wW zvdYy74YSajk)29~rr!T{wqBVeG@X}i+*lAN=u&JyN?V;N=zFica&ls|px<(2ZuyO+ z7+c50BEDdw-XB4Mpbj92+pM-g(hDqmF zhJWD{JQnlgaMbDG^Pm?qH^!HkJ$g)-53g`{()ts-9?r>CrEjj5;-p=hlD1tZ#R*tD z!B?4_LF|OMH8Ec#FH@EYO$oo652)4&O@*7n)-TK;`7N@Pzw!@uZ5dcb^w(Sn?ULwd zh?n;2zM`Kp2!o%18w+pDzxj=h=+h0b*V@QFmGZG|#%R-<$M0Vf2r~=LZs-~E6=vtS z#OD9q3iEy|%ojN9A@)4Dz+ZH~mPPWP#O0YjY2B>jqZ^Od8|8Pyxkocu>nP!gws-w+ zzQkUL57}QE(lv7Z2YTZF2FG#xv=g(Wd!a_5c|p@8f7TXkt+bnkxow*RoTFWg;wZ+) z=sb{j;6JEC^gV-oW{*S`XP+?C5BnY^*u_q&W9~U#)^E6g9wR@19xzA=A zW%yL zwSU8WaJNIFR_rv2Pu->=Kj%HnB=OKk4Lp^eo{Z6|gA=mvUnb{d4k8hL7#D}p=v@rX4cH^nNoNivxzk}b^XU;E-QON{R2zL56q7(xIFj#K_aJ0%vUNO zF-k0mb99i=`Gk?OJf~#$B+RZE-Ed*`M$8@?wSR;&#@vrK*N0s^W#mW5V|~KzlXnkf zVstrIyLi!I>HY953NP)OjoHOxOJk z#r)7zC%&^_Bv<^d!Km}4E%iBo;dHKaY*ENt5CreqWG2oCEH^zS>2WzHd547xS%_@4Acm$WDC~j{?bh$Yb$6!;F08 z>A_L9M(3#S-qY@^Lh?){RIW>8v zp`~k4V7t8}borgIdjXigBy@iPm{EAq3vT_Az_$VC4$$K{(K2Bjp92;xVA}!uim>be zy;`8N33UA(aOway&jE)v(9;C0o)euY*mnSq!fPGCr497%0IyT%(+*rsz^xs;A)=oN zxKsE;8}KkjbE#zXqMtm(>d45Up@4>u*kI)f(()xOHEC&}rBIO;S*Mhf7LlSP>y$)? zl1NdJ9X@2tmuORySvA?KChPpXNsH|8BeNPZt05L>U>zs-_LiD0Mm3}0 zeWa$eO(AVl$fc%2YD&Tsk}!i0pN5KsP__AxwSM=KVyDN$yT^-zJ;GyC{t}#=IBR-R zjF-|YCNybsa$I~|TeF&WXZ_lp^_FH^8)Y#wIn4_UYc3CL7Ha-AKfi6B&oVAHHP&m& SOv9GuGyVq}wroufApiiD;qVp! literal 0 HcmV?d00001 diff --git a/inst/qml/MixedModelsBGLMM.qml b/inst/qml/MixedModelsBGLMM.qml index 6450bc51..80e06216 100644 --- a/inst/qml/MixedModelsBGLMM.qml +++ b/inst/qml/MixedModelsBGLMM.qml @@ -81,7 +81,7 @@ Form { values: [ { label: qsTr("Binomial"), value: "binomial"}, - { label: qsTr("Binomial (aggregated)"), value: "binomial_agg"}, + { label: qsTr("Binomial (aggregated)"), value: "binomialAgg"}, { label: qsTr("Gaussian"), value: "gaussian"}, { label: qsTr("Gamma"), value: "Gamma"}, { label: qsTr("Inverse Gaussian"), value: "inverse.gaussian"}, diff --git a/inst/qml/MixedModelsGLMM.qml b/inst/qml/MixedModelsGLMM.qml index 677f1c9e..5bffe7a7 100644 --- a/inst/qml/MixedModelsGLMM.qml +++ b/inst/qml/MixedModelsGLMM.qml @@ -82,7 +82,7 @@ Form { values: [ { label: qsTr("Binomial"), value: "binomial"}, - { label: qsTr("Binomial (aggregated)"), value: "binomial_agg"}, + { label: qsTr("Binomial (aggregated)"), value: "binomialAgg"}, { label: qsTr("Gaussian"), value: "gaussian"}, { label: qsTr("Gamma"), value: "Gamma"}, { label: qsTr("Inverse Gaussian"), value: "inverse.gaussian"}, @@ -92,7 +92,7 @@ Form { property var familyMap: { "binomial": ["logit", "probit", "cauchit", "cloglog", "log"], - "binomial_agg": ["logit", "probit", "cauchit", "cloglog", "log"], + "binomialAgg": ["logit", "probit", "cauchit", "cloglog", "log"], "gaussian": ["identity", "log", "inverse"], "Gamma": ["identity", "log", "inverse"], "inverse.gaussian": ["identity", "log", "inverse"], @@ -102,7 +102,7 @@ Form { property var familyDefault: { "binomial": "logit", - "binomial_agg": "logit", + "binomialAgg": "logit", "gaussian": "identity", "Gamma": "log", "inverse.gaussian": "log", diff --git a/inst/qml/common/MixedModelsOptions.qml b/inst/qml/common/MixedModelsOptions.qml index 6420bff1..b85fccf9 100644 --- a/inst/qml/common/MixedModelsOptions.qml +++ b/inst/qml/common/MixedModelsOptions.qml @@ -69,7 +69,7 @@ Section IntegerField { enabled: method.currentValue == "PB" - name: "bootstrap_samples" + name: "bootstrapSamples" label: qsTr("No. samples") defaultValue: 500 min: 100 diff --git a/options.RDS b/options.RDS new file mode 100644 index 0000000000000000000000000000000000000000..76f6d653b6314be551a87ed9b358d3dc6e4d38be GIT binary patch literal 913 zcmV;C18)2uiwFP!000002JKc)Z__Xo&-!PyUD-M|_yn9Mwh3vR*3osaX%p2_!ETjl z+{BRBQS5db2fhbf_z0Z&9DD~PE{G$if#cYzoi$svRh(w2b^PA*@4dW#c_%f?vWiw| zj{leWqcz{^tZzKsu&lxgKW)jqA$Klj)#T29rGnT?R+aB%3<5|K;gndX9vS*h8~2F= z`S~IrXzuUb-MhPYcmKy-L#`p^sx5+91Sq4Dupfl*S2Lsqo zg%<@)2`cLS07Ndrz(0ZjE8>IDCyeg65p)5A&Z`lOB&Q}g9e|;4P`VN5E9LWoa-tMO z06QcwZCOf)S!0$d2tprWS25P}7#j+RMce^2>zIXv+>QTD$+1e|XDg0TycXklZ2$Ze zug~h-tXOL4@p^OsXxJkDFu=XF&9z<gmXIhmWq2{@|03K?FmcXDe@JO~DF>p>8T6$wT?Y_D(;;-ZXFG%< z%@+dbSY-bQ+USF_V>L_f!ZW5DeF=WzOeSFHbI|AAoeZ(VD}+S)t8!2CeDR3t3Ux`; z-M=DeZOTx<;b~XP3SkP3{iX6p5RO0?@`+5>*3cPy$oCBkCH)X#*gX&7Brw|pDI<5( z^k87h%x3tks~NMy5pFz?mMBcS?>!2cJwBHBn18CwjGy<~`srAms&p9ed_QmPtGAFt nt`V?BbMn1<9AlBL literal 0 HcmV?d00001 diff --git a/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-1.svg b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-1.svg index 0383ae5c..d43de3a6 100644 --- a/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-1.svg +++ b/tests/testthat/_snaps/mixedmodelsglmm/plot-glmm-1.svg @@ -78,8 +78,8 @@ 1 2 -JaspColumn_.1._Encoded -JaspColumn_.5._Encoded +Variable1 +Variable5 plot-glmm-1 diff --git a/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-1.svg b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-1.svg index 3c03baad..f371de81 100644 --- a/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-1.svg +++ b/tests/testthat/_snaps/mixedmodelslmm/plot-lmm-1.svg @@ -117,8 +117,8 @@ 1 2 -JaspColumn_.1._Encoded -JaspColumn_.4._Encoded +Variable1 +Variable4 plot-lmm-1 diff --git a/tests/testthat/test-mixedmodelsglmm.R b/tests/testthat/test-mixedmodelsglmm.R index f5f94fd5..c4496254 100644 --- a/tests/testthat/test-mixedmodelsglmm.R +++ b/tests/testthat/test-mixedmodelsglmm.R @@ -15,14 +15,14 @@ context("Generalized Linear Mixed Models") "0", "0")), list(isContrast = TRUE, levels = c("1", "2", "3", "4", "5", "6"), name = "Contrast 2", values = c("1", "-1", "0", "0", "0", "0"))) - options$bootstrap_samples <- 500 - options$dependentVariable <- "JaspColumn_.5._Encoded" + options$bootstrapSamples <- 500 + options$dependentVariable <- "Variable5" options$fitStats <- TRUE - options$fixedEffects <- list(list(components = "JaspColumn_.1._Encoded"), list(components = "JaspColumn_.7._Encoded"), - list(components = c("JaspColumn_.1._Encoded", "JaspColumn_.7._Encoded" + options$fixedEffects <- list(list(components = "Variable1"), list(components = "Variable7"), + list(components = c("Variable1", "Variable7" ))) - options$fixedVariables <- c("JaspColumn_.1._Encoded", "JaspColumn_.7._Encoded") - options$marginalMeans <- list(list(variable = "JaspColumn_.1._Encoded"), list(variable = "JaspColumn_.7._Encoded")) + options$fixedVariables <- c("Variable1", "Variable7") + options$marginalMeans <- list(list(variable = "Variable1"), list(variable = "Variable7")) options$marginalMeansContrast <- TRUE options$method <- "LRT" options$plotAlpha <- 0.7 @@ -33,7 +33,7 @@ context("Generalized Linear Mixed Models") options$plotLegendPosition <- "none" options$plotRelativeSize <- 1 options$plotRelativeSizeText <- 1.5 - options$plotsAgregatedOver <- "JaspColumn_.0._Encoded" + options$plotsAgregatedOver <- "Variable0" options$plotsBackgroundColor <- "darkgrey" options$plotsCImethod <- "model" options$plotsCIwidth <- 0.95 @@ -46,13 +46,13 @@ context("Generalized Linear Mixed Models") options$plotsPanel <- list() options$plotsTheme <- "JASP" options$plotsTrace <- list() - options$plotsX <- list(list(variable = "JaspColumn_.1._Encoded")) + options$plotsX <- list(list(variable = "Variable1")) options$pvalVS <- FALSE options$randomEffects <- list( list(correlations = TRUE, - randomComponents = list(list(randomSlopes = TRUE, value = "JaspColumn_.1._Encoded")), - value = "JaspColumn_.0._Encoded")) - options$randomVariables <- "JaspColumn_.0._Encoded" + randomComponents = list(list(randomSlopes = TRUE, value = "Variable1")), + value = "Variable0")) + options$randomVariables <- "Variable0" options$seed <- 1 options$setSeed <- FALSE options$showFE <- TRUE @@ -63,12 +63,12 @@ context("Generalized Linear Mixed Models") options$trendsContrasts <- list(list(isContrast = FALSE, levels = c("1", "2"), name = "cA", values = c("1", "2")), list(isContrast = TRUE, levels = c("1", "2"), name = "Contrast 1", values = c("-1", "1"))) - options$trendsTrend <- list(list(variable = "JaspColumn_.7._Encoded")) - options$trendsVariables <- list(list(variable = "JaspColumn_.1._Encoded")) + options$trendsTrend <- list(list(variable = "Variable7")) + options$trendsVariables <- list(list(variable = "Variable1")) options$type <- "3" options$link <- "logit" set.seed(1) - dataset <- structure(list(JaspColumn_.0._Encoded = c(1L, 2L, 3L, 4L, 5L, + dataset <- structure(list(Variable0 = c(1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, @@ -88,7 +88,7 @@ context("Generalized Linear Mixed Models") 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L), JaspColumn_.1._Encoded = c(1L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L), Variable1 = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, @@ -107,7 +107,7 @@ context("Generalized Linear Mixed Models") 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), JaspColumn_.2._Encoded = c(1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), Variable2 = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, @@ -126,7 +126,7 @@ context("Generalized Linear Mixed Models") 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), JaspColumn_.3._Encoded = c(1L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), Variable3 = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, @@ -145,7 +145,7 @@ context("Generalized Linear Mixed Models") 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L), JaspColumn_.4._Encoded = c(-0.653989689, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L), Variable4 = c(-0.653989689, 0.597847379, 0.53124944, -0.919283666, 1.549214002, -0.964337181, 0.758624407, -0.633353539, 0.093434858, 0.081944247, 1.251310302, 1.399815493, -0.942716455, -0.495601118, 0.917930091, 0.344838602, @@ -205,7 +205,7 @@ context("Generalized Linear Mixed Models") -1.502343948, -1.37596223, 0.74894869, 0.664588217, 1.321486377, 1.888462109, -0.903168893, -3.201437624, -0.535609031, 0.554010178, -0.547718747, 1.542488798, 1.851156869, 0.154379085, 0.617288371, - 1.273637679, -1.466949312, -0.150368723, -0.256217966), JaspColumn_.5._Encoded = c(1L, + 1.273637679, -1.466949312, -0.150368723, -0.256217966), Variable5 = c(1L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, @@ -224,7 +224,7 @@ context("Generalized Linear Mixed Models") 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 1L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 0L, - 0L, 1L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L), JaspColumn_.6._Encoded = c(2L, + 0L, 1L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L), Variable6 = c(2L, 2L, 4L, 3L, 8L, 0L, 2L, 1L, 1L, 1L, 6L, 4L, 0L, 1L, 2L, 1L, 0L, 0L, 4L, 1L, 0L, 1L, 3L, 10L, 3L, 1L, 1L, 1L, 2L, 1L, 2L, 0L, 2L, 0L, 3L, 4L, 2L, 1L, 0L, 2L, 1L, 1L, 0L, 2L, 0L, 1L, 0L, 1L, @@ -244,7 +244,7 @@ context("Generalized Linear Mixed Models") 0L, 0L, 0L, 0L, 18L, 10L, 4L, 12L, 0L, 9L, 1L, 1L, 1L, 0L, 3L, 3L, 0L, 0L, 0L, 4L, 1L, 1L, 4L, 1L, 0L, 4L, 5L, 14L, 2L, 1L, 1L, 3L, 0L, 0L, 2L, 2L, 5L, 9L, 0L, 0L, 2L, 1L, 0L, 3L, 6L, 0L, - 4L, 6L, 0L, 1L, 1L), JaspColumn_.7._Encoded = c(0.427219425, + 4L, 6L, 0L, 1L, 1L), Variable7 = c(0.427219425, 0.220688309, 0.570053273, 0.231100824, 0.131067892, 1, 0.076567255, 0.405903343, 0.474725634, 0.990018262, 0.192843674, 0.224774893, 1, 0.740614383, 0.851823829, 0.653432541, 1, 1, 0.624686075, @@ -296,9 +296,9 @@ context("Generalized Linear Mixed Models") test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, - list(1, "JaspColumn_.1._Encoded", 0.991431110310274, 0.000115341522132439, - 1, "JaspColumn_.7._Encoded", 0.0187024090268013, 5.5291293975402, - 1, "JaspColumn_.1._Encoded * JaspColumn_.7._Encoded", 0.528941241360197, + list(1, "Variable1", 0.991431110310274, 0.000115341522132439, + 1, "Variable7", 0.0187024090268013, 5.5291293975402, + 1, "Variable1 * Variable7", 0.528941241360197, 0.396425180671656)) }) @@ -329,16 +329,16 @@ context("Generalized Linear Mixed Models") jaspTools::expect_equal_tables(table, list(1.01114715607801, 0.188755680199758, 0.769360854494757, 1.31426904575492, "Intercept", 0.00493804175582078, 0.991565307672846, 0.467108193062088, - 0.0105715160409623, "JaspColumn_.1._Encoded", -2.50123804213005, - 0.0208986439411648, 1.08287583244124, -2.30981056848527, "JaspColumn_.7._Encoded", + 0.0105715160409623, "Variable1", -2.50123804213005, + 0.0208986439411648, 1.08287583244124, -2.30981056848527, "Variable7", 0.43017430669552, 0.528658632555254, 0.682756807631676, 0.630054950587302, - "JaspColumn_.1._Encoded * JaspColumn_.7._Encoded")) + "Variable1 * Variable7")) }) - test_that("JaspColumn_.0._Encoded: Correlation Estimates table results match", { + test_that("Variable0: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE1"]][["data"]] jaspTools::expect_equal_tables(table, - list(1, "Intercept", -0.860597215248448, 1, "JaspColumn_.1._Encoded" + list(1, "Intercept", -0.860597215248448, 1, "Variable1" )) }) @@ -348,15 +348,15 @@ context("Generalized Linear Mixed Models") list(1, 1)) }) - test_that("JaspColumn_.0._Encoded: Variance Estimates table results match", { + test_that("Variable0: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0.889188580238109, 0.790656331225863, "Intercept", 0.470404764148096, - 0.221280642133226, "JaspColumn_.1._Encoded")) + 0.221280642133226, "Variable1")) }) test_that("Contrasts table results match", { - table <- results[["results"]][["contrasts_Means"]][["data"]] + table <- results[["results"]][["contrastsMeans"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", "", 0.209335420026882, 0.0163060641315532, 0.0791239089261232, 2.64566580276431, "Contrast 2", @@ -365,7 +365,7 @@ context("Generalized Linear Mixed Models") }) test_that("Contrasts table results match", { - table <- results[["results"]][["contrasts_Trends"]][["data"]] + table <- results[["results"]][["contrastsTrends"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", "", 0.430174306695523, 0.528658632555254, 0.68275680763168, 0.630054950587302)) @@ -412,7 +412,7 @@ context("Generalized Linear Mixed Models") "-1", "0", "0", "0", "0")), list(isContrast = TRUE, levels = c("2", "3", "4", "5", "6", "7"), name = "Contrast 2", values = c("0", "1", "-1", "0", "0", "0"))) - options$bootstrap_samples <- 500 + options$bootstrapSamples <- 500 options$dependentVariable <- "contBinom" options$fitStats <- TRUE options$fixedEffects <- list(list(components = "contNormal"), list(components = "facGender"), @@ -525,7 +525,7 @@ context("Generalized Linear Mixed Models") }) test_that("Contrasts table results match", { - table <- results[["results"]][["contrasts_Means"]][["data"]] + table <- results[["results"]][["contrastsMeans"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", "", 0.25187564641617, 0.294980047829034, 0.24050936605887, 1.04725920051911, "Contrast 2", @@ -561,7 +561,7 @@ context("Generalized Linear Mixed Models") "3"), name = "Contrast 1", values = c("1", "0")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 2", values = c("0", "0"))) - options$bootstrap_samples <- 10 + options$bootstrapSamples <- 10 options$dependentVariable <- "contGamma" options$family <- "Gamma" options$fitStats <- FALSE @@ -679,7 +679,7 @@ context("Generalized Linear Mixed Models") }) test_that("Contrasts table results match", { - table <- results[["results"]][["contrasts_Means"]][["data"]] + table <- results[["results"]][["contrastsMeans"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", "", 0.587430349612986, 6.35907081922447e-08, 0.108614466701096, 5.408398783834)) @@ -698,7 +698,7 @@ context("Generalized Linear Mixed Models") options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", values = c("f", "m")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 1", values = c("0", "0"))) - options$bootstrap_samples <- 10 + options$bootstrapSamples <- 10 options$dependentVariable <- "facFifty" options$family <- "poisson" options$fitStats <- FALSE @@ -801,10 +801,10 @@ context("Generalized Linear Mixed Models") options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "cA", values = c("1", "2")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 1", values = c("-1", "1"))) - options$bootstrap_samples <- 500 + options$bootstrapSamples <- 500 options$dependentVariable <- "binom_mean" options$dependentVariableAggregation <- "rep" - options$family <- "binomial_agg" + options$family <- "binomialAgg" options$fitStats <- TRUE options$fixedEffects <- list(list(components = "cA"), list(components = "cB"), list(components = c("cA", "cB"))) @@ -870,35 +870,34 @@ context("Generalized Linear Mixed Models") 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L)), class = "data.frame", row.names = c(NA, -60L)) - results <- jaspTools::runAnalysis("MixedModelsGLMM", dataset, options) + results <- jaspTools::runAnalysis("MixedModelsGLMM", dataset = dataset, options) test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "cA", 0.768666971055732, 0.0865059874772953, 1, "cB", 0.479800725027522, - 0.499316216168296, 1, "cA * cB", 0.859034817019825, 0.0315428035947605 - )) + 0.499316216168296, 1, "cAcB", + 0.859034817019825, 0.0315428035947605)) }) - # rounding due to problems on MacOS test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] - jaspTools::expect_equal_tables(sapply(as.numeric(unlist(table)), round, 3, simplify = F), - sapply(list(1, 0.521559047720783, 0.41115145068317, 1, 0.0567190036068068, - 0.629899750093515, 2, 0.543534580013736, 0.424298904623603, - 2, 0.0607273848025058, 0.657981320465884), round, 3, simplify = F)) + jaspTools::expect_equal_tables(table, + list(1, 0.521559047720783, 0.41115145068317, 1, 0.0567190036068068, + 0.629899750093515, 2, 0.543534580013736, 0.424298904623603, + 2, 0.0607273848025058, 0.657981320465884)) }) - # rounding due to problems on MacOS test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] - jaspTools::expect_equal_tables(sapply(as.numeric(unlist(table)), round, 3, simplify = F), - sapply(as.numeric(c(0.661160396272512, 0.526032009864107, 1.04271672627264, 0.634074796743634, + jaspTools::expect_equal_tables(table, + list(0.661160396272512, 0.526032009864107, 1.04271672627264, 0.634074796743634, "Intercept", 0.194569016770762, 0.768524273472735, 0.661111825925663, 0.294305757574876, "cA", -0.331580696152255, 0.480882470945843, 0.470404674525666, -0.704883931025144, "cB", -0.0531391637884625, - 0.858923106746129, 0.298962625751381, -0.177745173514275, "cA * cB")), round, 3, simplify = F)) + 0.858923106746129, 0.298962625751381, -0.177745173514275, "cAcB" + )) }) test_that("id: Correlation Estimates table results match", { @@ -921,7 +920,7 @@ context("Generalized Linear Mixed Models") }) test_that("Contrasts table results match", { - table <- results[["results"]][["contrasts_Means"]][["data"]] + table <- results[["results"]][["contrastsMeans"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", "", 0.021975532292953, 0.74419933094708, 0.0673481619405325, 0.326297432027278)) diff --git a/tests/testthat/test-mixedmodelslmm.R b/tests/testthat/test-mixedmodelslmm.R index a2053ca0..9d300e8a 100644 --- a/tests/testthat/test-mixedmodelslmm.R +++ b/tests/testthat/test-mixedmodelslmm.R @@ -3,39 +3,39 @@ context("Linear Mixed Models") ### default, all selected output using Satterwhite method { options <- jaspTools::analysisOptions("MixedModelsLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("1", "2", "3", "4", - "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", - "16", "17", "18"), name = "cA", values = c("1", "2", "1", "2", - "1", "2", "1", "2", "1", "2", "1", "2", "1", "2", "1", "2", "1", - "2")), list(isContrast = FALSE, levels = c("1", "2", "3", "4", - "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", - "16", "17", "18"), name = "cB", values = c("1", "1", "2", "2", - "3", "3", "1", "1", "2", "2", "3", "3", "1", "1", "2", "2", "3", - "3")), list(isContrast = FALSE, levels = c("1", "2", "3", "4", - "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", - "16", "17", "18"), name = "y_beta", values = c("-1", "-1", "-1", - "-1", "-1", "-1", "0", "0", "0", "0", "0", "0", "1", "1", "1", - "1", "1", "1")), list(isContrast = TRUE, levels = c("1", "2", - "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", - "15", "16", "17", "18"), name = "Contrast 1", values = c("1", - "-1", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", - "0", "0", "0", "0", "0")), list(isContrast = TRUE, levels = c("1", - "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", - "14", "15", "16", "17", "18"), name = "Contrast 2", values = c("0", - "1", "-1", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("1", "2", "3", "4", + "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", + "16", "17", "18"), name = "cA", values = c("1", "2", "1", "2", + "1", "2", "1", "2", "1", "2", "1", "2", "1", "2", "1", "2", "1", + "2")), list(isContrast = FALSE, levels = c("1", "2", "3", "4", + "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", + "16", "17", "18"), name = "cB", values = c("1", "1", "2", "2", + "3", "3", "1", "1", "2", "2", "3", "3", "1", "1", "2", "2", "3", + "3")), list(isContrast = FALSE, levels = c("1", "2", "3", "4", + "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", + "16", "17", "18"), name = "y_beta", values = c("-1", "-1", "-1", + "-1", "-1", "-1", "0", "0", "0", "0", "0", "0", "1", "1", "1", + "1", "1", "1")), list(isContrast = TRUE, levels = c("1", "2", + "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", + "15", "16", "17", "18"), name = "Contrast 1", values = c("1", + "-1", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", + "0", "0", "0", "0", "0")), list(isContrast = TRUE, levels = c("1", + "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", + "14", "15", "16", "17", "18"), name = "Contrast 2", values = c("0", + "1", "-1", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0"))) - options$bootstrap_samples <- 500 - options$dependentVariable <- "JaspColumn_.4._Encoded" + options$bootstrapSamples <- 500 + options$dependentVariable <- "Variable4" options$fitStats <- TRUE - options$fixedEffects <- list(list(components = "JaspColumn_.1._Encoded"), list(components = "JaspColumn_.2._Encoded"), - list(components = c("JaspColumn_.1._Encoded", "JaspColumn_.2._Encoded" - )), list(components = "JaspColumn_.7._Encoded"), list(components = c("JaspColumn_.1._Encoded", - "JaspColumn_.7._Encoded")), list(components = c("JaspColumn_.2._Encoded", - "JaspColumn_.7._Encoded")), list(components = c("JaspColumn_.1._Encoded", - "JaspColumn_.2._Encoded", "JaspColumn_.7._Encoded"))) - options$fixedVariables <- c("JaspColumn_.1._Encoded", "JaspColumn_.2._Encoded", "JaspColumn_.7._Encoded") - options$marginalMeans <- list(list(variable = "JaspColumn_.1._Encoded"), list(variable = "JaspColumn_.2._Encoded"), - list(variable = "JaspColumn_.7._Encoded")) + options$fixedEffects <- list(list(components = "Variable1"), list(components = "Variable2"), + list(components = c("Variable1", "Variable2" + )), list(components = "Variable7"), list(components = c("Variable1", + "Variable7")), list(components = c("Variable2", + "Variable7")), list(components = c("Variable1", + "Variable2", "Variable7"))) + options$fixedVariables <- c("Variable1", "Variable2", "Variable7") + options$marginalMeans <- list(list(variable = "Variable1"), list(variable = "Variable2"), + list(variable = "Variable7")) options$marginalMeansCompare <- TRUE options$marginalMeansContrast <- TRUE options$method <- "S" @@ -47,7 +47,7 @@ context("Linear Mixed Models") options$plotLegendPosition <- "none" options$plotRelativeSize <- 1 options$plotRelativeSizeText <- 1.5 - options$plotsAgregatedOver <- "JaspColumn_.0._Encoded" + options$plotsAgregatedOver <- "Variable0" options$plotsBackgroundColor <- "darkgrey" options$plotsCImethod <- "model" options$plotsCIwidth <- 0.95 @@ -59,276 +59,276 @@ context("Linear Mixed Models") options$plotsMappingShape <- TRUE options$plotsPanel <- list() options$plotsTheme <- "JASP" - options$plotsTrace <- list(list(variable = "JaspColumn_.2._Encoded")) - options$plotsX <- list(list(variable = "JaspColumn_.1._Encoded")) + options$plotsTrace <- list(list(variable = "Variable2")) + options$plotsX <- list(list(variable = "Variable1")) options$pvalVS <- FALSE - options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = TRUE, - value = "JaspColumn_.1._Encoded"), list(randomSlopes = FALSE, - value = "JaspColumn_.2._Encoded"), list(randomSlopes = FALSE, - value = c("JaspColumn_.1._Encoded", "JaspColumn_.2._Encoded" - )), list(randomSlopes = FALSE, value = "JaspColumn_.7._Encoded"), - list(randomSlopes = FALSE, value = c("JaspColumn_.1._Encoded", - "JaspColumn_.7._Encoded")), list(randomSlopes = FALSE, value = c("JaspColumn_.2._Encoded", - "JaspColumn_.7._Encoded")), list(randomSlopes = FALSE, value = c("JaspColumn_.1._Encoded", - "JaspColumn_.2._Encoded", "JaspColumn_.7._Encoded"))), value = "JaspColumn_.0._Encoded")) - options$randomVariables <- "JaspColumn_.0._Encoded" + options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = TRUE, + value = "Variable1"), list(randomSlopes = FALSE, + value = "Variable2"), list(randomSlopes = FALSE, + value = c("Variable1", "Variable2" + )), list(randomSlopes = FALSE, value = "Variable7"), + list(randomSlopes = FALSE, value = c("Variable1", + "Variable7")), list(randomSlopes = FALSE, value = c("Variable2", + "Variable7")), list(randomSlopes = FALSE, value = c("Variable1", + "Variable2", "Variable7"))), value = "Variable0")) + options$randomVariables <- "Variable0" options$seed <- 1 options$setSeed <- FALSE options$showFE <- TRUE options$showRE <- TRUE options$test_intercept <- FALSE options$trendsContrast <- TRUE - options$trendsContrasts <- list(list(isContrast = FALSE, levels = c("1", "2", "3", "4", + options$trendsContrasts <- list(list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", "6"), name = "cB", values = c("1", "2", "3", "1", "2", "3" - )), list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", - "6"), name = "cA", values = c("1", "1", "1", "2", "2", "2")), - list(isContrast = TRUE, levels = c("1", "2", "3", "4", "5", - "6"), name = "Contrast 1", values = c("1", "-1", "0", "0", - "0", "0")), list(isContrast = TRUE, levels = c("1", "2", - "3", "4", "5", "6"), name = "Contrast 2", values = c("0", + )), list(isContrast = FALSE, levels = c("1", "2", "3", "4", "5", + "6"), name = "cA", values = c("1", "1", "1", "2", "2", "2")), + list(isContrast = TRUE, levels = c("1", "2", "3", "4", "5", + "6"), name = "Contrast 1", values = c("1", "-1", "0", "0", + "0", "0")), list(isContrast = TRUE, levels = c("1", "2", + "3", "4", "5", "6"), name = "Contrast 2", values = c("0", "1", "0", "0", "0", "0"))) - options$trendsTrend <- list(list(variable = "JaspColumn_.7._Encoded")) - options$trendsVariables <- list(list(variable = "JaspColumn_.2._Encoded"), list(variable = "JaspColumn_.1._Encoded")) + options$trendsTrend <- list(list(variable = "Variable7")) + options$trendsVariables <- list(list(variable = "Variable2"), list(variable = "Variable1")) options$type <- "3" set.seed(1) - dataset <- structure(list(JaspColumn_.0._Encoded = c(1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, - 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, - 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L), JaspColumn_.1._Encoded = c(1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), JaspColumn_.2._Encoded = c(1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), JaspColumn_.3._Encoded = c(1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, - 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, - 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, - 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, - 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L), JaspColumn_.4._Encoded = c(-0.653989689, - 0.597847379, 0.53124944, -0.919283666, 1.549214002, -0.964337181, - 0.758624407, -0.633353539, 0.093434858, 0.081944247, 1.251310302, - 1.399815493, -0.942716455, -0.495601118, 0.917930091, 0.344838602, - -1.226474961, -1.405114801, 0.686194991, 0.017571144, -0.337816215, - 0.384985065, 1.430491376, 1.866825203, 0.752814251, 1.31909783, - 0.447452196, -1.346206879, 0.479402493, -0.848513454, 0.850545592, - -3.037579176, 0.545769791, -1.182557897, -0.128004891, 1.11267647, - 0.616535768, -0.669227302, 0.076114909, 0.816454623, 0.422781459, - -0.094856662, -0.374461304, 0.691431944, -1.528712893, 1.05380469, - -0.545337415, -0.026770503, -2.189233221, -0.616004017, 1.150339483, - -0.133211268, 0.252652295, 1.399980471, -0.513151105, 1.117392323, - -0.610869543, 0.331300534, -0.992903801, -0.895568118, 0.623585941, - 1.05882918, -1.58627026, 0.947877674, 2.033833295, 0.179956552, - 1.573438425, -1.694333909, 1.079726669, 1.508240792, 0.90600351, - -0.290763172, -0.496024515, 1.946237186, -0.893948592, 0.830769682, - 0.440062416, -0.57837005, 1.790515054, 0.137924932, 0.055424081, - 0.547806104, -0.748529992, 1.71335853, 1.808028443, 0.017313744, - 0.988861738, -1.43975293, 0.338108584, -0.365015598, 1.86933575, - 1.699421632, 0.308476418, 1.556020356, -0.952816041, 1.874185874, - 1.104225239, -1.318714635, 1.431532182, 0.756206118, 1.892566353, - -0.933657521, 1.277498726, 0.407372551, 1.021542579, 0.74476069, - 0.571588797, -0.762850791, -2.287992665, -0.596915582, 2.920177191, - -0.853565433, -0.771818751, 0.492465518, -0.455610621, 2.667902824, - 1.953870427, 0.14233637, -1.188999386, -0.185194402, 2.751932451, - 0.1714291, 0.495442662, 0.007490023, -1.381723611, -0.360288418, - 1.228175718, 1.270669023, -0.317481349, -1.121300988, 0.248833912, - -0.936079972, -0.019929997, -0.752375481, 1.745747293, 0.005492604, - 0.407922866, 0.061474844, 0.69299688, 0.597159811, 2.949895836, - -0.24811046, 0.034494308, -0.78621074, 0.614844377, 1.095323201, - 0.672793259, 0.057114702, 0.072950494, 0.346984663, -0.452874548, - -0.114694466, 0.536167379, 2.672375374, 0.618138653, 2.749195306, - 2.199564155, -1.821705402, 0.662389551, -0.086448818, 2.350030519, - 1.42969294, -0.082903446, 1.526255915, -0.77415644, 1.646198365, - 0.550819959, -1.912875322, -0.170004512, -0.153966373, 3.216473665, - -2.384187974, 0.730941972, -0.065087507, 1.330153598, 1.27618167, - 1.956183459, 0.436215424, -1.232486611, -0.455381093, 0.83128861, - 0.152153259, -0.45491991, -0.256058166, -0.193076508, -0.334064589, - 0.215860632, -1.749746886, 0.358765965, 0.211328495, -0.112055855, - 0.945593904, 0.532860661, 0.01631963, -0.695297425, -0.182978288, - 1.940983578, -1.052570114, 1.265312559, -0.21744826, 2.122842478, - 1.291844321, -0.694666126, 2.001880096, 0.977066134, 1.383692522, - -0.085431624, -1.152918968, -1.621837649, 0.647353218, 1.079628054, - -0.220121984, -0.562039994, 2.441868908, 0.688842095, 0.572532136, - 1.049670153, -1.439036257, 0.673783789, 0.810812932, -0.557921732, - -0.055039468, 1.065618622, -0.653057442, -0.537812988, 0.818735764, - 0.874036767, -0.264722867, -1.083081897, 0.132684797, 1.282776406, - 0.980202012, 0.912757975, 0.395195197, -1.294487302, -0.149088612, - 1.042843997, -1.213788746, -1.842337004, -0.087241521, 1.759125287, - -0.65217472, -0.468828649, -1.128895132, 0.355130761, -1.13143679, - -0.231067871, -1.353450121, -1.710583197, 0.186715205, -0.543962675, - 0.292958499, -0.4283386, 2.670479768, 2.379591267, 1.278406268, - 2.298737024, -0.737706867, 1.468454399, 0.055981228, 0.149251786, - -0.332347905, -0.191862331, -0.012294677, 0.139243256, -1.123574851, - -0.034383926, -0.512343287, 0.812126437, 0.486944352, 0.595358492, - 1.224605923, 0.863959031, -1.789032311, 0.489475508, 2.019401428, - 2.492383813, 0.177655849, -0.587024392, 0.299497534, 1.602179556, - -1.502343948, -1.37596223, 0.74894869, 0.664588217, 1.321486377, - 1.888462109, -0.903168893, -3.201437624, -0.535609031, 0.554010178, - -0.547718747, 1.542488798, 1.851156869, 0.154379085, 0.617288371, - 1.273637679, -1.466949312, -0.150368723, -0.256217966), JaspColumn_.5._Encoded = c(1L, - 0L, 1L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, - 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, - 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, - 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 1L, - 1L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, - 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 0L, 0L, 1L, - 0L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, - 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, - 0L, 1L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, - 0L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, - 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, - 0L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, - 0L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, - 1L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 1L, - 0L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, - 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, - 0L, 1L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 0L, - 0L, 0L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 0L, - 0L, 1L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L), JaspColumn_.6._Encoded = c(2L, - 2L, 4L, 3L, 8L, 0L, 2L, 1L, 1L, 1L, 6L, 4L, 0L, 1L, 2L, 1L, 0L, - 0L, 4L, 1L, 0L, 1L, 3L, 10L, 3L, 1L, 1L, 1L, 2L, 1L, 2L, 0L, - 2L, 0L, 3L, 4L, 2L, 1L, 0L, 2L, 1L, 1L, 0L, 2L, 0L, 1L, 0L, 1L, - 0L, 0L, 5L, 1L, 2L, 3L, 1L, 3L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 4L, - 4L, 2L, 6L, 0L, 4L, 6L, 7L, 1L, 2L, 12L, 0L, 2L, 1L, 1L, 6L, - 2L, 1L, 0L, 0L, 12L, 2L, 0L, 2L, 1L, 1L, 2L, 8L, 5L, 2L, 3L, - 0L, 7L, 1L, 0L, 2L, 3L, 7L, 0L, 4L, 2L, 4L, 3L, 3L, 0L, 0L, 2L, - 11L, 1L, 0L, 3L, 0L, 12L, 5L, 2L, 1L, 0L, 19L, 2L, 1L, 1L, 0L, - 0L, 4L, 1L, 0L, 0L, 5L, 1L, 0L, 1L, 4L, 0L, 1L, 2L, 1L, 0L, 16L, - 1L, 0L, 0L, 1L, 2L, 3L, 4L, 1L, 0L, 2L, 0L, 1L, 12L, 0L, 18L, - 7L, 0L, 2L, 0L, 11L, 5L, 1L, 5L, 0L, 7L, 4L, 0L, 1L, 0L, 23L, - 0L, 2L, 1L, 1L, 6L, 11L, 1L, 0L, 0L, 1L, 0L, 1L, 2L, 1L, 0L, - 2L, 0L, 1L, 1L, 1L, 3L, 2L, 0L, 0L, 2L, 5L, 0L, 5L, 2L, 8L, 4L, - 1L, 10L, 3L, 4L, 0L, 0L, 0L, 1L, 2L, 0L, 0L, 7L, 2L, 1L, 3L, - 0L, 1L, 2L, 0L, 1L, 6L, 0L, 1L, 3L, 2L, 0L, 0L, 1L, 2L, 3L, 4L, - 2L, 1L, 1L, 2L, 1L, 0L, 1L, 4L, 0L, 0L, 0L, 3L, 0L, 0L, 1L, 0L, - 0L, 0L, 0L, 0L, 18L, 10L, 4L, 12L, 0L, 9L, 1L, 1L, 1L, 0L, 3L, - 3L, 0L, 0L, 0L, 4L, 1L, 1L, 4L, 1L, 0L, 4L, 5L, 14L, 2L, 1L, - 1L, 3L, 0L, 0L, 2L, 2L, 5L, 9L, 0L, 0L, 2L, 1L, 0L, 3L, 6L, 0L, - 4L, 6L, 0L, 1L, 1L), JaspColumn_.7._Encoded = c(0.427219425, - 0.220688309, 0.570053273, 0.231100824, 0.131067892, 1, 0.076567255, - 0.405903343, 0.474725634, 0.990018262, 0.192843674, 0.224774893, - 1, 0.740614383, 0.851823829, 0.653432541, 1, 1, 0.624686075, - 0.607677759, 1, 0.105184005, 0.178594546, 0.002517108, 0.769499354, - 0.543466466, 0.904824708, 0.597340464, 0.102275177, 0.939954609, - 0.644957841, 1, 0.092147577, 1, 0.052178635, 0.108955976, 0.103881947, - 0.307079922, 1, 0.640638174, 0.998201291, 0.358593487, 1, 0.098677587, - 1, 0.625249783, 1, 0.94040242, 1, 1, 0.108139376, 0.01932307, - 0.068532055, 0.319257561, 0.317226161, 0.042847799, 1, 0.907828255, - 1, 1, 1, 0.817368982, 1, 0.120666731, 0.211511707, 0.157775565, - 0.160599299, 1, 0.223432249, 0.071663969, 0.152479944, 0.4318303, - 0.064199554, 0.084701885, 1, 0.214182802, 0.250437733, 0.64748267, - 0.221051177, 0.8792932, 0.102889819, 1, 1, 0.004530114, 0.056033505, - 1, 0.107350229, 0.341537754, 0.560227328, 0.56788941, 0.029397749, - 0.128741443, 0.340319883, 0.438422074, 1, 0.363424137, 0.64064305, - 1, 0.669024544, 0.097899144, 0.184498989, 1, 0.626521215, 0.646898637, - 0.263503489, 0.147692887, 0.131565273, 1, 1, 0.132856326, 0.045526628, - 0.585667955, 1, 0.549235367, 1, 0.020705723, 0.029918293, 0.456543362, - 0.856084292, 1, 0.033240023, 0.000931051, 0.141747406, 0.691832666, - 1, 1, 0.119549448, 0.459920161, 1, 1, 0.63650842, 0.885468904, - 1, 0.66929208, 0.086900934, 1, 0.00297873, 0.387909833, 0.16488008, - 1, 0.154010162, 0.688411372, 1, 1, 0.374140598, 0.489588998, - 0.656373572, 0.253907352, 0.341392293, 1, 0.341498251, 1, 0.039745196, - 0.049899045, 1, 0.004291585, 0.064142592, 1, 0.162245865, 1, - 9.52e-05, 0.334425874, 0.55930246, 0.023006289, 1, 0.092510628, - 0.179388773, 1, 0.298066521, 1, 0.020858126, 1, 0.219817914, - 0.381100323, 0.383832334, 0.031687818, 0.021982156, 0.100909454, - 1, 1, 0.90886201, 1, 0.133518321, 0.321278177, 0.977561022, 1, - 0.377386837, 1, 0.924968583, 0.22384265, 0.001476047, 0.141017063, - 0.079471224, 1, 1, 0.003846134, 0.056555377, 1, 0.120304732, - 0.289193756, 0.021411919, 0.003588727, 0.815915327, 0.186839249, - 0.124749619, 0.215773542, 1, 1, 1, 0.09331221, 0.227188488, 1, - 1, 0.304550487, 0.242236769, 0.915177329, 0.038263021, 1, 0.690036211, - 0.115890253, 1, 0.377763011, 0.214936317, 1, 0.409689095, 0.016033388, - 0.696195914, 1, 1, 0.579652169, 0.111762879, 0.288249519, 0.685298051, - 0.029751715, 0.34902306, 0.740039564, 0.160866749, 0.934899752, - 1, 0.089958756, 0.101130973, 1, 1, 1, 0.000367582, 1, 1, 0.501846786, - 1, 1, 1, 1, 1, 0.012013178, 0.003237151, 0.37217903, 0.009178291, - 1, 0.091345794, 0.743160189, 0.983801698, 0.74850986, 1, 0.152319066, - 0.47288842, 1, 1, 1, 0.006951365, 0.522907566, 0.477519199, 0.077229532, - 0.344051985, 1, 0.268246943, 0.222762224, 0.013367555, 0.157375875, - 0.794346784, 0.403181111, 0.097897052, 1, 1, 0.243050875, 0.188878481, - 0.067540856, 0.169211418, 1, 1, 0.052260709, 0.052824504, 1, - 0.12313927, 0.085084118, 1, 0.018040391, 0.055642594, 1, 0.901317881, + dataset <- structure(list(Variable0 = c(1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, + 6L, 7L, 8L, 9L, 10L, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, + 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L), Variable1 = c(1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), Variable2 = c(1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), Variable3 = c(1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, + 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, + 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, + 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, + 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L, 5L), Variable4 = c(-0.653989689, + 0.597847379, 0.53124944, -0.919283666, 1.549214002, -0.964337181, + 0.758624407, -0.633353539, 0.093434858, 0.081944247, 1.251310302, + 1.399815493, -0.942716455, -0.495601118, 0.917930091, 0.344838602, + -1.226474961, -1.405114801, 0.686194991, 0.017571144, -0.337816215, + 0.384985065, 1.430491376, 1.866825203, 0.752814251, 1.31909783, + 0.447452196, -1.346206879, 0.479402493, -0.848513454, 0.850545592, + -3.037579176, 0.545769791, -1.182557897, -0.128004891, 1.11267647, + 0.616535768, -0.669227302, 0.076114909, 0.816454623, 0.422781459, + -0.094856662, -0.374461304, 0.691431944, -1.528712893, 1.05380469, + -0.545337415, -0.026770503, -2.189233221, -0.616004017, 1.150339483, + -0.133211268, 0.252652295, 1.399980471, -0.513151105, 1.117392323, + -0.610869543, 0.331300534, -0.992903801, -0.895568118, 0.623585941, + 1.05882918, -1.58627026, 0.947877674, 2.033833295, 0.179956552, + 1.573438425, -1.694333909, 1.079726669, 1.508240792, 0.90600351, + -0.290763172, -0.496024515, 1.946237186, -0.893948592, 0.830769682, + 0.440062416, -0.57837005, 1.790515054, 0.137924932, 0.055424081, + 0.547806104, -0.748529992, 1.71335853, 1.808028443, 0.017313744, + 0.988861738, -1.43975293, 0.338108584, -0.365015598, 1.86933575, + 1.699421632, 0.308476418, 1.556020356, -0.952816041, 1.874185874, + 1.104225239, -1.318714635, 1.431532182, 0.756206118, 1.892566353, + -0.933657521, 1.277498726, 0.407372551, 1.021542579, 0.74476069, + 0.571588797, -0.762850791, -2.287992665, -0.596915582, 2.920177191, + -0.853565433, -0.771818751, 0.492465518, -0.455610621, 2.667902824, + 1.953870427, 0.14233637, -1.188999386, -0.185194402, 2.751932451, + 0.1714291, 0.495442662, 0.007490023, -1.381723611, -0.360288418, + 1.228175718, 1.270669023, -0.317481349, -1.121300988, 0.248833912, + -0.936079972, -0.019929997, -0.752375481, 1.745747293, 0.005492604, + 0.407922866, 0.061474844, 0.69299688, 0.597159811, 2.949895836, + -0.24811046, 0.034494308, -0.78621074, 0.614844377, 1.095323201, + 0.672793259, 0.057114702, 0.072950494, 0.346984663, -0.452874548, + -0.114694466, 0.536167379, 2.672375374, 0.618138653, 2.749195306, + 2.199564155, -1.821705402, 0.662389551, -0.086448818, 2.350030519, + 1.42969294, -0.082903446, 1.526255915, -0.77415644, 1.646198365, + 0.550819959, -1.912875322, -0.170004512, -0.153966373, 3.216473665, + -2.384187974, 0.730941972, -0.065087507, 1.330153598, 1.27618167, + 1.956183459, 0.436215424, -1.232486611, -0.455381093, 0.83128861, + 0.152153259, -0.45491991, -0.256058166, -0.193076508, -0.334064589, + 0.215860632, -1.749746886, 0.358765965, 0.211328495, -0.112055855, + 0.945593904, 0.532860661, 0.01631963, -0.695297425, -0.182978288, + 1.940983578, -1.052570114, 1.265312559, -0.21744826, 2.122842478, + 1.291844321, -0.694666126, 2.001880096, 0.977066134, 1.383692522, + -0.085431624, -1.152918968, -1.621837649, 0.647353218, 1.079628054, + -0.220121984, -0.562039994, 2.441868908, 0.688842095, 0.572532136, + 1.049670153, -1.439036257, 0.673783789, 0.810812932, -0.557921732, + -0.055039468, 1.065618622, -0.653057442, -0.537812988, 0.818735764, + 0.874036767, -0.264722867, -1.083081897, 0.132684797, 1.282776406, + 0.980202012, 0.912757975, 0.395195197, -1.294487302, -0.149088612, + 1.042843997, -1.213788746, -1.842337004, -0.087241521, 1.759125287, + -0.65217472, -0.468828649, -1.128895132, 0.355130761, -1.13143679, + -0.231067871, -1.353450121, -1.710583197, 0.186715205, -0.543962675, + 0.292958499, -0.4283386, 2.670479768, 2.379591267, 1.278406268, + 2.298737024, -0.737706867, 1.468454399, 0.055981228, 0.149251786, + -0.332347905, -0.191862331, -0.012294677, 0.139243256, -1.123574851, + -0.034383926, -0.512343287, 0.812126437, 0.486944352, 0.595358492, + 1.224605923, 0.863959031, -1.789032311, 0.489475508, 2.019401428, + 2.492383813, 0.177655849, -0.587024392, 0.299497534, 1.602179556, + -1.502343948, -1.37596223, 0.74894869, 0.664588217, 1.321486377, + 1.888462109, -0.903168893, -3.201437624, -0.535609031, 0.554010178, + -0.547718747, 1.542488798, 1.851156869, 0.154379085, 0.617288371, + 1.273637679, -1.466949312, -0.150368723, -0.256217966), Variable5 = c(1L, + 0L, 1L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, + 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, + 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, + 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 1L, + 1L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, + 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 0L, 0L, 1L, + 0L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, + 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, + 0L, 1L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, + 0L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, + 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, + 0L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, + 0L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, + 1L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 1L, + 0L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, + 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, + 0L, 1L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 0L, + 0L, 0L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 0L, + 0L, 1L, 0L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 0L), Variable6 = c(2L, + 2L, 4L, 3L, 8L, 0L, 2L, 1L, 1L, 1L, 6L, 4L, 0L, 1L, 2L, 1L, 0L, + 0L, 4L, 1L, 0L, 1L, 3L, 10L, 3L, 1L, 1L, 1L, 2L, 1L, 2L, 0L, + 2L, 0L, 3L, 4L, 2L, 1L, 0L, 2L, 1L, 1L, 0L, 2L, 0L, 1L, 0L, 1L, + 0L, 0L, 5L, 1L, 2L, 3L, 1L, 3L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, 4L, + 4L, 2L, 6L, 0L, 4L, 6L, 7L, 1L, 2L, 12L, 0L, 2L, 1L, 1L, 6L, + 2L, 1L, 0L, 0L, 12L, 2L, 0L, 2L, 1L, 1L, 2L, 8L, 5L, 2L, 3L, + 0L, 7L, 1L, 0L, 2L, 3L, 7L, 0L, 4L, 2L, 4L, 3L, 3L, 0L, 0L, 2L, + 11L, 1L, 0L, 3L, 0L, 12L, 5L, 2L, 1L, 0L, 19L, 2L, 1L, 1L, 0L, + 0L, 4L, 1L, 0L, 0L, 5L, 1L, 0L, 1L, 4L, 0L, 1L, 2L, 1L, 0L, 16L, + 1L, 0L, 0L, 1L, 2L, 3L, 4L, 1L, 0L, 2L, 0L, 1L, 12L, 0L, 18L, + 7L, 0L, 2L, 0L, 11L, 5L, 1L, 5L, 0L, 7L, 4L, 0L, 1L, 0L, 23L, + 0L, 2L, 1L, 1L, 6L, 11L, 1L, 0L, 0L, 1L, 0L, 1L, 2L, 1L, 0L, + 2L, 0L, 1L, 1L, 1L, 3L, 2L, 0L, 0L, 2L, 5L, 0L, 5L, 2L, 8L, 4L, + 1L, 10L, 3L, 4L, 0L, 0L, 0L, 1L, 2L, 0L, 0L, 7L, 2L, 1L, 3L, + 0L, 1L, 2L, 0L, 1L, 6L, 0L, 1L, 3L, 2L, 0L, 0L, 1L, 2L, 3L, 4L, + 2L, 1L, 1L, 2L, 1L, 0L, 1L, 4L, 0L, 0L, 0L, 3L, 0L, 0L, 1L, 0L, + 0L, 0L, 0L, 0L, 18L, 10L, 4L, 12L, 0L, 9L, 1L, 1L, 1L, 0L, 3L, + 3L, 0L, 0L, 0L, 4L, 1L, 1L, 4L, 1L, 0L, 4L, 5L, 14L, 2L, 1L, + 1L, 3L, 0L, 0L, 2L, 2L, 5L, 9L, 0L, 0L, 2L, 1L, 0L, 3L, 6L, 0L, + 4L, 6L, 0L, 1L, 1L), Variable7 = c(0.427219425, + 0.220688309, 0.570053273, 0.231100824, 0.131067892, 1, 0.076567255, + 0.405903343, 0.474725634, 0.990018262, 0.192843674, 0.224774893, + 1, 0.740614383, 0.851823829, 0.653432541, 1, 1, 0.624686075, + 0.607677759, 1, 0.105184005, 0.178594546, 0.002517108, 0.769499354, + 0.543466466, 0.904824708, 0.597340464, 0.102275177, 0.939954609, + 0.644957841, 1, 0.092147577, 1, 0.052178635, 0.108955976, 0.103881947, + 0.307079922, 1, 0.640638174, 0.998201291, 0.358593487, 1, 0.098677587, + 1, 0.625249783, 1, 0.94040242, 1, 1, 0.108139376, 0.01932307, + 0.068532055, 0.319257561, 0.317226161, 0.042847799, 1, 0.907828255, + 1, 1, 1, 0.817368982, 1, 0.120666731, 0.211511707, 0.157775565, + 0.160599299, 1, 0.223432249, 0.071663969, 0.152479944, 0.4318303, + 0.064199554, 0.084701885, 1, 0.214182802, 0.250437733, 0.64748267, + 0.221051177, 0.8792932, 0.102889819, 1, 1, 0.004530114, 0.056033505, + 1, 0.107350229, 0.341537754, 0.560227328, 0.56788941, 0.029397749, + 0.128741443, 0.340319883, 0.438422074, 1, 0.363424137, 0.64064305, + 1, 0.669024544, 0.097899144, 0.184498989, 1, 0.626521215, 0.646898637, + 0.263503489, 0.147692887, 0.131565273, 1, 1, 0.132856326, 0.045526628, + 0.585667955, 1, 0.549235367, 1, 0.020705723, 0.029918293, 0.456543362, + 0.856084292, 1, 0.033240023, 0.000931051, 0.141747406, 0.691832666, + 1, 1, 0.119549448, 0.459920161, 1, 1, 0.63650842, 0.885468904, + 1, 0.66929208, 0.086900934, 1, 0.00297873, 0.387909833, 0.16488008, + 1, 0.154010162, 0.688411372, 1, 1, 0.374140598, 0.489588998, + 0.656373572, 0.253907352, 0.341392293, 1, 0.341498251, 1, 0.039745196, + 0.049899045, 1, 0.004291585, 0.064142592, 1, 0.162245865, 1, + 9.52e-05, 0.334425874, 0.55930246, 0.023006289, 1, 0.092510628, + 0.179388773, 1, 0.298066521, 1, 0.020858126, 1, 0.219817914, + 0.381100323, 0.383832334, 0.031687818, 0.021982156, 0.100909454, + 1, 1, 0.90886201, 1, 0.133518321, 0.321278177, 0.977561022, 1, + 0.377386837, 1, 0.924968583, 0.22384265, 0.001476047, 0.141017063, + 0.079471224, 1, 1, 0.003846134, 0.056555377, 1, 0.120304732, + 0.289193756, 0.021411919, 0.003588727, 0.815915327, 0.186839249, + 0.124749619, 0.215773542, 1, 1, 1, 0.09331221, 0.227188488, 1, + 1, 0.304550487, 0.242236769, 0.915177329, 0.038263021, 1, 0.690036211, + 0.115890253, 1, 0.377763011, 0.214936317, 1, 0.409689095, 0.016033388, + 0.696195914, 1, 1, 0.579652169, 0.111762879, 0.288249519, 0.685298051, + 0.029751715, 0.34902306, 0.740039564, 0.160866749, 0.934899752, + 1, 0.089958756, 0.101130973, 1, 1, 1, 0.000367582, 1, 1, 0.501846786, + 1, 1, 1, 1, 1, 0.012013178, 0.003237151, 0.37217903, 0.009178291, + 1, 0.091345794, 0.743160189, 0.983801698, 0.74850986, 1, 0.152319066, + 0.47288842, 1, 1, 1, 0.006951365, 0.522907566, 0.477519199, 0.077229532, + 0.344051985, 1, 0.268246943, 0.222762224, 0.013367555, 0.157375875, + 0.794346784, 0.403181111, 0.097897052, 1, 1, 0.243050875, 0.188878481, + 0.067540856, 0.169211418, 1, 1, 0.052260709, 0.052824504, 1, + 0.12313927, 0.085084118, 1, 0.018040391, 0.055642594, 1, 0.901317881, 0.859124256)), class = "data.frame", row.names = c(NA, -300L)) results <- jaspTools::runAnalysis("MixedModelsLMM", dataset, options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, - list("1, 257.99", "JaspColumn_.1._Encoded", 0.426414180238378, 0.634576077359649, - "1, 282.23", "JaspColumn_.2._Encoded", 0.648104497286089, 0.208744742802555, - "1, 282.92", "JaspColumn_.7._Encoded", 0.272159183015596, 1.21054651491042, - "1, 283.64", "JaspColumn_.1._Encoded * JaspColumn_.2._Encoded", - 0.74472366342099, 0.106225176201557, "1, 284.41", "JaspColumn_.1._Encoded * JaspColumn_.7._Encoded", - 0.681782706300614, 0.168471669695429, "1, 284.53", "JaspColumn_.2._Encoded * JaspColumn_.7._Encoded", - 0.633028958518581, 0.22846822915199, "1, 284.96", "JaspColumn_.1._Encoded * JaspColumn_.2._Encoded * JaspColumn_.7._Encoded", + list("1, 257.99", "Variable1", 0.426414180238378, 0.634576077359649, + "1, 282.23", "Variable2", 0.648104497286089, 0.208744742802555, + "1, 282.92", "Variable7", 0.272159183015596, 1.21054651491042, + "1, 283.64", "Variable1 * Variable2", + 0.74472366342099, 0.106225176201557, "1, 284.41", "Variable1 * Variable7", + 0.681782706300614, 0.168471669695429, "1, 284.53", "Variable2 * Variable7", + 0.633028958518581, 0.22846822915199, "1, 284.96", "Variable1 * Variable2 * Variable7", 0.931744555167491, 0.00734892069033801)) }) - + test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -347,7 +347,7 @@ context("Linear Mixed Models") -0.680053672162645, 6, 0.000334258863071123, 0.122595026605752, -3.58719148327186, -0.199489998500637)) }) - + test_that("Estimated Means and Confidence Intervals table results match", { table <- results[["results"]][["EstimatesTable"]][["data"]] jaspTools::expect_equal_tables(table, @@ -355,66 +355,66 @@ context("Linear Mixed Models") 2, 2, 0.0777669964062764, 0.302728943195176, 0.527690889984076 )) }) - + test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] jaspTools::expect_equal_tables(table, list(230.891606556034, 0.608062595749729, 0.372858810192038, 0.681023693258942, 0.89286555191631, "Intercept", 257.98768727024, 0.327632122078992, - 0.426414180238378, 0.411286663217132, 0.796602835395185, "JaspColumn_.1._Encoded", + 0.426414180238378, 0.411286663217132, 0.796602835395185, "Variable1", 282.226948919654, 0.139257176102306, 0.648104497286089, 0.304796384328169, - 0.456885918805291, "JaspColumn_.2._Encoded", 282.918621512351, + 0.456885918805291, "Variable2", 282.918621512351, -1.05885353945792, 0.272159183015596, 0.962376815249481, -1.1002483878245, - "JaspColumn_.7._Encoded", 283.638799740339, -0.0607677106265602, - 0.74472366342099, 0.186448607814412, -0.325922040067187, "JaspColumn_.1._Encoded * JaspColumn_.2._Encoded", + "Variable7", 283.638799740339, -0.0607677106265602, + 0.74472366342099, 0.186448607814412, -0.325922040067187, "Variable1 * Variable2", 284.412910787555, -0.24930037907597, 0.681782706300614, 0.607378617665152, - -0.410453005465217, "JaspColumn_.1._Encoded * JaspColumn_.7._Encoded", + -0.410453005465217, "Variable1 * Variable7", 284.533506761359, -0.212893078541668, 0.633028958518581, 0.445398381324788, - -0.477983503012384, "JaspColumn_.2._Encoded * JaspColumn_.7._Encoded", + -0.477983503012384, "Variable2 * Variable7", 284.963881035524, 0.0240067531742241, 0.931744555167491, 0.280041017559053, - 0.0857258461045326, "JaspColumn_.1._Encoded * JaspColumn_.2._Encoded * JaspColumn_.7._Encoded" + 0.0857258461045326, "Variable1 * Variable2 * Variable7" )) }) - - test_that("JaspColumn_.0._Encoded: Correlation Estimates table results match", { + + test_that("Variable0: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE1"]][["data"]] jaspTools::expect_equal_tables(table, - list(1, "Intercept", -0.895416305095377, 1, "JaspColumn_.1._Encoded" + list(1, "Intercept", -0.895416305095377, 1, "Variable1" )) }) - + test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES1"]][["data"]] jaspTools::expect_equal_tables(table, list(0.77051634334806, 0.593695435366465)) }) - - test_that("JaspColumn_.0._Encoded: Variance Estimates table results match", { + + test_that("Variable0: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0.531845577486718, 0.282859718292181, "Intercept", 0.214294032831598, - 0.0459219325072302, "JaspColumn_.1._Encoded")) + 0.0459219325072302, "Variable1")) }) - + test_that("Sample sizes table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitSizes"]][["data"]] jaspTools::expect_equal_tables(table, list(10, 300)) }) - + test_that("Fit statistics table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitStats"]][["data"]] jaspTools::expect_equal_tables(table, list(749.049627510379, 793.495017206253, 725.049627510379, 12, -362.524813755189 )) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "plot-lmm-1") }) - + test_that("Estimated Trends table results match", { table <- results[["results"]][["trendsSummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -427,29 +427,29 @@ context("Linear Mixed Models") ### no correlations between random effects, Kernwald Roggers method, custom values { options <- jaspTools::analysisOptions("MixedModelsLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3", "4", "5", - "6", "7"), name = "contGamma", values = c("-3.2", "0", "3.2", - "-3.2", "0", "3.2")), list(isContrast = FALSE, levels = c("2", - "3", "4", "5", "6", "7"), name = "contBinom", values = c("0", - "0", "0", "1", "1", "1")), list(isContrast = TRUE, levels = c("2", - "3", "4", "5", "6", "7"), name = "Contrast 1", values = c("-1", - "1", "0", "0", "0", "0")), list(isContrast = TRUE, levels = c("2", - "3", "4", "5", "6", "7"), name = "Contrast 2", values = c("0", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3", "4", "5", + "6", "7"), name = "contGamma", values = c("-3.2", "0", "3.2", + "-3.2", "0", "3.2")), list(isContrast = FALSE, levels = c("2", + "3", "4", "5", "6", "7"), name = "contBinom", values = c("0", + "0", "0", "1", "1", "1")), list(isContrast = TRUE, levels = c("2", + "3", "4", "5", "6", "7"), name = "Contrast 1", values = c("-1", + "1", "0", "0", "0", "0")), list(isContrast = TRUE, levels = c("2", + "3", "4", "5", "6", "7"), name = "Contrast 2", values = c("0", "0", "1", "-1", "0", "0"))) - options$bootstrap_samples <- 500 + options$bootstrapSamples <- 500 options$dependentVariable <- "contNormal" options$fitStats <- FALSE - options$fixedEffects <- list(list(components = "contGamma"), list(components = "contBinom"), - list(components = "facExperim"), list(components = "facGender"), - list(components = c("contGamma", "contBinom")), list(components = c("contGamma", + options$fixedEffects <- list(list(components = "contGamma"), list(components = "contBinom"), + list(components = "facExperim"), list(components = "facGender"), + list(components = c("contGamma", "contBinom")), list(components = c("contGamma", "facExperim")), list(components = c("contGamma", "facGender" )), list(components = c("contBinom", "facExperim")), list( - components = c("contBinom", "facGender")), list(components = c("facExperim", - "facGender")), list(components = c("contGamma", "contBinom", - "facExperim")), list(components = c("contGamma", "contBinom", - "facGender")), list(components = c("contGamma", "facExperim", - "facGender")), list(components = c("contBinom", "facExperim", - "facGender")), list(components = c("contGamma", "contBinom", + components = c("contBinom", "facGender")), list(components = c("facExperim", + "facGender")), list(components = c("contGamma", "contBinom", + "facExperim")), list(components = c("contGamma", "contBinom", + "facGender")), list(components = c("contGamma", "facExperim", + "facGender")), list(components = c("contBinom", "facExperim", + "facGender")), list(components = c("contGamma", "contBinom", "facExperim", "facGender"))) options$fixedVariables <- c("contGamma", "contBinom", "facExperim", "facGender") options$marginalMeans <- list(list(variable = "contGamma"), list(variable = "contBinom")) @@ -484,20 +484,20 @@ context("Linear Mixed Models") options$plotsX <- list(list(variable = "contBinom")) options$pvalVS <- TRUE options$randomEffects <- list(list(correlations = FALSE, randomComponents = list(list( - randomSlopes = TRUE, value = "contGamma"), list(randomSlopes = TRUE, - value = "contBinom"), list(randomSlopes = TRUE, value = "facExperim"), - list(randomSlopes = TRUE, value = "facGender"), list(randomSlopes = FALSE, - value = c("contGamma", "contBinom")), list(randomSlopes = FALSE, - value = c("contGamma", "facExperim")), list(randomSlopes = FALSE, - value = c("contGamma", "facGender")), list(randomSlopes = FALSE, - value = c("contBinom", "facExperim")), list(randomSlopes = FALSE, - value = c("contBinom", "facGender")), list(randomSlopes = FALSE, - value = c("facExperim", "facGender")), list(randomSlopes = FALSE, + randomSlopes = TRUE, value = "contGamma"), list(randomSlopes = TRUE, + value = "contBinom"), list(randomSlopes = TRUE, value = "facExperim"), + list(randomSlopes = TRUE, value = "facGender"), list(randomSlopes = FALSE, + value = c("contGamma", "contBinom")), list(randomSlopes = FALSE, + value = c("contGamma", "facExperim")), list(randomSlopes = FALSE, + value = c("contGamma", "facGender")), list(randomSlopes = FALSE, + value = c("contBinom", "facExperim")), list(randomSlopes = FALSE, + value = c("contBinom", "facGender")), list(randomSlopes = FALSE, + value = c("facExperim", "facGender")), list(randomSlopes = FALSE, value = c("contGamma", "contBinom", "facExperim")), list( - randomSlopes = FALSE, value = c("contGamma", "contBinom", - "facGender")), list(randomSlopes = FALSE, value = c("contGamma", - "facExperim", "facGender")), list(randomSlopes = FALSE, value = c("contBinom", - "facExperim", "facGender")), list(randomSlopes = FALSE, value = c("contGamma", + randomSlopes = FALSE, value = c("contGamma", "contBinom", + "facGender")), list(randomSlopes = FALSE, value = c("contGamma", + "facExperim", "facGender")), list(randomSlopes = FALSE, value = c("contBinom", + "facExperim", "facGender")), list(randomSlopes = FALSE, value = c("contGamma", "contBinom", "facExperim", "facGender"))), value = "facFive")) options$randomVariables <- "facFive" options$seed <- 1 @@ -509,11 +509,11 @@ context("Linear Mixed Models") options$trendsCompare <- TRUE options$trendsCompareTo <- 9 options$trendsContrast <- TRUE - options$trendsContrasts <- list(list(isContrast = FALSE, levels = c("2", "3", "4", "5"), - name = "facExperim", values = c("control", "experimental", - "control", "experimental")), list(isContrast = FALSE, levels = c("2", - "3", "4", "5"), name = "facGender", values = c("f", "f", "m", - "m")), list(isContrast = TRUE, levels = c("2", "3", "4", "5"), + options$trendsContrasts <- list(list(isContrast = FALSE, levels = c("2", "3", "4", "5"), + name = "facExperim", values = c("control", "experimental", + "control", "experimental")), list(isContrast = FALSE, levels = c("2", + "3", "4", "5"), name = "facGender", values = c("f", "f", "m", + "m")), list(isContrast = TRUE, levels = c("2", "3", "4", "5"), name = "Contrast 1", values = c("-1", "0", "1", "0"))) options$trendsDf <- "kenward-roger" options$trendsTrend <- list(list(variable = "contGamma")) @@ -521,8 +521,8 @@ context("Linear Mixed Models") options$type <- "3" set.seed(1) results <- jaspTools::runAnalysis("MixedModelsLMM", "debug", options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -546,7 +546,7 @@ context("Linear Mixed Models") "contGamma * contBinom * facExperim * facGender", 0.148676132254087, 1.2982095421261, 2.12924808409802)) }) - + test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -567,7 +567,7 @@ context("Linear Mixed Models") 1.72388383172118, 0.977535027346068, -1.73012847999302, 1.25568227713622 )) }) - + test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -603,80 +603,80 @@ context("Linear Mixed Models") 0.211481679694976, 1.61256468315413, "contGamma * contBinom * facExperim (1) * facGender (1)" )) }) - + test_that("facFive.3: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE4"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "facExperim (control)", "NaN", 1, "facExperim (experimental)" )) }) - + test_that("facFive.4: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE5"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "facGender (f)", "NaN", 1, "facGender (m)")) }) - + test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES5"]][["data"]] jaspTools::expect_equal_tables(table, list(1.01552953184787, 1.03130023005516)) }) - + test_that("facFive: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0, 0, "Intercept")) }) - + test_that("facFive.1: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE2"]][["data"]] jaspTools::expect_equal_tables(table, list(0, 0, "contGamma")) }) - + test_that("facFive.2: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE3"]][["data"]] jaspTools::expect_equal_tables(table, list(0, 0, "contBinom")) }) - + test_that("facFive.3: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE4"]][["data"]] jaspTools::expect_equal_tables(table, list(0, 0, "facExperim (control)", 0.237531600307891, 0.0564212611448276, "facExperim (experimental)")) }) - + test_that("facFive.4: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE5"]][["data"]] jaspTools::expect_equal_tables(table, list(0, 0, "facGender (f)", 0.156150662299331, 0.0243830293365197, "facGender (m)")) }) - + test_that("Contrasts table results match", { - table <- results[["results"]][["contrasts_Means"]][["data"]] + table <- results[["results"]][["contrastsMeans"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", 82.2103671303575, -0.231310349492497, 0.60243960877149, 1, 0.442347520093316, -0.522915443142307, "Contrast 2", 79.902751067842, -0.642750180031443, 0.548152227927422, 1, 1.06574918195276, -0.603097042827413)) }) - + test_that("Contrasts table results match", { - table <- results[["results"]][["contrasts_Trends"]][["data"]] + table <- results[["results"]][["contrastsTrends"]][["data"]] jaspTools::expect_equal_tables(table, list("Contrast 1", 57.0113581457788, -0.560541517971749, 0.0729821205951162, 1.92573082206986, 0.306860675388687, -1.82669713954627)) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "plot-lmm-2") }) - + test_that("Estimated Trends table results match", { table <- results[["results"]][["trendsSummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -695,10 +695,10 @@ context("Linear Mixed Models") ### type II, LRT + intercept { options <- jaspTools::analysisOptions("MixedModelsLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", - values = c("f", "m")), list(isContrast = TRUE, levels = c("2", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", + values = c("f", "m")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 1", values = c("0", "0"))) - options$bootstrap_samples <- 500 + options$bootstrapSamples <- 500 options$dependentVariable <- "contNormal" options$fitStats <- FALSE options$fixedEffects <- list(list(components = "facGender")) @@ -728,9 +728,9 @@ context("Linear Mixed Models") options$plotsTrace <- list() options$plotsX <- list(list(variable = "facGender")) options$pvalVS <- FALSE - options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = TRUE, - value = "facGender")), value = "contBinom"), list(correlations = TRUE, - randomComponents = list(list(randomSlopes = TRUE, value = "facGender")), + options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = TRUE, + value = "facGender")), value = "contBinom"), list(correlations = TRUE, + randomComponents = list(list(randomSlopes = TRUE, value = "facGender")), value = "facFive")) options$randomVariables <- c("contBinom", "facFive") options$seed <- 1 @@ -738,20 +738,20 @@ context("Linear Mixed Models") options$showFE <- TRUE options$showRE <- FALSE options$test_intercept <- TRUE - options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", + options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", values = list())) options$trendsTrend <- list() options$type <- "2" set.seed(1) results <- jaspTools::runAnalysis("MixedModelsLMM", "debug", options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "facGender", 0.0892620294750889, 2.88763209614939)) }) - + test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -759,7 +759,7 @@ context("Linear Mixed Models") -0.13891608695165, 0.0410342976475168, "m", -0.296581004637054, 0.172255870489273, 0.378649599932087)) }) - + test_that("Estimated Means and Confidence Intervals table results match", { table <- results[["results"]][["EstimatesTable"]][["data"]] jaspTools::expect_equal_tables(table, @@ -767,7 +767,7 @@ context("Linear Mixed Models") "m", -0.812059108259059, 0.0410342976475168, 0.894127703554092 )) }) - + test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -776,7 +776,7 @@ context("Linear Mixed Models") 0.082440039209281, 0.115076349521506, -2.01058024953449, "facGender (1)" )) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] @@ -786,10 +786,10 @@ context("Linear Mixed Models") ### parametric bootstrap { options <- jaspTools::analysisOptions("MixedModelsLMM") - options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", - values = c("f", "m")), list(isContrast = TRUE, levels = c("2", + options$Contrasts <- list(list(isContrast = FALSE, levels = c("2", "3"), name = "facGender", + values = c("f", "m")), list(isContrast = TRUE, levels = c("2", "3"), name = "Contrast 1", values = c("0", "0"))) - options$bootstrap_samples <- 100 + options$bootstrapSamples <- 100 options$dependentVariable <- "contNormal" options$fitStats <- FALSE options$fixedEffects <- list(list(components = "facGender")) @@ -819,7 +819,7 @@ context("Linear Mixed Models") options$plotsTrace <- list() options$plotsX <- list(list(variable = "facGender")) options$pvalVS <- FALSE - options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = TRUE, + options$randomEffects <- list(list(correlations = TRUE, randomComponents = list(list(randomSlopes = TRUE, value = "facGender")), value = "facFive")) options$randomVariables <- "facFive" options$seed <- 1 @@ -827,21 +827,21 @@ context("Linear Mixed Models") options$showFE <- TRUE options$showRE <- TRUE options$test_intercept <- FALSE - options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", + options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", values = list())) options$trendsTrend <- list() options$type <- "2" set.seed(1) results <- jaspTools::runAnalysis("MixedModelsLMM", "debug", options) - - + + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "facGender", 0.0585272236145518, 0.129411764705882, 3.57863502661178 )) }) - + test_that("Estimated Marginal Means table results match", { table <- results[["results"]][["EMMsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -849,7 +849,7 @@ context("Linear Mixed Models") -0.138916113944573, 0.0410341526398586, "m", -0.296585024170459, 0.172257847324448, 0.378653329450176)) }) - + test_that("Fixed Effects Estimates table results match", { table <- results[["results"]][["FEsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -858,26 +858,26 @@ context("Linear Mixed Models") 0.0824437479104129, 0.115077396728607, -2.01056147129998, "facGender (1)" )) }) - + test_that("facFive: Correlation Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_CE1"]][["data"]] jaspTools::expect_equal_tables(table, list(1, "Intercept", -1, 1, "facGender (1)")) }) - + test_that("Residual Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_RES1"]][["data"]] jaspTools::expect_equal_tables(table, list(1.01581460714797, 1.00787628563627)) }) - + test_that("facFive: Variance Estimates table results match", { table <- results[["results"]][["REsummary"]][["collection"]][["REsummary_VE1"]][["data"]] jaspTools::expect_equal_tables(table, list(0.0906377552259416, 0.00821520267239771, "Intercept", 0.120437360968589, 0.0145051579170782, "facGender (1)")) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] @@ -888,12 +888,12 @@ context("Linear Mixed Models") ### fix plot - S + type II { options <- jaspTools::analysisOptions("MixedModelsLMM") - options$Contrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", + options$Contrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", values = list())) - options$bootstrap_samples <- 100 + options$bootstrapSamples <- 100 options$dependentVariable <- "contNormal" options$fitStats <- TRUE - options$fixedEffects <- list(list(components = "facGender"), list(components = "debMiss30"), + options$fixedEffects <- list(list(components = "facGender"), list(components = "debMiss30"), list(components = c("facGender", "debMiss30"))) options$fixedVariables <- c("facGender", "debMiss30") options$method <- "S" @@ -927,13 +927,13 @@ context("Linear Mixed Models") options$showFE <- FALSE options$showRE <- FALSE options$test_intercept <- FALSE - options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", + options$trendsContrasts <- list(list(isContrast = TRUE, levels = list(), name = "Contrast 1", values = list())) options$trendsTrend <- list() options$type <- "2" set.seed(1) results <- jaspTools::runAnalysis("MixedModelsLMM", "debug", options) - + test_that("ANOVA Summary table results match", { table <- results[["results"]][["ANOVAsummary"]][["data"]] jaspTools::expect_equal_tables(table, @@ -942,20 +942,20 @@ context("Linear Mixed Models") "1, 62.40", "facGender * debMiss30", 0.304695104140844, 1.07108241647693 )) }) - + test_that("Sample sizes table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitSizes"]][["data"]] jaspTools::expect_equal_tables(table, list(5, 70)) }) - + test_that("Fit statistics table results match", { table <- results[["results"]][["fitSummary"]][["collection"]][["fitSummary_fitStats"]][["data"]] jaspTools::expect_equal_tables(table, list(245.086327825346, 258.577299277642, 233.086327825346, 6, -116.543163912673 )) }) - + test_that("Plot matches", { plotName <- results[["results"]][["plots"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] From 0bc7f674c64babedc09e6454bc0f4863349b0456 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Fri, 2 Jul 2021 15:44:28 +0200 Subject: [PATCH 20/38] simplifying the variable names? --- .gitignore | 3 ++ R/MixedModelsCommon.R | 68 ++++++++++--------------------------------- 2 files changed, 18 insertions(+), 53 deletions(-) diff --git a/.gitignore b/.gitignore index fd15cea8..f8093fea 100644 --- a/.gitignore +++ b/.gitignore @@ -47,3 +47,6 @@ Thumbs.db # RStudio files .Rproj.user + +# some local files +do-not-share diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index e4fa0a53..14985ca8 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -791,13 +791,8 @@ for (i in 1:length(tempStdDev)) { - if (names(tempStdDev)[i] == "(Intercept)") - varName <- gettext("Intercept") - else - varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) - tempRow <- list( - variable = varName, + variable = .mmVariableNames(names(tempStdDev)[i], options$fixedVariables), std = tempStdDev[i], var = tempStdDev[i]^2 ) @@ -818,25 +813,14 @@ # add columns REcor$addColumnInfo(name = "variable", title = gettext("Term"), type = "string") for (i in 1:nrow(tempCorr)) { - - if (rownames(tempCorr)[i] == "(Intercept)") - varName <- gettext("Intercept") - else - varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - - REcor$addColumnInfo(name = paste0("v", i), title = varName, type = "number") + REcor$addColumnInfo(name = paste0("v", i), title = .mmVariableNames(names(tempStdDev)[i], options$fixedVariables), type = "number") } # fill rows for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") - varName <- gettext("Intercept") - else - varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - + tempRow <- list(variable = .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables)) - tempRow <- list(variable = varName) for (j in 1:i) { tempRow[paste0("v", j)] <- tempCorr[i, j] } @@ -918,16 +902,10 @@ for (i in 1:nrow(FEcoef)) { - if (rownames(FEcoef)[i] == "(Intercept)") - effectName <- gettext("Intercept") - else - effectName <- .mmVariableNames(rownames(FEcoef)[i], options$fixedVariables) - - if (type == "LMM") { tempRow <- list( - term = effectName, + term = .mmVariableNames(rownames(FEcoef)[i], options$fixedVariables), estimate = FEcoef[i, 1], se = FEcoef[i, 2], df = FEcoef[i, 3], @@ -938,7 +916,7 @@ } else if (type == "GLMM") { tempRow <- list( - term = effectName, + term = .mmVariableNames(rownames(FEcoef)[i], options$fixedVariables), estimate = FEcoef[i, 1], se = FEcoef[i, 2], stat = FEcoef[i, 3] @@ -2102,13 +2080,8 @@ for (i in 1:length(tempStdDev)) { - if (names(tempStdDev)[i] == "(Intercept)") - varName <- gettext("Intercept") - else - varName <- .mmVariableNames(names(tempStdDev)[i], options$fixedVariables) - tempRow <- list( - variable = varName, + variable = .mmVariableNames(names(tempStdDev)[i], options$fixedVariables), std = tempStdDev[i], var = tempStdDev[i]^2 ) @@ -2131,11 +2104,7 @@ for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") - varName <- gettext("Intercept") - else - varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - + varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) REcor$addColumnInfo(name = paste0("v", i), title = varName, type = "number") } @@ -2143,12 +2112,7 @@ # fill rows for (i in 1:nrow(tempCorr)) { - if (rownames(tempCorr)[i] == "(Intercept)") - varName <- gettext("Intercept") - else - varName <- .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables) - - tempRow <- list(variable = varName) + tempRow <- list(variable = .mmVariableNames(rownames(tempCorr)[i], options$fixedVariables)) for (j in 1:i) { tempRow[paste0("v", j)] <- tempCorr[i, j] @@ -2213,13 +2177,8 @@ for (i in 1:nrow(feSummary)) { - if (rownames(feSummary)[i] == "(Intercept)") - effectName <- "Intercept" - else - effectName <- .mmVariableNames(rownames(feSummary)[i], options$fixedVariables) - tempRow <- list( - term = effectName, + term = .mmVariableNames(rownames(feSummary)[i], options$fixedVariables), estimate = feSummary[i, 1], se = feSummary[i, 3], lowerCI = feSummary[i, 4], @@ -2339,9 +2298,9 @@ varName <- paste(unlist(strsplit(as.character(tempSummary$Variable[j]), ",")), collapse = jaspBase::interactionSymbol) varName <- gsub(" ", "", varName, fixed = TRUE) - if (grepl(jaspBase::interactionSymbol, names(modelSummary)[i], fixed = TRUE)) { + if (grepl(":", names(modelSummary)[i], fixed = TRUE)) { - for (n in unlist(strsplit(names(modelSummary)[i], jaspBase::interactionSymbol))) { + for (n in unlist(strsplit(names(modelSummary)[i], ":"))) { varName <- gsub(n, "", varName, fixed = TRUE) } @@ -2488,7 +2447,10 @@ } # helper functions -.mmVariableNames <- function(varName, variables) { +.mmVariableNames <- function(varName, variables) { + + if (varName == "(Intercept)") + return(gettext("Intercept")) for (vn in variables) { inf <- regexpr(vn, varName, fixed = TRUE) From 71fcbeb8ebb58cdec7ed7b6ec227bff64bc87178 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Fri, 2 Jul 2021 16:40:17 +0200 Subject: [PATCH 21/38] tryCatch -> try --- R/MixedModelsCommon.R | 54 ++++++++++++++++--------------------------- 1 file changed, 20 insertions(+), 34 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 14985ca8..f2b85539 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -447,7 +447,7 @@ modelFormula <- .mmModelFormula(options, dataset) if (type == "LMM") { - model <- tryCatch( + model <- try( afex::mixed( formula = as.formula(modelFormula$modelFormula), data = dataset, @@ -456,9 +456,7 @@ test_intercept = if (options$method %in% c("LRT", "PB")) options$test_intercept else FALSE, args_test = list(nsim = options$bootstrapSamples), check_contrasts = TRUE - ), - error = function(e) return(e) - ) + )) } else if (type == "GLMM") { # needs to be avaluated in the global environment glmmFamily <<- options$family @@ -467,7 +465,7 @@ # I wish there was a better way to do this if (options$family == "binomialAgg") { glmmWeight <<- dataset[, options$dependentVariableAggregation] - model <- tryCatch( + model <- try( afex::mixed( formula = as.formula(modelFormula$modelFormula), data = dataset, @@ -478,11 +476,9 @@ check_contrasts = TRUE, family = eval(call("binomial", glmmLink)), weights = glmmWeight - ), - error = function(e) return(e) - ) + )) } else { - model <- tryCatch( + model <- try( afex::mixed( formula = as.formula(modelFormula$modelFormula), data = dataset, @@ -493,9 +489,7 @@ check_contrasts = TRUE, #start = start, family = eval(call(glmmFamily, glmmLink)) - ), - error = function(e) return(e) - ) + )) } } @@ -1070,7 +1064,7 @@ model <- model$full_model[[length(model$full_model)]] .setSeedJASP(options) - p <- tryCatch( + p <- try( afex::afex_plot( model, dv = options$dependentVariable, @@ -1092,9 +1086,7 @@ line_arg = list(size = .5 * options$plotRelativeSize), legend_title = paste(unlist(options$plotsTrace), collapse = "\n"), dodge = options$plotDodge - ), - error = function(e) e - ) + )) if (inherits(p, "error")) { plots$setError(p$message) @@ -1727,37 +1719,31 @@ # take care of the scale if (type %in% c("LMM", "BLMM") || what == "Trends") { - emmContrast <- tryCatch( + emmContrast <- try( as.data.frame( emmeans::contrast( emm, contrs, adjust = if (type %in% c("LMM", "GLMM")) selectedAdjustment) - ), - error = function(e) e - ) + )) } else if (type %in% c("GLMM", "BGLMM")) { if (selectedResponse) { - emmContrast <- tryCatch( + emmContrast <- try( as.data.frame( emmeans::contrast( emmeans::regrid(emm), contrs, adjust = if (type == "GLMM") selectedAdjustment ) - ), - error = function(e) e - ) + )) } else { - emmContrast <- tryCatch( + emmContrast <- try( as.data.frame( emmeans::contrast( emm, contrs, adjust = if (type == "GLMM") selectedAdjustment) - ), - error = function(e) e - ) + )) } } @@ -1892,7 +1878,7 @@ if (type == "BLMM") { - model <- tryCatch(stanova::stanova( + model <- try(stanova::stanova( formula = as.formula(modelFormula$modelFormula), check_contrasts = "contr.bayes", data = dataset, @@ -1903,7 +1889,7 @@ control = list(max_treedepth = options$max_treedepth), seed = .getSeedJASP(options), model_fun = "lmer" - ), error = function(e) e ) + )) } else if (type == "BGLMM") { @@ -1922,7 +1908,7 @@ if (options$family == "binomialAgg") { glmmWeight <<- dataset[, options$dependentVariableAggregation] - model <- tryCatch(stanova::stanova( + model <- try(stanova::stanova( formula = as.formula(modelFormula$modelFormula), check_contrasts = "contr.bayes", data = dataset, @@ -1935,11 +1921,11 @@ family = eval(call("binomial", glmmLink)), seed = .getSeedJASP(options), model_fun = "glmer" - ), error = function(e) e ) + )) } else { - model <- tryCatch(stanova::stanova( + model <- try(stanova::stanova( formula = as.formula(modelFormula$modelFormula), check_contrasts = "contr.bayes", data = dataset, @@ -1951,7 +1937,7 @@ family = glmmFamily, seed = .getSeedJASP(options), model_fun = "glmer" - ), error = function(e) e ) + )) } From d64636fd6f694fd046544d6df40905b907ba4e0b Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Fri, 2 Jul 2021 17:37:35 +0200 Subject: [PATCH 22/38] tryCatch -> try vol. II --- R/MixedModelsCommon.R | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index f2b85539..92f96e09 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -553,27 +553,27 @@ # some error managment for GLMMS - and oh boy, they can fail really easily if (type %in% c("LMM", "GLMM") && !is.null(model)) { if (any(attr(model, "class") %in% c("std::runtime_error", "C++Error", "error"))) { - if (model$message == "(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate") + if (model == "(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate") ANOVAsummary$setError( gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.") ) - else if (model$message == "PIRLS loop resulted in NaN value") + else if (model == "PIRLS loop resulted in NaN value") ANOVAsummary$setError( gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data or an overly complex model structure. Try removing some of the predictors.") ) - else if (model$message == "cannot find valid starting values: please specify some") + else if (model == "cannot find valid starting values: please specify some") # currently no solution to this, it seems to be a problem with synthetic data only. # I will try silving it once someone actually has problem with real data. ANOVAsummary$setError(gettext("The optimizer failed to find a solution due to invalid starting values. (JASP currently does not support specifying different starting values.)")) - else if (model$message == "Downdated VtV is not positive definite") + else if (model == "Downdated VtV is not positive definite") ANOVAsummary$setError(gettext("The optimizer failed to find a solution. Probably due to scaling issues quasi-separation in the data. Try rescaling or removing some of the predictors.")) else - ANOVAsummary$setError(model$message) + ANOVAsummary$setError(model) return() @@ -1088,8 +1088,8 @@ dodge = options$plotDodge )) - if (inherits(p, "error")) { - plots$setError(p$message) + if (jaspBase::isTryError(p)) { + plots$setError(p) return() } @@ -1747,8 +1747,8 @@ } } - if (inherits(emmContrast, "error")) { - EMMCsummary$setError(emmContrast$message) + if (jaspBase::isTryError(emmContrast)) { + EMMCsummary$setError(emmContrast) return() } @@ -1943,11 +1943,11 @@ } - if (inherits(model, "error")) { - if (model$message == "Dropping columns failed to produce full column rank design matrix") + if (jaspBase::isTryError(model)) { + if (model == "Dropping columns failed to produce full column rank design matrix") .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. A factor or combination of factors resulted in more levels than the effective sample size.")) else - .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model$message)) + .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model)) } object <- list( @@ -2187,7 +2187,7 @@ return() model <- jaspResults[["mmModel"]]$object$model - if (!is.null(model) && !class(jaspResults[["mmModel"]]$object$model) %in% c("simpleError", "error")) { + if (!is.null(model) && jaspBase::isTryError(jaspResults[["mmModel"]]$object$model)) { modelSummary <- summary( model, @@ -2259,7 +2259,7 @@ tempTable$addFootnote(.mmMessageMissingAgg) - if (inherits(jaspResults[["mmModel"]]$object$model, "error")) + if (jaspBase::isTryError(jaspResults[["mmModel"]]$object$model)) STANOVAsummary$setError(gettext("The model could not be estimated. Please, check the options and dataset for errors.")) return() From 05905a922b58802575fdf61f52e12158434c496e Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 6 Jul 2021 10:17:14 +0200 Subject: [PATCH 23/38] try error fix --- R/MixedModelsCommon.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 92f96e09..907c9e24 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -552,7 +552,7 @@ # some error managment for GLMMS - and oh boy, they can fail really easily if (type %in% c("LMM", "GLMM") && !is.null(model)) { - if (any(attr(model, "class") %in% c("std::runtime_error", "C++Error", "error"))) { + if (inherits(model, c("std::runtime_error", "C++Error", "try-error"))) { if (model == "(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate") ANOVAsummary$setError( gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.") From 2597ebdbf3b76d677b300e4837c4df3b13e12f51 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 14 Jul 2021 09:34:36 +0200 Subject: [PATCH 24/38] (oops, embarrassing) fixing default links for GLMMs --- inst/qml/MixedModelsBGLMM.qml | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/inst/qml/MixedModelsBGLMM.qml b/inst/qml/MixedModelsBGLMM.qml index 80e06216..a464a0a1 100644 --- a/inst/qml/MixedModelsBGLMM.qml +++ b/inst/qml/MixedModelsBGLMM.qml @@ -92,6 +92,7 @@ Form { property var familyMap: { "binomial": ["logit", "probit", "cauchit", "cloglog", "log"], + "binomialAgg": ["logit", "probit", "cauchit", "cloglog", "log"], "gaussian": ["identity", "log", "inverse"], "Gamma": ["identity", "log", "inverse"], "inverse.gaussian": ["identity", "log", "inverse"], @@ -100,6 +101,18 @@ Form { "betar": ["logit", "probit", "cauchit", "cloglog", "log"] } + property var familyDefault: + { + "binomial": "logit", + "binomialAgg": "logit", + "gaussian": "identity", + "Gamma": "log", + "inverse.gaussian": "log", + "poisson": "log", + "neg_binomial_2": "log", + "betar": "logit" + } + onCurrentValueChanged: { if (!familyMap[currentValue].includes(link.value)) @@ -126,7 +139,7 @@ Form { label: qsTr("Logit") value: "logit" visible: family.familyMap[family.currentValue].includes(value) - checked: true + checked: family.familyDefault[family.currentValue] == "logit" } RadioButton @@ -134,6 +147,7 @@ Form { label: qsTr("Probit") value: "probit" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "probit" } RadioButton @@ -141,6 +155,7 @@ Form { label: qsTr("Cauchit") value: "cauchit" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "cauchit" } RadioButton @@ -148,6 +163,7 @@ Form { label: qsTr("Complementary LogLog") value: "cloglog" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "cloglog" } RadioButton @@ -155,6 +171,7 @@ Form { label: qsTr("Identity") value: "identity" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "identity" } RadioButton @@ -162,6 +179,7 @@ Form { label: qsTr("Log") value: "log" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "log" } RadioButton @@ -169,6 +187,7 @@ Form { label: qsTr("Sqrt") value: "sqrt" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "sqrt" } RadioButton @@ -176,6 +195,7 @@ Form { label: qsTr("Inverse") value: "inverse" visible: family.familyMap[family.currentValue].includes(value) + checked: family.familyDefault[family.currentValue] == "inverse" } } } From bdc01b19ebdc38cbd63526e52b563d32b9d8bfc2 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 14 Jul 2021 09:42:18 +0200 Subject: [PATCH 25/38] restoring skipped B(G)LMMs summary output --- R/MixedModelsCommon.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 907c9e24..3d13586b 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -2187,7 +2187,7 @@ return() model <- jaspResults[["mmModel"]]$object$model - if (!is.null(model) && jaspBase::isTryError(jaspResults[["mmModel"]]$object$model)) { + if (!is.null(model) && !jaspBase::isTryError(model)) { modelSummary <- summary( model, From 17496aa9acf67cf6e0475a33ce53d1530cc1acd3 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 14 Jul 2021 10:02:05 +0200 Subject: [PATCH 26/38] try apparently appends call information to the error messages..., boy, how much I love tryCatch :) --- R/MixedModelsCommon.R | 35 +++++------------------------------ R/MixedModelsMessages.R | 12 ++++++++++++ 2 files changed, 17 insertions(+), 30 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 3d13586b..c829af00 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -550,35 +550,10 @@ ANOVAsummary$dependOn(c(dependencies, seedDependencies, "pvalVS")) - # some error managment for GLMMS - and oh boy, they can fail really easily - if (type %in% c("LMM", "GLMM") && !is.null(model)) { - if (inherits(model, c("std::runtime_error", "C++Error", "try-error"))) { - if (model == "(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate") - ANOVAsummary$setError( - gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.") - ) - - else if (model == "PIRLS loop resulted in NaN value") - ANOVAsummary$setError( - gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data or an overly complex model structure. Try removing some of the predictors.") - ) - - else if (model == "cannot find valid starting values: please specify some") - # currently no solution to this, it seems to be a problem with synthetic data only. - # I will try silving it once someone actually has problem with real data. - ANOVAsummary$setError(gettext("The optimizer failed to find a solution due to invalid starting values. (JASP currently does not support specifying different starting values.)")) - - else if (model == "Downdated VtV is not positive definite") - ANOVAsummary$setError(gettext("The optimizer failed to find a solution. Probably due to scaling issues quasi-separation in the data. Try rescaling or removing some of the predictors.")) - - - else - ANOVAsummary$setError(model) - - - return() - } - + # some error management for GLMMS - and oh boy, they can fail really easily + if (!is.null(model) && inherits(model, c("std::runtime_error", "C++Error", "try-error"))) { + ANOVAsummary$setError(.mmErrorOnFit(model)) + return() } @@ -1944,7 +1919,7 @@ } if (jaspBase::isTryError(model)) { - if (model == "Dropping columns failed to produce full column rank design matrix") + if (grepl("Dropping columns failed to produce full column rank design matrix", model)) .quitAnalysis(gettext("The specified combination of factors does not produce an estimable model. A factor or combination of factors resulted in more levels than the effective sample size.")) else .quitAnalysis(paste0(gettext("Please, report the following error message at JASP GitHub https://github.com/jasp-stats/jasp-issues: "), model)) diff --git a/R/MixedModelsMessages.R b/R/MixedModelsMessages.R index 7af3c965..7a7ace55 100644 --- a/R/MixedModelsMessages.R +++ b/R/MixedModelsMessages.R @@ -209,3 +209,15 @@ return(gettext("The model was fitted using maximum likelihood.")) } } +.mmErrorOnFit <- function(error) { + if (grepl("(maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate", error)) + return(gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data. Try removing some of the predictors.")) + else if (grepl("PIRLS loop resulted in NaN value", error)) + return(gettext("The optimizer failed to find a solution. Probably due to quasi-separation in the data or an overly complex model structure. Try removing some of the predictors.")) + else if (grepl( "cannot find valid starting values: please specify some", error)) + return(gettext("The optimizer failed to find a solution due to invalid starting values. (JASP currently does not support specifying different starting values.)")) + else if (grepl("Downdated VtV is not positive definite", error)) + return(gettext("The optimizer failed to find a solution. Probably due to scaling issues quasi-separation in the data. Try rescaling or removing some of the predictors.")) + else + return(error) +} From 7a6aef2dc997549f86e69ed56fe1659db58090a0 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 14 Jul 2021 10:11:28 +0200 Subject: [PATCH 27/38] fixing autocorrelation plot - it wasn't stan but camelCasing --- R/MixedModelsCommon.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index c829af00..f8349dad 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -2608,7 +2608,7 @@ clrs <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), plotData$nchains) thm <- rstan:::rstanvis_theme() dots <- rstan:::.add_aesthetics(list(), c("size", "color", "fill")) - acDat <- rstan:::.ac_plotData(dat = plotData$samp, lags = lags, partial = FALSE) + acDat <- rstan:::.ac_plot_data(dat = plotData$samp, lags = lags, partial = FALSE) dots$position <- "dodge" dots$stat <- "summary" From 4d97bc1ab08a369d8841d52c51f82ce0f5db5c8d Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 14 Jul 2021 11:14:00 +0200 Subject: [PATCH 28/38] Should produce better error message in some of the B(G)LMM crashes --- R/MixedModelsCommon.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index f8349dad..2c8ad3e1 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -2163,12 +2163,17 @@ model <- jaspResults[["mmModel"]]$object$model if (!is.null(model) && !jaspBase::isTryError(model)) { + modelSummary <- summary( model, probs = c(.50 - options$summaryCI / 2, .50, .50 + options$summaryCI / 2), diff_intercept = options$show == "deviation" ) + + if (any(sapply(modelSummary, is.null))) + .quitAnalysis("The model summary could not be produced. Please, verify that the predictors and the outcome variable have reasonable scaling and that there are sufficient observations for each factor level.") + } else { # dummy object for creating empty summary modelSummary <- list("Model summary" = matrix(NA, nrow = 0, ncol = 0)) From 48b2f92a23858832bba907781ff3cd2f29a75745 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 14 Jul 2021 12:43:18 +0200 Subject: [PATCH 29/38] one more camelCasing error --- R/MixedModelsCommon.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 2c8ad3e1..091a7a3f 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -2304,7 +2304,7 @@ tempTable$addFootnote(.mmMessageLowBMFI(length(lowBmfi)), symbol = gettext("Warning:")) if (maxTreedepth != 0) - tempTable$addFootnote(.mmMessageMaxTreedepth(max_treedepth)) + tempTable$addFootnote(.mmMessageMaxTreedepth(maxTreedepth)) if (maxRhat > 1.01) tempTable$addFootnote(.mmMessageMaxRhat(maxRhat), symbol = gettext("Warning:")) From 32717f2c0441c108f5a74e0e215e0e186d6ee3be Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Wed, 14 Jul 2021 12:43:31 +0200 Subject: [PATCH 30/38] removing trash --- dataset.RDS | Bin 2452 -> 0 bytes options.RDS | Bin 913 -> 0 bytes 2 files changed, 0 insertions(+), 0 deletions(-) delete mode 100644 dataset.RDS delete mode 100644 options.RDS diff --git a/dataset.RDS b/dataset.RDS deleted file mode 100644 index c81981ec9b780e36de54f7e905d276e34bab9fce..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2452 zcmV;F32XKriwFP!000002JKd9R8&V6uD5`)BQ6Mnt%tDao?AyQInt;fjByGSI}URaa@Q>+NgvmsDMcKH2Q8msHVY* zp7}AyKIiMN)_ZT=d+XMVvP1}Rh-VD{W`-s*4~~>8d=!RmS3{3Cz!o895XM=}vj_*F zXRJo8`!EkY2(@N`Vinc*6#0)P*iGa551M+~?Ci-wb zg~&etqZs@UNHL5<y_B+kqR9{Zn0}OSGt_PsMAGIFxlg?wXADfWZQGEuc z;|u4d?WXHK=nXP4E>L}l2jmCDk4DvjvecmEN9?GzqwUmzds5aq(psP2PZrs^ihHx*y7ldfBkPxc~% z{?3%W;9oClUr<(SdqF?=mG%?#As=BseIH<){@!q<&I|q{^+{xP>v<%8??FeXi*KBf zF!_$~B=-Ox)9aqlG~&V4)&BW{&aq4vkzp_BL-NkJ-_Z;D!bz6VLvLd>{T-p~1PK4wpivU_i{CFa8Qp~dVR%-v0Xx5_U`;_Bg+p2}Lx zk9N=8zE}lJ?73@YWtDzb5Nh|{^@;dvzVOh!EFm&_y-;^$UAL&ITA`u-qLA+IA~cHY zo}>)>x~N<)G^tnlj*It_>^*hCBXwITW^TCsrOT!Cc;neDf~3m}@wI$2xV#eCXaeTaSfFdb>wW zvdYy74YSajk)29~rr!T{wqBVeG@X}i+*lAN=u&JyN?V;N=zFica&ls|px<(2ZuyO+ z7+c50BEDdw-XB4Mpbj92+pM-g(hDqmF zhJWD{JQnlgaMbDG^Pm?qH^!HkJ$g)-53g`{()ts-9?r>CrEjj5;-p=hlD1tZ#R*tD z!B?4_LF|OMH8Ec#FH@EYO$oo652)4&O@*7n)-TK;`7N@Pzw!@uZ5dcb^w(Sn?ULwd zh?n;2zM`Kp2!o%18w+pDzxj=h=+h0b*V@QFmGZG|#%R-<$M0Vf2r~=LZs-~E6=vtS z#OD9q3iEy|%ojN9A@)4Dz+ZH~mPPWP#O0YjY2B>jqZ^Od8|8Pyxkocu>nP!gws-w+ zzQkUL57}QE(lv7Z2YTZF2FG#xv=g(Wd!a_5c|p@8f7TXkt+bnkxow*RoTFWg;wZ+) z=sb{j;6JEC^gV-oW{*S`XP+?C5BnY^*u_q&W9~U#)^E6g9wR@19xzA=A zW%yL zwSU8WaJNIFR_rv2Pu->=Kj%HnB=OKk4Lp^eo{Z6|gA=mvUnb{d4k8hL7#D}p=v@rX4cH^nNoNivxzk}b^XU;E-QON{R2zL56q7(xIFj#K_aJ0%vUNO zF-k0mb99i=`Gk?OJf~#$B+RZE-Ed*`M$8@?wSR;&#@vrK*N0s^W#mW5V|~KzlXnkf zVstrIyLi!I>HY953NP)OjoHOxOJk z#r)7zC%&^_Bv<^d!Km}4E%iBo;dHKaY*ENt5CreqWG2oCEH^zS>2WzHd547xS%_@4Acm$WDC~j{?bh$Yb$6!;F08 z>A_L9M(3#S-qY@^Lh?){RIW>8v zp`~k4V7t8}borgIdjXigBy@iPm{EAq3vT_Az_$VC4$$K{(K2Bjp92;xVA}!uim>be zy;`8N33UA(aOway&jE)v(9;C0o)euY*mnSq!fPGCr497%0IyT%(+*rsz^xs;A)=oN zxKsE;8}KkjbE#zXqMtm(>d45Up@4>u*kI)f(()xOHEC&}rBIO;S*Mhf7LlSP>y$)? zl1NdJ9X@2tmuORySvA?KChPpXNsH|8BeNPZt05L>U>zs-_LiD0Mm3}0 zeWa$eO(AVl$fc%2YD&Tsk}!i0pN5KsP__AxwSM=KVyDN$yT^-zJ;GyC{t}#=IBR-R zjF-|YCNybsa$I~|TeF&WXZ_lp^_FH^8)Y#wIn4_UYc3CL7Ha-AKfi6B&oVAHHP&m& SOv9GuGyVq}wroufApiiD;qVp! diff --git a/options.RDS b/options.RDS deleted file mode 100644 index 76f6d653b6314be551a87ed9b358d3dc6e4d38be..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 913 zcmV;C18)2uiwFP!000002JKc)Z__Xo&-!PyUD-M|_yn9Mwh3vR*3osaX%p2_!ETjl z+{BRBQS5db2fhbf_z0Z&9DD~PE{G$if#cYzoi$svRh(w2b^PA*@4dW#c_%f?vWiw| zj{leWqcz{^tZzKsu&lxgKW)jqA$Klj)#T29rGnT?R+aB%3<5|K;gndX9vS*h8~2F= z`S~IrXzuUb-MhPYcmKy-L#`p^sx5+91Sq4Dupfl*S2Lsqo zg%<@)2`cLS07Ndrz(0ZjE8>IDCyeg65p)5A&Z`lOB&Q}g9e|;4P`VN5E9LWoa-tMO z06QcwZCOf)S!0$d2tprWS25P}7#j+RMce^2>zIXv+>QTD$+1e|XDg0TycXklZ2$Ze zug~h-tXOL4@p^OsXxJkDFu=XF&9z<gmXIhmWq2{@|03K?FmcXDe@JO~DF>p>8T6$wT?Y_D(;;-ZXFG%< z%@+dbSY-bQ+USF_V>L_f!ZW5DeF=WzOeSFHbI|AAoeZ(VD}+S)t8!2CeDR3t3Ux`; z-M=DeZOTx<;b~XP3SkP3{iX6p5RO0?@`+5>*3cPy$oCBkCH)X#*gX&7Brw|pDI<5( z^k87h%x3tks~NMy5pFz?mMBcS?>!2cJwBHBn18CwjGy<~`srAms&p9ed_QmPtGAFt nt`V?BbMn1<9AlBL From b233e758d5dc2a7db0343ed4fed583564b25e2e0 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Thu, 15 Jul 2021 10:54:59 +0200 Subject: [PATCH 31/38] clarifying documentation for B(G)LMM --- inst/help/MixedModelsBGLMM.md | 2 +- inst/help/MixedModelsBLMM.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/inst/help/MixedModelsBGLMM.md b/inst/help/MixedModelsBGLMM.md index 031c9211..1d95ef54 100644 --- a/inst/help/MixedModelsBGLMM.md +++ b/inst/help/MixedModelsBGLMM.md @@ -9,7 +9,7 @@ Bayesian Generalized Linear Mixed Models allow you to model a linear relationshi - Homoscedasticity: The error variance of each predictor is constant across all values of that predictor. - Distribution of errors: The errors are distributed according to the distributional family. -The analysis uses sum contrast encoding for categorical (nominal and ordinal) predictors (R uses dummy encoding by default). This scheme is used for better interpretability of models with interactions. However, the fixed and random effects estimates will differ from those obtained from R with default settings. We advise using the 'Estimated marginal means' section for obtaining mean estimates at individual factor levels. For comparing the mean estimates, use the contrasts option. +The analysis uses orthonormal contrasts such that the marginal prior on all fixed effects is identical for categorical (nominal and ordinal) predictors (R uses dummy encoding by default). This scheme is used for better interpretability of models with interactions. However, the fixed and random effects estimates will differ from those obtained from R with default settings. We advise using the 'Estimated marginal means' section for obtaining mean estimates at individual factor levels. For comparing the mean estimates, use the contrasts option. The analysis uses a long data format. diff --git a/inst/help/MixedModelsBLMM.md b/inst/help/MixedModelsBLMM.md index 3dec7899..7acc5d80 100644 --- a/inst/help/MixedModelsBLMM.md +++ b/inst/help/MixedModelsBLMM.md @@ -10,7 +10,7 @@ Bayesian Linear Mixed Models allow you to model a linear relationship between on - Homoscedasticity: The error variance of each predictor is constant across all values of that predictor. - Normality of errors: The errors are normally distributed with mean zero. -The analysis uses sum contrast encoding for categorical (nominal and ordinal) predictors (R uses dummy encoding by default). This scheme is used for better interpretability of models with interactions. However, the fixed and random effects estimates will differ from those obtained from R with default settings. We advise using the 'Estimated marginal means' section for obtaining mean estimates at individual factor levels. For comparing the mean estimates, use the contrasts option. +The analysis uses orthonormal contrasts such that the marginal prior on all fixed effects is identical for categorical (nominal and ordinal) predictors (R uses dummy encoding by default). This scheme is used for better interpretability of models with interactions. However, the fixed and random effects estimates will differ from those obtained from R with default settings. We advise using the 'Estimated marginal means' section for obtaining mean estimates at individual factor levels. For comparing the mean estimates, use the contrasts option. The analysis uses a long data format. From 60e4121288df12c769b84e75f4329bdfd010c46a Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Fri, 23 Jul 2021 12:18:01 +0200 Subject: [PATCH 32/38] Create Upgrades.qml --- inst/Upgrades.qml | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 inst/Upgrades.qml diff --git a/inst/Upgrades.qml b/inst/Upgrades.qml new file mode 100644 index 00000000..0ee95d7a --- /dev/null +++ b/inst/Upgrades.qml @@ -0,0 +1,34 @@ +import QtQuick 2.12 +import JASP.Module 1.0 + +Upgrades +{ + Upgrade + { + functionName: "MixedModelsLMM" + fromVersion: "0.14" + toVersion: "0.15" + + ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples" } + + } + + Upgrade + { + functionName: "MixedModelsGLMM" + fromVersion: "0.14" + toVersion: "0.15" + + ChangeRename { from: "binomial_agg"; to: "binomialAgg" } + ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples" } + } + + Upgrade + { + functionName: "MixedModelsBGLMM" + fromVersion: "0.14" + toVersion: "0.15" + + ChangeRename { from: "binomial_agg"; to: "binomialAgg" } + } +} From 87dc830049824f95b3e04021a06a7e7b65299943 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Fri, 23 Jul 2021 12:29:32 +0200 Subject: [PATCH 33/38] improving the contrast coding message in accordance with Henrik's suggestion --- R/MixedModelsCommon.R | 6 +++--- R/MixedModelsMessages.R | 4 +++- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/R/MixedModelsCommon.R b/R/MixedModelsCommon.R index 091a7a3f..83b6cd6b 100644 --- a/R/MixedModelsCommon.R +++ b/R/MixedModelsCommon.R @@ -2050,7 +2050,7 @@ REvar$addRows(tempRow) } - REvar$addFootnote(.mmMessageInterpretability) + REvar$addFootnote(.mmMessageInterpretabilityBayesian) REsummary[[paste0("VE", gi)]] <- REvar @@ -2082,7 +2082,7 @@ REcor$addRows(tempRow) } - REcor$addFootnote(.mmMessageInterpretability) + REcor$addFootnote(.mmMessageInterpretabilityBayesian) REsummary[[paste0("CE", gi)]] <- REcor @@ -2152,7 +2152,7 @@ } # add warning messages - FEsummary$addFootnote(.mmMessageInterpretability) + FEsummary$addFootnote(.mmMessageInterpretabilityBayesian) return() } diff --git a/R/MixedModelsMessages.R b/R/MixedModelsMessages.R index 7a7ace55..15ee698d 100644 --- a/R/MixedModelsMessages.R +++ b/R/MixedModelsMessages.R @@ -16,7 +16,9 @@ # .mmMessageInterpretability <- - gettext("The intercept corresponds to the (unweighted) grand mean; for each factor with k levels, k - 1 parameters are estimated. Consequently, the estimates cannot be directly mapped to factor levels.") + gettext("The intercept corresponds to the (unweighted) grand mean; for each factor with k levels, k - 1 parameters are estimated with sum contrast coding. Consequently, the estimates cannot be directly mapped to factor levels. Use estimated marginal means for obtaining estimates for each factor level/design cell or their differences.") +.mmMessageInterpretabilityBayesian <- + gettext("The intercept corresponds to the (unweighted) grand mean; for each factor with k levels, k - 1 parameters are estimated with orthonormal coding proposed by Rouder et al. (2012). Consequently, the estimates cannot be directly mapped to factor levels. Use estimated marginal means for obtaining estimates for each factor level/design cell or their differences.") .mmMessageSingularFit <- gettext("Model fit is singular. Specified random effects parameters (random intercepts and random slopes) cannot be estimated from the available data. Carefully reduce the random effects structure, but this practice might inflate the reported p-value, and invalidates the analysis.") .mmMessageVovkSellke <- From a2d185e82090abb50c7350c1849f0dc2e13105f2 Mon Sep 17 00:00:00 2001 From: FBartos <38475991+FBartos@users.noreply.github.com> Date: Mon, 26 Jul 2021 10:57:41 +0200 Subject: [PATCH 34/38] Apply suggestions from code review Co-authored-by: Simon Kucharsky --- inst/Upgrades.qml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/inst/Upgrades.qml b/inst/Upgrades.qml index 0ee95d7a..b9d90b84 100644 --- a/inst/Upgrades.qml +++ b/inst/Upgrades.qml @@ -6,7 +6,7 @@ Upgrades Upgrade { functionName: "MixedModelsLMM" - fromVersion: "0.14" + fromVersion: "0.14.3" toVersion: "0.15" ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples" } @@ -19,7 +19,11 @@ Upgrades fromVersion: "0.14" toVersion: "0.15" - ChangeRename { from: "binomial_agg"; to: "binomialAgg" } + ChangeSetValue{ + name: "family" + condition: function(options) { return options["family"] == "binomial_agg"; } + jsonValue: "binomialAgg" + } ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples" } } From 8726cdd623a96d183b788af983fb6e4125f5a8fc Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Mon, 26 Jul 2021 11:16:46 +0200 Subject: [PATCH 35/38] Update Upgrades.qml --- inst/Upgrades.qml | 80 +++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 71 insertions(+), 9 deletions(-) diff --git a/inst/Upgrades.qml b/inst/Upgrades.qml index b9d90b84..362c2947 100644 --- a/inst/Upgrades.qml +++ b/inst/Upgrades.qml @@ -9,30 +9,92 @@ Upgrades fromVersion: "0.14.3" toVersion: "0.15" - ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples" } + ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples"; } + ChangeSetValue + { + name: "plotsTheme" + condition: function(options) { return options["plotsTheme"] == "jtools::theme_apa"; } + jsonValue: "theme_apa" + } + ChangeSetValue + { + name: "plotsTheme" + condition: function(options) { return options["plotsTheme"] == "ggpubr::theme_pubr"; } + jsonValue: "theme_pubr" + } } Upgrade { functionName: "MixedModelsGLMM" - fromVersion: "0.14" + fromVersion: "0.14.3" + toVersion: "0.15" + + ChangeSetValue + { + name: "family" + condition: function(options) { return options["family"] == "binomial_agg"; } + jsonValue: "binomialAgg" + } + ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples"; } + ChangeSetValue + { + name: "plotsTheme" + condition: function(options) { return options["plotsTheme"] == "jtools::theme_apa"; } + jsonValue: "theme_apa" + } + ChangeSetValue + { + name: "plotsTheme" + condition: function(options) { return options["plotsTheme"] == "ggpubr::theme_pubr"; } + jsonValue: "theme_pubr" + } + } + + Upgrade + { + functionName: "MixedModelsBLMM" + fromVersion: "0.14.3" toVersion: "0.15" - ChangeSetValue{ - name: "family" - condition: function(options) { return options["family"] == "binomial_agg"; } - jsonValue: "binomialAgg" + ChangeSetValue + { + name: "plotsTheme" + condition: function(options) { return options["plotsTheme"] == "jtools::theme_apa"; } + jsonValue: "theme_apa" + } + ChangeSetValue + { + name: "plotsTheme" + condition: function(options) { return options["plotsTheme"] == "ggpubr::theme_pubr"; } + jsonValue: "theme_pubr" } - ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples" } } Upgrade { functionName: "MixedModelsBGLMM" - fromVersion: "0.14" + fromVersion: "0.14.3" toVersion: "0.15" - ChangeRename { from: "binomial_agg"; to: "binomialAgg" } + ChangeSetValue + { + name: "family" + condition: function(options) { return options["family"] == "binomial_agg"; } + jsonValue: "binomialAgg" + } + ChangeSetValue + { + name: "plotsTheme" + condition: function(options) { return options["plotsTheme"] == "jtools::theme_apa"; } + jsonValue: "theme_apa" + } + ChangeSetValue + { + name: "plotsTheme" + condition: function(options) { return options["plotsTheme"] == "ggpubr::theme_pubr"; } + jsonValue: "theme_pubr" + } } } From fb3daf1778a8708094189cd929591e4912fae7fa Mon Sep 17 00:00:00 2001 From: FBartos <38475991+FBartos@users.noreply.github.com> Date: Mon, 26 Jul 2021 13:33:29 +0200 Subject: [PATCH 36/38] Update inst/Upgrades.qml Co-authored-by: Simon Kucharsky --- inst/Upgrades.qml | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/inst/Upgrades.qml b/inst/Upgrades.qml index 362c2947..7caa7d7e 100644 --- a/inst/Upgrades.qml +++ b/inst/Upgrades.qml @@ -10,17 +10,18 @@ Upgrades toVersion: "0.15" ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples"; } - ChangeSetValue + ChangeJS { name: "plotsTheme" - condition: function(options) { return options["plotsTheme"] == "jtools::theme_apa"; } - jsonValue: "theme_apa" - } - ChangeSetValue - { - name: "plotsTheme" - condition: function(options) { return options["plotsTheme"] == "ggpubr::theme_pubr"; } - jsonValue: "theme_pubr" + jsFunction: function(options) + { + switch(options["plotsTheme"]) + { + case "jtools::theme_apa": return "theme_apa"; + case "ggpubr::theme_pubr": return "theme_pubr"; + default: return options["plotsTheme"] + } + } } } From 96471fd44716626dd2de2b0348226209233eab28 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Mon, 26 Jul 2021 13:35:28 +0200 Subject: [PATCH 37/38] Update Upgrades.qml --- inst/Upgrades.qml | 58 ++++++++++++++++++++++++----------------------- 1 file changed, 30 insertions(+), 28 deletions(-) diff --git a/inst/Upgrades.qml b/inst/Upgrades.qml index 7caa7d7e..466d330a 100644 --- a/inst/Upgrades.qml +++ b/inst/Upgrades.qml @@ -23,7 +23,6 @@ Upgrades } } } - } Upgrade @@ -39,17 +38,18 @@ Upgrades jsonValue: "binomialAgg" } ChangeRename { from: "bootstrap_samples"; to: "bootstrapSamples"; } - ChangeSetValue - { - name: "plotsTheme" - condition: function(options) { return options["plotsTheme"] == "jtools::theme_apa"; } - jsonValue: "theme_apa" - } - ChangeSetValue + ChangeJS { name: "plotsTheme" - condition: function(options) { return options["plotsTheme"] == "ggpubr::theme_pubr"; } - jsonValue: "theme_pubr" + jsFunction: function(options) + { + switch(options["plotsTheme"]) + { + case "jtools::theme_apa": return "theme_apa"; + case "ggpubr::theme_pubr": return "theme_pubr"; + default: return options["plotsTheme"] + } + } } } @@ -59,17 +59,18 @@ Upgrades fromVersion: "0.14.3" toVersion: "0.15" - ChangeSetValue - { - name: "plotsTheme" - condition: function(options) { return options["plotsTheme"] == "jtools::theme_apa"; } - jsonValue: "theme_apa" - } - ChangeSetValue + ChangeJS { name: "plotsTheme" - condition: function(options) { return options["plotsTheme"] == "ggpubr::theme_pubr"; } - jsonValue: "theme_pubr" + jsFunction: function(options) + { + switch(options["plotsTheme"]) + { + case "jtools::theme_apa": return "theme_apa"; + case "ggpubr::theme_pubr": return "theme_pubr"; + default: return options["plotsTheme"] + } + } } } @@ -85,17 +86,18 @@ Upgrades condition: function(options) { return options["family"] == "binomial_agg"; } jsonValue: "binomialAgg" } - ChangeSetValue - { - name: "plotsTheme" - condition: function(options) { return options["plotsTheme"] == "jtools::theme_apa"; } - jsonValue: "theme_apa" - } - ChangeSetValue + ChangeJS { name: "plotsTheme" - condition: function(options) { return options["plotsTheme"] == "ggpubr::theme_pubr"; } - jsonValue: "theme_pubr" + jsFunction: function(options) + { + switch(options["plotsTheme"]) + { + case "jtools::theme_apa": return "theme_apa"; + case "ggpubr::theme_pubr": return "theme_pubr"; + default: return options["plotsTheme"] + } + } } } } From ef44c5522474b048f8eb057a9fd1b2ba697ec086 Mon Sep 17 00:00:00 2001 From: Frantisek Bartos Date: Tue, 3 Aug 2021 10:20:53 +0200 Subject: [PATCH 38/38] translation issues https://github.com/orgs/jasp-stats/teams/translators/discussions/1?from_comment=2 --- R/MixedModelsMessages.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/MixedModelsMessages.R b/R/MixedModelsMessages.R index 15ee698d..0b49919e 100644 --- a/R/MixedModelsMessages.R +++ b/R/MixedModelsMessages.R @@ -68,8 +68,8 @@ sprintf( ngettext( length(terms), - "Random slopes of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slopes of '%s' for random effects grouping factor '%s'.", "Random slope of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slope of '%s' for random effects grouping factor '%s'.", + "Random slopes of ‘%s’ for the random effects grouping factor ‘%s’ removed -- Too few observations to estimate random slopes of '%s' for random effects grouping factor '%s'." ), paste0("'", terms, "'", collapse = ", "), grouping, @@ -165,8 +165,8 @@ sprintf( ngettext( iterations, - "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transition exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth", - "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transitions exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth" + "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transition exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth'.", + "The Hamiltonian Monte Carlo procedure might be inefficient -- %i transitions exceeded the maximum tree depth. This can be solved by carefully increasing 'Maximum tree depth'." ), iterations ) @@ -198,8 +198,8 @@ sprintf( ngettext( n_bad, - "LOO estimate unreliable -- There was %1.0f observation with the shape parameter (k) of the generalized Pareto distribution higher than > .5.", - "LOO estimate unreliable -- There were %1.0f observations with the shape parameter (k) of the generalized Pareto distribution higher than > .5." + "LOO estimate unreliable -- There was %1.0f observation with the shape parameter (k) of the generalized Pareto distribution higher than 0.5.", + "LOO estimate unreliable -- There were %1.0f observations with the shape parameter (k) of the generalized Pareto distribution higher than 0.5." ), n_bad )