From c72a3785b86dbcc931825f5e3b9cead483e0e9a8 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Thu, 15 May 2025 20:25:21 +0200 Subject: [PATCH 01/65] Creating Bayesian Gauge R&R Analysis - Initial QML & R-code development --- DESCRIPTION | 2 +- NAMESPACE | 3 +- R/msaBayesianGaugeRR.R | 169 +++++++++ inst/Description.qml | 7 + inst/qml/msaBayesianGaugeRR.qml | 601 ++++++++++++++++++++++++++++++++ man/dot-PRESS.Rd | 13 + man/dot-pred_r_squared.Rd | 13 + renv.lock | 18 +- 8 files changed, 810 insertions(+), 16 deletions(-) create mode 100644 R/msaBayesianGaugeRR.R create mode 100644 inst/qml/msaBayesianGaugeRR.qml create mode 100644 man/dot-PRESS.Rd create mode 100644 man/dot-pred_r_squared.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 8b0c9119..52791540 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -43,4 +43,4 @@ Remotes: jasp-stats/jaspDescriptives, jasp-stats/jaspGraphs Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.2 +RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index ccae865c..058e5c01 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,6 +5,7 @@ export(doeAnalysis) export(doeFactorial) export(doeResponseSurfaceMethodology) export(msaAttribute) +export(msaBayesianGaugeRR) export(msaGaugeLinearity) export(msaGaugeRR) export(msaGaugeRRnonrep) @@ -12,8 +13,8 @@ export(msaTestRetest) export(msaType1Gauge) export(probabilityOfDetection) export(processCapabilityStudies) -export(timeWeightedCharts) export(rareEventCharts) +export(timeWeightedCharts) export(variablesChartsIndividuals) export(variablesChartsSubgroups) importFrom(jaspBase,.extractErrorMessage) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R new file mode 100644 index 00000000..ef06ffc0 --- /dev/null +++ b/R/msaBayesianGaugeRR.R @@ -0,0 +1,169 @@ +# +# Copyright (C) 2013-2018 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 . +# + +#' @export +msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { + # Reading the data in the correct format + wideFormat <- options[["dataFormat"]] == "wideFormat" + if (wideFormat) { + measurements <- unlist(options[["measurementsWideFormat"]]) + parts <- unlist(options[["partWideFormat"]]) + operators <- unlist(options[["operatorWideFormat"]]) + } else { + measurements <- unlist(options[["measurementLongFormat"]]) + parts <- unlist(options[["partLongFormat"]]) + operators <- unlist(options[["operatorLongFormat"]]) + } + + #ready statement + if (wideFormat && !options[["type3"]]) { + ready <- (length(measurements) > 1 && !identical(operators, "") && !identical(parts, "")) + } else if (wideFormat && options[["type3"]]) { + ready <- (length(measurements) > 1 && !identical(parts, "")) + } else if (!wideFormat && !options[["type3"]]) { + ready <- (measurements != "" && !identical(operators, "") && !identical(parts, "")) + } else if (!wideFormat && options[["type3"]]) { + ready <- (!identical(measurements, "") && !identical(parts, "")) + } + + + numeric.vars <- measurements + numeric.vars <- numeric.vars[numeric.vars != ""] + factor.vars <- c(parts, operators) + factor.vars <- factor.vars[factor.vars != ""] + + if (is.null(dataset)) { + dataset <- .readDataSetToEnd(columns.as.numeric = numeric.vars, columns.as.factor = factor.vars) + if (options$type3){ + dataset$operators <- rep(1, nrow(dataset)) + operators <- "operators" + } + } + + # Checking for infinity and missingValues + .hasErrors(dataset, type = c('infinity', 'missingValues'), + infinity.target = measurements, + missingValues.target = c(measurements, parts, operators), + exitAnalysisIfErrors = TRUE) + + #Converting long to wide data + # if (!wideFormat && ready) { + # dataset <- dataset[order(dataset[[operators]]),] + # dataset <- dataset[order(dataset[[parts]]),] + # nrep <- table(dataset[operators])[[1]]/length(unique(dataset[[parts]])) + # index <- rep(paste("V", 1:nrep, sep = ""), nrow(dataset)/nrep) + # dataset <- cbind(dataset, data.frame(index = index)) + # dataset <- tidyr::spread(dataset, index, measurements) + # measurements <- unique(index) + # dataset <- dataset[,c(operators, parts, measurements)] + # } else if (ready) { + # dataset <- dataset[order(dataset[[parts]]),] + # } + + if(ready && !options[["type3"]]){ + crossed <- .checkIfCrossed(dataset, operators, parts, measurements) + if(!crossed){ + plot <- createJaspPlot(title = gettext("Gauge r&R"), width = 700, height = 400) + jaspResults[["plot"]] <- plot + plot$setError(gettext("Design is not balanced: not every operator measured every part. Use non-replicable gauge r&R.")) + return() + } + } + + # Checking type 3 + Type3 <- c(length(unique(dataset[[operators]])) == 1 || options$type3) + + # Errors # + # Checking whether type3 is used correctly + .hasErrors(dataset, + target = measurements, + custom = function() { + if (Type3 && !options$type3) + return("This dataset seems to have only a single unique operator. Please use the Type 3 study by checking the box below.")}, + exitAnalysisIfErrors = TRUE) + # Checking whether the format wide is used correctly + if (ready) + .hasErrors(dataset, + target = measurements, + custom = function() { + dataToBeChecked <- dataset[dataset[[operators]] == dataset[[operators]][1],] + partsLevels <- length(levels(dataToBeChecked[[parts]])) + partsLength <- length(dataToBeChecked[[parts]]) + if (wideFormat && partsLevels != partsLength && !Type3) + return(gettextf("The measurements selected seem to be in a 'Single Column' format as every operator's part is measured %d times.", partsLength/partsLevels))}, + exitAnalysisIfErrors = FALSE) + + + saveRDS(options, "/Users/julian/Documents/Jasp files/options.rds") + saveRDS(dataset, "/Users/julian/Documents/Jasp files/dataset.rds") + saveRDS(measurements, "/Users/julian/Documents/Jasp files/measurements.rds") + saveRDS(operators, "/Users/julian/Documents/Jasp files/operators.rds") + saveRDS(parts, "/Users/julian/Documents/Jasp files/parts.rds") + + # BF table + .createBFtable(jaspResults, dataset, options, measurements, parts, operators, ready) + +} + +.createBFtable <- function(jaspResults, dataset, options, measurements, parts, operators, ready) { + if(!is.null(jaspResults[["BFtable"]])) { + return() + } + + BFtable <- createJaspTable(title = gettext("Model Comparison")) + BFtable$position <- 1 + BFtable$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat")) + + jaspResults[["BFtable"]] <- BFtable + + BFtable$addColumnInfo(name = "modelName", title = gettext("Model"), type = "string") + BFtable$addColumnInfo(name = "BF", title = gettext("BF01"), type = "number") + + # return empty if no data is specified + if(nrow(dataset) == 0) { + return() + } + + # set data + if(ready) { # this could also be sth like if(ncol(dataset) == 3) + BFtable$setData(.getBFinteraction(dataset, measurements, parts, operators)) + BFtable$addFootnote("The Bayes factor compares the model without the interaction term to the full model.") + } + + return() +} + +.getBFinteraction <- function(dataset, measurements, parts, operators) { + # create formulae + formula_int <- as.formula(paste(measurements, "~", parts, "*", operators)) + formula <- as.formula(paste(measurements, "~", parts, "+", operators)) + + # fit BayesFactor objects + fit_int <- BayesFactor::lmBF(formula_int, whichRandom = c(parts, operators), + data = dataset) + fit <- BayesFactor::lmBF(formula, whichRandom = c(parts, operators), + data = dataset) + + # obtain BF + bf <- fit / fit_int + bf <- as.numeric(BayesFactor::extractBF(bf)["bf"]) + bf <- round(bf, 2) + + return(data.frame(modelName = "No interaction", + BF = bf)) +} diff --git a/inst/Description.qml b/inst/Description.qml index 81980d89..4a6abd31 100644 --- a/inst/Description.qml +++ b/inst/Description.qml @@ -29,6 +29,13 @@ Description title: qsTr("Type 2 and 3 Gauge r&R Study") func: "msaGaugeRR" } + + Analysis + { + title: qsTr("Type 2 and 3 Bayesian Gauge r&R Study") + func: "msaBayesianGaugeRR" + } + Analysis { title: qsTr("Gauge r&R Study (Non-replicable Measurements)") diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml new file mode 100644 index 00000000..b52e2aa2 --- /dev/null +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -0,0 +1,601 @@ +// Copyright (C) 2013-2018 University of Amsterdam +// This program is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation, either version 3 of the +// License, or (at your option) any later version. +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU Affero General Public License for more details. +// You should have received a copy of the GNU Affero General Public +// License along with this program. If not, see +// . +// + +import QtQuick +import QtQuick.Layouts +import JASP.Controls + +Form +{ + columns: 1 + + DropDown + { + name: "dataFormat" + label: qsTr("Data format") + id: dataFormat + indexDefaultValue: 0 + values: + [ + { label: qsTr("Single column"), value: "longFormat"}, + { label: qsTr("Across rows"), value: "wideFormat"}, + ] + onValueChanged: + { + measurementsWideFormat.itemDoubleClicked(0) + measurementLongFormat.itemDoubleClicked(0) + } + } + + VariablesForm + { + id: variablesFormLongFormat + visible: dataFormat.currentValue == "longFormat" + + AvailableVariablesList + { + name: "variablesFormLongFormat" + } + + AssignedVariablesList + { + name: "measurementLongFormat" + title: qsTr("Measurement") + id: measurementLongFormat + singleVariable: true + allowedColumns: ["scale"] + } + + AssignedVariablesList + { + name: "operatorLongFormat" + title: qsTr("Operator") + id: operatorLongFormat + singleVariable: true + allowedColumns: ["nominal"] + enabled: !type3.checked + } + + AssignedVariablesList + { + name: "partLongFormat" + title: qsTr("Part") + singleVariable: true + allowedColumns: ["nominal"] + } + } + + VariablesForm + { + id: variablesFormWideFormat + visible: dataFormat.currentValue == "wideFormat" + + AvailableVariablesList + { + name: "variablesFormWideFormat" + } + + AssignedVariablesList + { + name: "measurementsWideFormat" + title: qsTr("Measurements") + id: measurementsWideFormat + singleVariable: false + allowedColumns: ["scale"] + } + + AssignedVariablesList + { + name: "operatorWideFormat" + title: qsTr("Operator") + id: operatorWideFormat + singleVariable: true + allowedColumns: ["nominal"] + enabled: !type3.checked + } + + AssignedVariablesList + { + name: "partWideFormat" + title: qsTr("Part") + singleVariable: true + allowedColumns: ["nominal"] + } + } + + CheckBox + { + name: "type3" + id: type3 + label: qsTr("Type 3 study (automatic equipment)") + onCheckedChanged: + { + operatorLongFormat.itemDoubleClicked(0) + operatorWideFormat.itemDoubleClicked(0) + } + } + + Group + { + title: qsTr("Analysis options") + + DropDown + { + name: "processVariationReference" + label: qsTr("Process variation based on") + id: variationReference + indexDefaultValue: 0 + values: + [ + { label: qsTr("Study variation"), value: "studySd" }, + { label: qsTr("Historical standard deviation"), value: "historicalSd" } + ] + } + + DoubleField + { + name: "historicalSdValue" + label: qsTr("Historical standard deviation:") + defaultValue: 3 + min: 0.000000001 + decimals: 9 + enabled: variationReference.currentValue == "historicalSd" + } + + CheckBox + { + name: "tolerance" + label: qsTr("Tolerance width") + childrenOnSameRow: true + + DoubleField + { + name: "toleranceValue" + id: toleranceValue + defaultValue: 10 + min: 0.000000001 + decimals: 9 + } + } + + CheckBox + { + name: "RRTable" + label: qsTr("r&R table") + checked: true + + DoubleField + { + name: "anovaBFForInteractionRemoval" + label: qsTr("BF interaction removal") + fieldWidth: 60 + defaultValue: 10 + min: 0 + decimals: 3 + } + + DropDown + { + name: "studyVarianceMultiplierType" + label: qsTr("Study var. multiplier type") + id: studyVarianceMultiplierType + indexDefaultValue: 0 + values: + [ + { label: qsTr("Std. Deviation"), value: "sd" }, + { label: qsTr("Percent"), value: "percent" } + ] + } + + DoubleField + { + name: "studyVarianceMultiplierValue" + label: qsTr("Study var. multiplier value") + fieldWidth: 60 + defaultValue: 6 + min: 0.001 + max: 99.999 + decimals: 3 + } + } + } + + Section + { + title: qsTr("Plots") + columns: 2 + + Group + { + CheckBox + { + name: "priorPlot" + label: qsTr("Prior") + checked: true + } + + CheckBox + { + name: "posteriorPlot" + label: qsTr("Posterior") + checked: true + } + } + + Group + { + CheckBox + { + name: "varianceComponentsGraph" + label: qsTr("Components of variation") + checked: true + } + + CheckBox + { + name: "rChart" + label: qsTr("Range charts by operator") + enabled: !type3.checked + } + + CheckBox + { + name: "xBarChart" + label: qsTr("Average chart by operator") + enabled: !type3.checked + } + + CheckBox + { + name: "scatterPlot" + label: qsTr("Scatter plots operators") + enabled: !type3.checked + + CheckBox + { + name: "scatterPlotFitLine" + label: qsTr("Fit line") + } + + CheckBox + { + name: "scatterPlotOriginLine" + label: qsTr("Show origin line") + } + } + + CheckBox + { + name: "partMeasurementPlot" + label: qsTr("Measurements by part plot") + + CheckBox + { + name: "partMeasurementPlotAllValues" + label: qsTr("Display all measurements") + } + } + + CheckBox + { + name: "operatorMeasurementPlot" + label: qsTr("Measurements by operator plot") + enabled: !type3.checked + } + + CheckBox + { + name: "partByOperatorMeasurementPlot" + label: qsTr("Part × operator interaction plot") + enabled: !type3.checked + } + + CheckBox + { + name: "trafficLightChart" + label: qsTr("Traffic light chart") + } + } + } + + Section + { + title: qsTr("Advanced options") + + Group + { + title: qsTr("Priors") + + DoubleField + { + name: "rscalePrior" + label: qsTr("r scale prior") + defaultValue: 1 + min: 0.001 + max: 10 + decimals: 3 + } + } + + Group + { + SetSeed{} + } + + Group + { + title: qsTr("MCMC options") + + DoubleField + { + name: "mcmcChains" + label: qsTr("Chains") + defaultValue: 2 + min: 1 + max: 10 + decimals: 0 + } + + DoubleField + { + name: "mcmcIterations" + label: qsTr("Iterations per chain") + id: mcmcIterations + defaultValue: 10000 + min: 1 + max: 100000 + decimals: 0 + fieldWidth: 60 + } + + DoubleField + { + name: "mcmcBurnin" + label: qsTr("Burn-in per chain") + defaultValue: 2000 + min: 1 + max: mcmcIterations.value / 2 + decimals: 0 + fieldWidth: 60 + } + } + } + + Section + { + title: qsTr("Report options") + + CheckBox + { + name: "report" + label: qsTr("Show Report") + id: anovaGaugeReport + columns: 1 + + CheckBox + { + name: "reportMetaData" + label: qsTr("Show report metadata") + checked: true + columns: 2 + + CheckBox + { + name: "reportTitle" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportTitleText" + label: qsTr("Title") + id: reportTitleText + placeholderText: qsTr("Gauge r&R Report") + fieldWidth: 100 + } + } + + CheckBox + { + name: "reportPartName" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportPartNameText" + label: qsTr("Part name") + id: reportPartNameText + placeholderText: qsTr("Name") + fieldWidth: 100 + } + } + + + CheckBox + { + name: "reportGaugeName" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportGaugeNameText" + label: qsTr("Gauge name") + id: reportGaugeNameText + placeholderText: qsTr("Name") + fieldWidth: 100 + } + } + + CheckBox + { + name: "reportCharacteristic" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportCharacteristicText" + label: qsTr("Characteristic") + id: reportCharacteristicText + placeholderText: qsTr("Characteristic") + fieldWidth: 100 + } + } + + CheckBox + { + name: "reportGaugeNumber" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportGaugeNumberText" + label: qsTr("Gauge number") + id: reportGaugeNumberText + placeholderText: qsTr("Number") + fieldWidth: 100 + } + } + + CheckBox + { + name: "reportTolerance" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportToleranceText" + label: qsTr("Tolerance") + id: reportToleranceText + placeholderText: qsTr("Tolerance") + fieldWidth: 100 + } + } + + CheckBox + { + name: "reportLocation" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportLocationText" + label: qsTr("Location") + id: reportLocationText + placeholderText: qsTr("Location") + fieldWidth: 100 + } + } + + CheckBox + { + name: "reportPerformedBy" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportPerformedByText" + label: qsTr("Performed by") + id: reportPerformedByText + placeholderText: qsTr("Analyst") + fieldWidth: 100 + } + } + + CheckBox + { + name: "reportDate" + checked: true + childrenOnSameRow: true + + TextField + { + name: "reportDateText" + label: qsTr("Date") + id: reportDate + placeholderText: qsTr("Date") + fieldWidth: 100 + } + } + } + + Group + { + title: qsTr("Select Report Components") + + CheckBox + { + name: "reportGaugeTable" + label: qsTr("Show gauge evaluation table") + checked: true + } + + CheckBox + { + name: "reportVariationComponents" + label: qsTr("Show components of variation") + checked: true + } + + CheckBox + { + name: "reportMeasurementsByPartPlot" + label: qsTr("Show measurements by part") + checked: true + } + + CheckBox + { + name: "reportRChartByOperator" + label: qsTr("Show range charts by operator") + checked: true + } + + CheckBox + { + name: "reportMeasurementsByOperatorPlot" + label: qsTr("Show measurements by operator") + checked: true + } + + CheckBox + { + name: "reportAverageChartByOperator" + label: qsTr("Show average charts by operator") + checked: true + } + + CheckBox + { + name: "reportPartByOperatorPlot" + label: qsTr("Show part × operator interaction") + checked: true + } + + CheckBox + { + name: "reportTrafficLightChart" + label: qsTr("Show traffic light chart") + checked: true + } + } + } + } +} \ No newline at end of file diff --git a/man/dot-PRESS.Rd b/man/dot-PRESS.Rd new file mode 100644 index 00000000..4d5e7692 --- /dev/null +++ b/man/dot-PRESS.Rd @@ -0,0 +1,13 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/doeAnalysis.R +\name{.PRESS} +\alias{.PRESS} +\title{calculate the predictive residuals +calculate the PRESS} +\usage{ +.PRESS(linear.model) +} +\description{ +calculate the predictive residuals +calculate the PRESS +} diff --git a/man/dot-pred_r_squared.Rd b/man/dot-pred_r_squared.Rd new file mode 100644 index 00000000..4446c563 --- /dev/null +++ b/man/dot-pred_r_squared.Rd @@ -0,0 +1,13 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/doeAnalysis.R +\name{.pred_r_squared} +\alias{.pred_r_squared} +\title{Use anova() to get the sum of squares for the linear model +Calculate the total sum of squares} +\usage{ +.pred_r_squared(linear.model) +} +\description{ +Use anova() to get the sum of squares for the linear model +Calculate the total sum of squares +} diff --git a/renv.lock b/renv.lock index c09b2757..1a0102b2 100644 --- a/renv.lock +++ b/renv.lock @@ -174,15 +174,9 @@ }, "RcppArmadillo": { "Package": "RcppArmadillo", - "Version": "14.4.1-1", + "Version": "14.4.2-1", "Source": "Repository", - "Requirements": [ - "R", - "Rcpp", - "stats", - "utils", - "methods" - ] + "Repository": "CRAN" }, "RcppEigen": { "Package": "RcppEigen", @@ -1881,13 +1875,9 @@ }, "svglite": { "Package": "svglite", - "Version": "2.1.3", + "Version": "2.2.1", "Source": "Repository", - "Requirements": [ - "R", - "systemfonts", - "cpp11" - ] + "Repository": "CRAN" }, "sys": { "Package": "sys", From 0558b509208d0b65149586c878e9b76af771b78f Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 20 May 2025 17:24:00 +0200 Subject: [PATCH 02/65] Model comparison & analysis of effects Adding model comparison and analysis of effects output tables based on the BayesFactor package --- R/msaBayesianGaugeRR.R | 145 ++++++++++++++++++++++++++------ inst/qml/msaBayesianGaugeRR.qml | 7 ++ 2 files changed, 126 insertions(+), 26 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index ef06ffc0..de84bd04 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -114,12 +114,29 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { saveRDS(operators, "/Users/julian/Documents/Jasp files/operators.rds") saveRDS(parts, "/Users/julian/Documents/Jasp files/parts.rds") - # BF table - .createBFtable(jaspResults, dataset, options, measurements, parts, operators, ready) + # Results from model comparison + if(ready & (options[["RRTable"]] | options[["effectsTable"]])){ + compRes <- .runBFtest(dataset, measurements, parts, operators, options) + } + + # Model comparison table + if(options[["RRTable"]]){ + .createBFtable(compRes, jaspResults, dataset, options, measurements, parts, operators, ready) + } + + # Effects table + if(options[["effectsTable"]]){ + .createEffectsTable(compRes, jaspResults, measurements, parts, operators, ready) + } } -.createBFtable <- function(jaspResults, dataset, options, measurements, parts, operators, ready) { + + + + + +.createBFtable <- function(compRes, jaspResults, dataset, options, measurements, parts, operators, ready) { if(!is.null(jaspResults[["BFtable"]])) { return() } @@ -127,43 +144,119 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { BFtable <- createJaspTable(title = gettext("Model Comparison")) BFtable$position <- 1 BFtable$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat")) + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable")) jaspResults[["BFtable"]] <- BFtable - BFtable$addColumnInfo(name = "modelName", title = gettext("Model"), type = "string") - BFtable$addColumnInfo(name = "BF", title = gettext("BF01"), type = "number") + BFtable$addColumnInfo(name = "modelName", title = gettext("Models"), type = "string") + BFtable$addColumnInfo(name = "modelPrior", title = gettext("P(M)"), type = "number") + BFtable$addColumnInfo(name = "modelPosterior", title = gettext("P(M|data)"), type = "number") + BFtable$addColumnInfo(name = "modelBF", title = gettext("BFM"), type = "number") + BFtable$addColumnInfo(name = "comparisonBF", title = gettext("BF01"), type = "number") + + # set data + if(ready) { # this could also be sth like if(ncol(dataset) == 3) + BFtable$setData(compRes) + BFtable$addFootnote("BF01 compares every model to the null model.") + } + + return() +} + +.runBFtest <- function(dataset, measurements, parts, operators, options) { + formula <- as.formula(paste(measurements, "~", parts, "*", operators)) + + if(options$setSeed) { + set.seed(options$seed) + } + # run general comparison for all potential models + bf_fit <- BayesFactor::generalTestBF(formula, data = dataset, + # whichRandom = c(operators, parts), + # rscaleRandom = options$rscalePrior, + progress = F) + bf_df <- as.data.frame(bf_fit) + + # add null model + bf_df["Null model", ] <- c(1, rep(NA, 3)) + + # add prior model probabilities + bf_df$prior <- rep(1 / nrow(bf_df), nrow(bf_df)) # uniform for now + + # compute P(M | data) + bf_df <- within(bf_df, unnormalised <- bf * prior) + bf_df <- within(bf_df, posterior <- unnormalised / sum(unnormalised)) + + # dropping unnecessary columns + bf_df <- bf_df[, !colnames(bf_df) %in% c("error", "time", "code", "unnormalised")] + colnames(bf_df) <- c("comparisonBF", "modelPrior", "modelPosterior") + bf_df$modelName <- rownames(bf_df) + + # compute BF_M as the ratio of posterior to prior odds + bf_df <- within(bf_df, modelBF <- ( modelPosterior / (1-modelPosterior) ) / ( modelPrior / (1-modelPrior) ) ) - # return empty if no data is specified - if(nrow(dataset) == 0) { + bf_df <- bf_df[order(-bf_df$modelBF), ] + + return(bf_df) + +} + +.createEffectsTable <- function(compRes, jaspResults, measurements, parts, operators, ready) { + if(!is.null(jaspResults[["effectsTable"]])) { return() } + effectsTable <- createJaspTable(title = gettext(paste("Analysis of Effects -", measurements))) + effectsTable$position <- 2 + effectsTable$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "effectsTable")) + + jaspResults[["effectsTable"]] <- effectsTable + + effectsTable$addColumnInfo(name = "effectName", title = gettext("Effects"), type = "string") + effectsTable$addColumnInfo(name = "priorInclusion", title = gettext("P(incl)"), type = "number") + effectsTable$addColumnInfo(name = "priorExclusion", title = gettext("P(excl)"), type = "number") + effectsTable$addColumnInfo(name = "posteriorInclusion", title = gettext("P(incl|data)"), type = "number") + effectsTable$addColumnInfo(name = "posteriorExclusion", title = gettext("P(excl|data)"), type = "number") + effectsTable$addColumnInfo(name = "inclusionBF", title = gettext("BFincl"), type = "number") + effectsTable$addColumnInfo(name = "exclusionBF", title = gettext("BFexcl"), type = "number") + # set data - if(ready) { # this could also be sth like if(ncol(dataset) == 3) - BFtable$setData(.getBFinteraction(dataset, measurements, parts, operators)) - BFtable$addFootnote("The Bayes factor compares the model without the interaction term to the full model.") + if(ready) { + effectsTable$setData(.fillEffectsTable(compRes, parts, operators)) } return() } -.getBFinteraction <- function(dataset, measurements, parts, operators) { - # create formulae - formula_int <- as.formula(paste(measurements, "~", parts, "*", operators)) - formula <- as.formula(paste(measurements, "~", parts, "+", operators)) +.fillEffectsTable <- function(compRes, parts, operators) { + effectName <- c(parts, operators, paste0(parts, ":", operators)) + + priorIncl <- priorExcl <- posteriorIncl <- posteriorExcl <- inclusionBF <- c() + + # loop over different effects and add P(M) and P(M | data) to obtain + # prior and posterior inclusion probabilities + for(i in seq_along(effectName)) { + effect <- grepl(effectName[i], compRes$modelName) - # fit BayesFactor objects - fit_int <- BayesFactor::lmBF(formula_int, whichRandom = c(parts, operators), - data = dataset) - fit <- BayesFactor::lmBF(formula, whichRandom = c(parts, operators), - data = dataset) + priorIncl[i] <- sum(compRes$modelPrior[effect]) + priorExcl[i] <- 1 - priorIncl[i] + + posteriorIncl[i] <- sum(compRes$modelPosterior[effect]) + posteriorExcl[i] <- 1 - posteriorIncl[i] + + inclusionBF[i] <- (posteriorIncl[i] / posteriorExcl[i]) / (priorIncl[i] / priorExcl[i]) + } + return(data.frame(effectName = effectName, + priorInclusion = priorIncl, + priorExclusion = priorExcl, + posteriorInclusion = posteriorIncl, + posteriorExclusion = posteriorExcl, + inclusionBF = inclusionBF, + exclusionBF = 1 / inclusionBF) + + ) +} - # obtain BF - bf <- fit / fit_int - bf <- as.numeric(BayesFactor::extractBF(bf)["bf"]) - bf <- round(bf, 2) +.runMCMC <- function(jaspResults, measurements, parts, operators, options){ - return(data.frame(modelName = "No interaction", - BF = bf)) } diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index b52e2aa2..bf342bbd 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -209,6 +209,13 @@ Form decimals: 3 } } + + CheckBox + { + name: "effectsTable" + label: qsTr("Effects table") + checked: false + } } Section From 5aa0a42063dd3afec285533a83db1930ddb0d0b6 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Thu, 22 May 2025 23:28:52 +0200 Subject: [PATCH 03/65] Variance components table R code for Bayesian variance components table --- R/msaBayesianGaugeRR.R | 198 +++++++++++++++++++++++++++++++++++++++-- 1 file changed, 192 insertions(+), 6 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index de84bd04..cbd1d978 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -115,7 +115,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { saveRDS(parts, "/Users/julian/Documents/Jasp files/parts.rds") # Results from model comparison - if(ready & (options[["RRTable"]] | options[["effectsTable"]])){ + if(ready){ compRes <- .runBFtest(dataset, measurements, parts, operators, options) } @@ -124,11 +124,24 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .createBFtable(compRes, jaspResults, dataset, options, measurements, parts, operators, ready) } + # Results from analysis of effects (workaround for accessing the data in jaspResults) ; could be combined with the if statement above + if(ready) { + effectsRes <- .fillEffectsTable(compRes, parts, operators) + } + # Effects table if(options[["effectsTable"]]){ - .createEffectsTable(compRes, jaspResults, measurements, parts, operators, ready) + .createEffectsTable(effectsRes, jaspResults, measurements, parts, operators, ready) } + # MCMC + if(ready) { + samplesMat <- .runMCMC(effectsRes, dataset, measurements, parts, operators, options) + } + + # Variance components table + .createVarCompTable(effectsRes, samplesMat, jaspResults, parts, operators, ready, options) + } @@ -173,7 +186,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { bf_fit <- BayesFactor::generalTestBF(formula, data = dataset, # whichRandom = c(operators, parts), # rscaleRandom = options$rscalePrior, - progress = F) + progress = FALSE) bf_df <- as.data.frame(bf_fit) # add null model @@ -200,7 +213,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } -.createEffectsTable <- function(compRes, jaspResults, measurements, parts, operators, ready) { +.createEffectsTable <- function(effectsRes, jaspResults, measurements, parts, operators, ready) { if(!is.null(jaspResults[["effectsTable"]])) { return() } @@ -222,7 +235,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # set data if(ready) { - effectsTable$setData(.fillEffectsTable(compRes, parts, operators)) + #effectsTable$setData(.fillEffectsTable(compRes, parts, operators)) + effectsTable$setData(effectsRes) } return() @@ -257,6 +271,178 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ) } -.runMCMC <- function(jaspResults, measurements, parts, operators, options){ +.createVarCompTable <- function(effectsRes, samplesMat, jaspResults, parts, operators, ready, options) { + if(!is.null(jaspResults[["varCompTable"]])) { + return() + } + + varCompTable <- createJaspTable(title = gettext("Variance Components")) + varCompTable$position <- 3 + varCompTable$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "anovaBFForInteractionRemoval", + "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference")) + + jaspResults[["varCompTable"]] <- varCompTable + + varCompTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + varCompTable$addColumnInfo(name = "postMeans", title = gettext("Mean"), type = "number") + varCompTable$addColumnInfo(name = "postSds", title = gettext("Std. Deviation"), type = "number") + varCompTable$addColumnInfo(name = "postCrIlower", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval")) + varCompTable$addColumnInfo(name = "postCrIupper", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval")) + varCompTable$addColumnInfo(name = "contribution", title = gettext("% Contribution
(Mean)"), type = "number") + + + # set data + if(ready) { + varCompTable$setData(.getVarianceComponents(effectsRes, samplesMat, parts, operators, options)) + } else { + return() + } + + return() +} + +.runMCMC <- function(effectsRes, dataset, measurements, parts, operators, options){ + # extract exclBF for interaction + excludeInter <- .evalInter(effectsRes, parts, operators, options) + if(excludeInter){ + formula <- as.formula(paste(measurements, "~", parts, "+", operators)) + } else { + formula <- as.formula(paste(measurements, "~", parts, "*", operators)) + } + + # fit the model with BayesFactor + fit <- BayesFactor::lmBF(formula, whichRandom = c(parts, operators), + data = dataset, rscaleRandom = options$rscalePrior) + + nchains <- options$mcmcChains + burnin <- options$mcmcBurnin + iter <- options$mcmcIterations + + chains <- coda::mcmc.list() + + if(options$setSeed) { + set.seed(options$seed) + } + + for(i in 1:nchains) { + # run chain + mcmcChain <- BayesFactor::posterior(fit, iterations = iter) + # exclude burn-in samples + chains[[i]] <- coda::as.mcmc(mcmcChain[-(1:burnin), ]) + } + + + # select relevant parameters + # names + # note this could be written into a helper function + sigmaPart <- paste0("g_", parts) + sigmaOperator <- paste0("g_", operators) + sigmaInter <- paste0("g_", parts, ":", operators) + + if(excludeInter){ + chains <- chains[, c(sigmaPart, sigmaOperator, "sig2")] + } else { + chains <- chains[, c(sigmaPart, sigmaOperator, sigmaInter, "sig2")] + } + + samplesMat <- as.matrix(chains) + + return(samplesMat) +} + + +.getVarianceComponents <- function(effectsRes, samplesMat, parts, operators, options) { + excludeInter <- .evalInter(effectsRes, parts, operators, options) + + # get components from MCMC samples + internalDF <- .getComponentsFromSamples(samplesMat, parts, operators, options, excludeInter) + + # %Contribution to total variance + contribution <- matrix(ncol = ncol(internalDF), nrow = nrow(internalDF)) + for(i in 1:ncol(internalDF)){ + contribution[, i] <- internalDF[[i]] / internalDF$total * 100 + } + + # calculate summary stats + postMeans <- colMeans(internalDF) + postSds <- apply(internalDF, 2, sd) + postCrIlower <- apply(internalDF, 2, quantile, probs = 0.025) + postCrIupper <- apply(internalDF, 2, quantile, probs = 0.975) + contribution <- colMeans(contribution) + + # remove some stats when historicalSd is specified + if(options$processVariationReference == "historicalSd"){ + postSds["part"] <- "" + postSds["total"] <- "" + postCrIlower["part"] <- "" + postCrIlower["total"] <- "" + postCrIupper["part"] <- "" + postCrIupper["total"] <- "" + } + + + sourceName <- c("Total gauge r&R", + "Repeatability", + "Reproducibility", + "Operator", + "Part-to-part", + "Total variation") + + return(data.frame(sourceName, + postMeans, + postSds, + postCrIlower, + postCrIupper, + contribution) + ) +} + +.getGaugeEval <- function(samplesMat){ + +} + +.evalInter <- function(effectsRes, parts, operators, options) { + ind <- effectsRes$effectName == paste0(parts, ":", operators) + excludeInter <- effectsRes[ind, "exclusionBF"] >= options$anovaBFForInteractionRemoval + + return(excludeInter) +} + +.getComponentsFromSamples <- function(samplesMat, parts, operators, options, excludeInter){ + # note this could be written into a helper function + sigmaPart <- paste0("g_", parts) + sigmaOperator <- paste0("g_", operators) + sigmaInter <- paste0("g_", parts, ":", operators) + + # obtain relevant components + if(excludeInter){ + reprod <- samplesMat[, sigmaOperator] + } else { + reprod <- samplesMat[, sigmaOperator] + samplesMat[, sigmaInter] + } + repeatability <- samplesMat[, "sig2"] + gauge <- reprod + repeatability + operator <- samplesMat[, sigmaOperator] + part <- samplesMat[, sigmaPart] + total <- gauge + part + + # replace total variation with historical variance and adjust + # part variation accordingly + if(options$processVariationReference == "historicalSd"){ + totalOld <- mean(total) + total <- rep(options$historicalSdValue^2, length(repeatability)) + diffTotals <- total - totalOld + part <- mean(part) + diffTotals + } + + internalDF <- data.frame(gauge, + repeatability, + reprod, + operator, + part, + total + ) + return(internalDF) } From 2248a55dcf8fbdea31db4259a7b17990740597ac Mon Sep 17 00:00:00 2001 From: jvli4n Date: Thu, 5 Jun 2025 14:38:30 +0200 Subject: [PATCH 04/65] Fitting MetaLog & plot posterior distributions 1) Fitting metalog distribution to MCMC samples 2) Plotting posteriors based on metalogs with option to query them 3) Removing analysis of effects and comparing full vs. main effects model instead. Here, I added the option to choose the model manually or based on the BF in favour of the full model. --- R/msaBayesianGaugeRR.R | 726 ++++++++++++++++++++++++++------ inst/qml/msaBayesianGaugeRR.qml | 139 +++++- 2 files changed, 732 insertions(+), 133 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index cbd1d978..7ce64b97 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -40,6 +40,15 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ready <- (!identical(measurements, "") && !identical(parts, "")) } + # note this should also be in a function (I could also just make the dropdown include full model, main effects only and automatic) + if(options$estimationType == "manual"){ + if(options$fullModel || options$mainEffectsOnly) { + ready <- ready + } else { + ready <- FALSE + } + } + numeric.vars <- measurements numeric.vars <- numeric.vars[numeric.vars != ""] @@ -116,31 +125,41 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # Results from model comparison if(ready){ - compRes <- .runBFtest(dataset, measurements, parts, operators, options) + .runBFtest(jaspResults, dataset, measurements, parts, operators, options) } # Model comparison table if(options[["RRTable"]]){ - .createBFtable(compRes, jaspResults, dataset, options, measurements, parts, operators, ready) - } - - # Results from analysis of effects (workaround for accessing the data in jaspResults) ; could be combined with the if statement above - if(ready) { - effectsRes <- .fillEffectsTable(compRes, parts, operators) + .createBFtable(jaspResults, dataset, options, measurements, parts, operators, ready) } - # Effects table - if(options[["effectsTable"]]){ - .createEffectsTable(effectsRes, jaspResults, measurements, parts, operators, ready) - } + # # Effects table + # if(options[["effectsTable"]]){ + # .createEffectsTable(effectsRes, jaspResults, measurements, parts, operators, ready) + # } # MCMC if(ready) { - samplesMat <- .runMCMC(effectsRes, dataset, measurements, parts, operators, options) + .runMCMC(jaspResults, dataset, measurements, parts, operators, options) + .fitMetaLog(jaspResults) } # Variance components table - .createVarCompTable(effectsRes, samplesMat, jaspResults, parts, operators, ready, options) + .createVarCompTable(jaspResults, parts, operators, ready, options) + + # Gauge evaluation table + .createGaugeEvalTable(jaspResults, parts, operators, ready, options) + + # posteriors + if(ready && options$posteriorPlot){ + .fillPostSummaryTable(jaspResults, options, parts, operators) + .plotVariancePosteriors(jaspResults, options, parts, operators) + + # summary table + if(options$posteriorCi || options$posteriorPointEstimate) { + .createPostSummaryTable(jaspResults, options, parts, operators) + } + } } @@ -149,138 +168,94 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { -.createBFtable <- function(compRes, jaspResults, dataset, options, measurements, parts, operators, ready) { +.createBFtable <- function(jaspResults, dataset, options, measurements, parts, operators, ready) { if(!is.null(jaspResults[["BFtable"]])) { return() } BFtable <- createJaspTable(title = gettext("Model Comparison")) BFtable$position <- 1 - BFtable$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable")) + BFtable$dependOn(.bfTableDependencies()) jaspResults[["BFtable"]] <- BFtable BFtable$addColumnInfo(name = "modelName", title = gettext("Models"), type = "string") - BFtable$addColumnInfo(name = "modelPrior", title = gettext("P(M)"), type = "number") - BFtable$addColumnInfo(name = "modelPosterior", title = gettext("P(M|data)"), type = "number") - BFtable$addColumnInfo(name = "modelBF", title = gettext("BFM"), type = "number") - BFtable$addColumnInfo(name = "comparisonBF", title = gettext("BF01"), type = "number") + BFtable$addColumnInfo(name = "comparisonBF", title = gettext("BF10"), type = "number") + BFtable$addColumnInfo(name = "error", title = gettext("error %"), type = "number") # set data if(ready) { # this could also be sth like if(ncol(dataset) == 3) - BFtable$setData(compRes) - BFtable$addFootnote("BF01 compares every model to the null model.") + BFtable$setData(jaspResults[["modelComparison"]][["object"]]) + BFtable$addFootnote(gettext("BF10 compares the full model to the other models.")) } return() } -.runBFtest <- function(dataset, measurements, parts, operators, options) { +.runBFtest <- function(jaspResults, dataset, measurements, parts, operators, options) { + if(is.null(jaspResults[["modelComparison"]])) { + modelComparison <- createJaspState() + modelComparison$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior")) + jaspResults[["modelComparison"]] <- modelComparison + } else { + return() + } + + formula <- as.formula(paste(measurements, "~", parts, "*", operators)) + if(options$setSeed) { set.seed(options$seed) } + # run general comparison for all potential models - bf_fit <- BayesFactor::generalTestBF(formula, data = dataset, - # whichRandom = c(operators, parts), - # rscaleRandom = options$rscalePrior, + bfFit <- BayesFactor::generalTestBF(formula, data = dataset, + whichRandom = c(operators, parts), + rscaleRandom = options$rscalePrior, progress = FALSE) - bf_df <- as.data.frame(bf_fit) - - # add null model - bf_df["Null model", ] <- c(1, rep(NA, 3)) - - # add prior model probabilities - bf_df$prior <- rep(1 / nrow(bf_df), nrow(bf_df)) # uniform for now + bfDf <- as.data.frame(bfFit) - # compute P(M | data) - bf_df <- within(bf_df, unnormalised <- bf * prior) - bf_df <- within(bf_df, posterior <- unnormalised / sum(unnormalised)) + # extract full model and model with only main effects + main <- paste(parts, "+", operators) + full <- paste0(parts, " + ", operators, " + ", parts, ":", operators) + bfDf <- bfDf[c(main, full), ] # dropping unnecessary columns - bf_df <- bf_df[, !colnames(bf_df) %in% c("error", "time", "code", "unnormalised")] - colnames(bf_df) <- c("comparisonBF", "modelPrior", "modelPosterior") - bf_df$modelName <- rownames(bf_df) + bfDf <- bfDf[, !colnames(bfDf) %in% c("time", "code")] - # compute BF_M as the ratio of posterior to prior odds - bf_df <- within(bf_df, modelBF <- ( modelPosterior / (1-modelPosterior) ) / ( modelPrior / (1-modelPrior) ) ) + # obtain BF comparing full model to other models + bfFullNull <- bfDf[full, ]$bf + bfDf$bf <- bfFullNull / bfDf$bf - bf_df <- bf_df[order(-bf_df$modelBF), ] - - return(bf_df) - -} - -.createEffectsTable <- function(effectsRes, jaspResults, measurements, parts, operators, ready) { - if(!is.null(jaspResults[["effectsTable"]])) { - return() - } + # add null model + bfDf["Null model", ] <- c(bfFullNull, + bfDf[full, ]$error) - effectsTable <- createJaspTable(title = gettext(paste("Analysis of Effects -", measurements))) - effectsTable$position <- 2 - effectsTable$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior", "effectsTable")) + bfDf[full, ]$error <- "" - jaspResults[["effectsTable"]] <- effectsTable + # add model names & change colnames + colnames(bfDf) <- c("comparisonBF", "error") + bfDf$modelName <- jaspBase::gsubInteractionSymbol(rownames(bfDf)) - effectsTable$addColumnInfo(name = "effectName", title = gettext("Effects"), type = "string") - effectsTable$addColumnInfo(name = "priorInclusion", title = gettext("P(incl)"), type = "number") - effectsTable$addColumnInfo(name = "priorExclusion", title = gettext("P(excl)"), type = "number") - effectsTable$addColumnInfo(name = "posteriorInclusion", title = gettext("P(incl|data)"), type = "number") - effectsTable$addColumnInfo(name = "posteriorExclusion", title = gettext("P(excl|data)"), type = "number") - effectsTable$addColumnInfo(name = "inclusionBF", title = gettext("BFincl"), type = "number") - effectsTable$addColumnInfo(name = "exclusionBF", title = gettext("BFexcl"), type = "number") + bfDF <- bfDf[order(-bfDf$comparisonBF), ] - # set data - if(ready) { - #effectsTable$setData(.fillEffectsTable(compRes, parts, operators)) - effectsTable$setData(effectsRes) - } + jaspResults[["modelComparison"]][["object"]] <- bfDf return() -} - -.fillEffectsTable <- function(compRes, parts, operators) { - effectName <- c(parts, operators, paste0(parts, ":", operators)) - - priorIncl <- priorExcl <- posteriorIncl <- posteriorExcl <- inclusionBF <- c() - - # loop over different effects and add P(M) and P(M | data) to obtain - # prior and posterior inclusion probabilities - for(i in seq_along(effectName)) { - effect <- grepl(effectName[i], compRes$modelName) - - priorIncl[i] <- sum(compRes$modelPrior[effect]) - priorExcl[i] <- 1 - priorIncl[i] - posteriorIncl[i] <- sum(compRes$modelPosterior[effect]) - posteriorExcl[i] <- 1 - posteriorIncl[i] - - inclusionBF[i] <- (posteriorIncl[i] / posteriorExcl[i]) / (priorIncl[i] / priorExcl[i]) - } - return(data.frame(effectName = effectName, - priorInclusion = priorIncl, - priorExclusion = priorExcl, - posteriorInclusion = posteriorIncl, - posteriorExclusion = posteriorExcl, - inclusionBF = inclusionBF, - exclusionBF = 1 / inclusionBF) - - ) } -.createVarCompTable <- function(effectsRes, samplesMat, jaspResults, parts, operators, ready, options) { + +.createVarCompTable <- function(jaspResults, parts, operators, ready, options) { if(!is.null(jaspResults[["varCompTable"]])) { return() } varCompTable <- createJaspTable(title = gettext("Variance Components")) varCompTable$position <- 3 - varCompTable$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior", "anovaBFForInteractionRemoval", - "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference")) + varCompTable$dependOn(.varCompTableDependencies()) jaspResults[["varCompTable"]] <- varCompTable @@ -291,10 +266,48 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { varCompTable$addColumnInfo(name = "postCrIupper", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval")) varCompTable$addColumnInfo(name = "contribution", title = gettext("% Contribution
(Mean)"), type = "number") + # set data + if(ready) { + varCompTable$setData(.getVarianceComponents(jaspResults, parts, operators, options)) + + if(.evalInter(jaspResults, parts, operators, options)) { + varCompTable$addFootnote("The components are based on the model only including the main effects.") + } else { + varCompTable$addFootnote("The components are based on the full model.") + } + + } else { + return() + } + + return() +} + + +.createGaugeEvalTable <- function(jaspResults, parts, operators, ready, options) { + if(!is.null(jaspResults[["gaugeEvalTable"]])) { + return() + } + + gaugeEvalTable <- createJaspTable(title = gettext("Gauge Evaluation")) + gaugeEvalTable$position <- 3 + gaugeEvalTable$dependOn(c(.varCompTableDependencies(), + "tolerance", "toleranceValue", "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + + jaspResults[["gaugeEvalTable"]] <- gaugeEvalTable + + gaugeEvalTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + gaugeEvalTable$addColumnInfo(name = "meanSds", title = gettext("Std. dev."), type = "number") + gaugeEvalTable$addColumnInfo(name = "meanStudyVar", title = gettext("Study variation"), type = "number") + gaugeEvalTable$addColumnInfo(name = "percentStudy", title = gettext("% Study Variation
(Mean)"), type = "number") + + if(options$tolerance) { + gaugeEvalTable$addColumnInfo(name = "percentTol", title = gettext("% Study Tolerance
(Mean)"), type = "number") + } # set data if(ready) { - varCompTable$setData(.getVarianceComponents(effectsRes, samplesMat, parts, operators, options)) + gaugeEvalTable$setData(.getGaugeEval(jaspResults, operators, parts, options)) } else { return() } @@ -302,9 +315,18 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.runMCMC <- function(effectsRes, dataset, measurements, parts, operators, options){ - # extract exclBF for interaction - excludeInter <- .evalInter(effectsRes, parts, operators, options) + +.runMCMC <- function(jaspResults, dataset, measurements, parts, operators, options){ + if(is.null(jaspResults[["MCMCsamples"]])){ + MCMCsamples <- createJaspState() + MCMCsamples$dependOn(.mcmcDependencies()) + jaspResults[["MCMCsamples"]] <- MCMCsamples + } else { + return() + } + + # obtain BF in favor of full over main effects model + excludeInter <- .evalInter(jaspResults, parts, operators, options) if(excludeInter){ formula <- as.formula(paste(measurements, "~", parts, "+", operators)) } else { @@ -349,15 +371,17 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { samplesMat <- as.matrix(chains) - return(samplesMat) + MCMCsamples[["object"]] <- samplesMat + + return() } -.getVarianceComponents <- function(effectsRes, samplesMat, parts, operators, options) { - excludeInter <- .evalInter(effectsRes, parts, operators, options) +.getVarianceComponents <- function(jaspResults, parts, operators, options) { + excludeInter <- .evalInter(jaspResults, parts, operators, options) # get components from MCMC samples - internalDF <- .getComponentsFromSamples(samplesMat, parts, operators, options, excludeInter) + internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) # %Contribution to total variance contribution <- matrix(ncol = ncol(internalDF), nrow = nrow(internalDF)) @@ -383,12 +407,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } - sourceName <- c("Total gauge r&R", - "Repeatability", - "Reproducibility", - "Operator", - "Part-to-part", - "Total variation") + sourceName <- .sourceNames() return(data.frame(sourceName, postMeans, @@ -399,23 +418,97 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ) } -.getGaugeEval <- function(samplesMat){ +.getGaugeEval <- function(jaspResults, operators, parts, options){ + excludeInter <- .evalInter(jaspResults, parts, operators, options) + + internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + + # standard deviation + sdDF <- sqrt(internalDF) + + # get factor for multiplication + if(options$studyVarianceMultiplierType == "sd") { + factorSd <- options$studyVarianceMultiplierValue + } else { + val <- options$studyVarianceMultiplierValue / 100 + q <- (1 - val) / 2 + factorSd <- abs(2 * qnorm(q)) + } + + studyVar <- sdDF * factorSd + + # % Study Variation + percStudy <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) + for(i in 1:ncol(studyVar)){ + percStudy[, i] <- studyVar[[i]] / studyVar$total * 100 + } + + # summaries + meanSds <- colMeans(sdDF) + meanStudyVar <- colMeans(studyVar) + percentStudy <- colMeans(percStudy) + # % Tolerance + if(options$tolerance) { + percTol <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) + for(i in 1:ncol(studyVar)){ + percTol[, i] <- studyVar[[i]] / options$toleranceValue * 100 + } + + percentTol <- colMeans(percTol) + + gaugeEvalDf <- data.frame(sourceName = .sourceNames(), + meanSds, + meanStudyVar, + percentStudy, + percentTol) + } else { + gaugeEvalDf <- data.frame(sourceName = .sourceNames(), + meanSds, + meanStudyVar, + percentStudy) + } + + # add footnotes + # number of distinct categories + nDistinct <- .gaugeNumberDistinctCategories(meanSds["part"], meanSds["gauge"]) + jaspResults[["gaugeEvalTable"]]$addFootnote(gettextf("Number of distinct categories = %d", nDistinct)) + + jaspResults[["gaugeEvalTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) + + + return(gaugeEvalDf) } -.evalInter <- function(effectsRes, parts, operators, options) { - ind <- effectsRes$effectName == paste0(parts, ":", operators) - excludeInter <- effectsRes[ind, "exclusionBF"] >= options$anovaBFForInteractionRemoval +.evalInter <- function(jaspResults, parts, operators, options) { + if(options$estimationType == "automatic") { + bfDf <- jaspResults[["modelComparison"]][["object"]] + main <- paste(parts, "+", operators) + + excludeInter <- bfDf[main, ]$comparisonBF <= options$bfFavorFull + } + + if(options$estimationType == "manual"){ + if(options$fullModel){ + excludeInter <- FALSE + } + + if(options$mainEffectsOnly){ + excludeInter <- TRUE + } + } return(excludeInter) } -.getComponentsFromSamples <- function(samplesMat, parts, operators, options, excludeInter){ +.getComponentsFromSamples <- function(jaspResults, parts, operators, options, excludeInter){ # note this could be written into a helper function sigmaPart <- paste0("g_", parts) sigmaOperator <- paste0("g_", operators) sigmaInter <- paste0("g_", parts, ":", operators) + samplesMat <- jaspResults[["MCMCsamples"]][["object"]] + # obtain relevant components if(excludeInter){ reprod <- samplesMat[, sigmaOperator] @@ -446,3 +539,398 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ) return(internalDF) } + +.fitMetaLog <- function(jaspResults) { + if(is.null(jaspResults[["metaLogFit"]])){ + metaLogFit <- createJaspState() + metaLogFit$dependOn(.mcmcDependencies()) + jaspResults[["metaLogFit"]] <- metaLogFit + } else { + return() + } + + samplesMat <- jaspResults[["MCMCsamples"]][["object"]] + + # fit metalog to each parameter + metaLogList <- apply(samplesMat, 2, + function(x) rmetalog::metalog(x, bounds = 0, boundedness = "sl")) + + # find optimal number of terms for each parameter + optimalTerms <- Map(.optimalMetaLog, metaLogList, names(metaLogList), + MoreArgs = list(samplesMat = samplesMat)) + + # add optimal terms to list + metaLogList <- Map(function(x, optimalTerms){ + x[["optimalTerms"]] <- optimalTerms + x + }, metaLogList, optimalTerms) + + metaLogFit[["object"]] <- metaLogList + + return() + +} + +.createPostSummaryTable <- function(jaspResults, options, parts, operators){ + if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]])){ + return() + } + + postSummary <- createJaspTable(title = gettext("Posterior Summary")) + postSummary$position <- 1 + postSummary$dependOn(c(.mcmcDependencies(), + .postPlotDependencies())) + + jaspResults[["variancePosteriors"]][["postSummary"]] <- postSummary + + # title for point estimate + pointEst <- switch (options$posteriorPointEstimateType, + "mean" = "Mean", + "mode" = "Mode", + "median" = "Median" + ) + + # overtitle for CrI + if(options$posteriorCiType == "central" || options$posteriorCiType == "HPD") { + mass <- round(options$posteriorCiMass * 100) + } + + if(options$posteriorCiType == "custom") { + mass <- round((options$posteriorCiUpper - options$posteriorCiLower) * 100) + } + + overtitle <- paste0(mass, "% ", "Credible Interval") + + + postSummary$addColumnInfo(name = "parameter", title = gettext("Parameter"), type = "string") + + if(options$posteriorPointEstimate) { + postSummary$addColumnInfo(name = "pointEstimate", title = gettext(pointEst), type = "number") + } + + if(options$posteriorCi) { + postSummary$addColumnInfo(name = "ciLower", title = gettext("Lower"), type = "number", overtitle = gettext(overtitle)) + postSummary$addColumnInfo(name = "ciUpper", title = gettext("Upper"), type = "number", overtitle = gettext(overtitle)) + } + + + postSummary$setData(jaspResults[["postSummaryStats"]][["object"]]) + + return() +} + +.fillPostSummaryTable <- function(jaspResults, options, parts, operators) { + if(is.null(jaspResults[["postSummaryStats"]]) && (options$posteriorCi || options$posteriorPointEstimate)){ + postSummaryStats <- createJaspState() + postSummaryStats$dependOn(c(.mcmcDependencies(), + .postPlotDependencies())) + jaspResults[["postSummaryStats"]] <- postSummaryStats + } else { + return() + } + + fits <- jaspResults[["metaLogFit"]][["object"]] + + parameter <- .convertOutputNames(names(fits), parts, operators) + + # point estimates + if(options$posteriorPointEstimate) { + + pointEstimate <- switch(options$posteriorPointEstimateType, + "mean" = unlist(lapply(fits, .meanMetaLog)), + "median" = unlist(lapply(fits, .medianMetaLog)), + "mode" = unlist(lapply(fits, .modeMetaLog))) # note: the mode still seems to be a bit off + } + + # intervals + if(options$posteriorCi) { + + intervals <- switch(options$posteriorCiType, + "central" = Map(.centralInterMetaLog, fits, mass = options$posteriorCiMass), + "HPD" = Map(.hdiMetaLog, fits, mass = options$posteriorCiMass), + "custom" = Map(.customInterMetaLog, fits, + lower = options$posteriorCiLower, + upper = options$posteriorCiUpper)) + + # lower and upper bounds separately + lower <- sapply(intervals, function(x) x[1]) + upper <- sapply(intervals, function(x) x[2]) + } + + if(options$posteriorPointEstimate && options$posteriorCi == FALSE) { + df <- data.frame(parameter, + pointEstimate) + } else if(options$posteriorPointEstimate == FALSE && options$posteriorCi) { + df <- data.frame(parameter, + ciLower = lower, + ciUpper = upper) + } else { + df <- data.frame(parameter, + pointEstimate, + ciLower = lower, + ciUpper = upper) + } + postSummaryStats[["object"]] <- df + + return() +} + +.plotVariancePosteriors <- function(jaspResults, options, parts, operators){ + + if(!is.null(jaspResults[["variancePosteriors"]])){ + return() + } + + variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) + variancePosteriors$position <- 4 + variancePosteriors$dependOn(c(.mcmcDependencies(), + .postPlotDependencies())) + jaspResults[["variancePosteriors"]] <- variancePosteriors + + fits <- jaspResults[["metaLogFit"]][["object"]] + titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) + postSummary <- jaspResults[["postSummaryStats"]][["object"]] + modes <- lapply(fits, .modeMetaLog) + + + for(i in seq_along(titles)) { + tempPlot <- createJaspPlot(title = gettext(titles[i]), width = 600, height = 320) + + # axis limits + dfTemp <- fits[[i]]$dataValues + + if(options$posteriorCi) { + xUpper <- ceiling(max(dfTemp[dfTemp$probs >= 0.975, ]$x_new[1], postSummary[i, "ciUpper"])) + } else { + xUpper <- ceiling(dfTemp[dfTemp$probs >= 0.975, ]$x_new[1]) + } + xLower <- 0 + xLims <- c(xLower, xUpper) + + yUpper <- rmetalog::dmetalog(m = fits[[i]], q = modes[[i]], term = fits[[i]]$optimalTerms) + yLower <- 0 + yLims <- c(yLower, yUpper) + + + p <- ggplot2::ggplot() + + # credible interval + if(options$posteriorCi) { + ciUpper <- postSummary[i, "ciUpper"] + ciLower <- postSummary[i, "ciLower"] + + p <- p + + ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$optimalTerms), + geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") + } + + p <- p + + ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$optimalTerms), + linewidth = 1) + + + # point estimate + if(options$posteriorPointEstimate) { + xPoint <- postSummary[i, "pointEstimate"] + yPoint <- rmetalog::dmetalog(m = fits[[i]], q = xPoint, term = fits[[i]]$optimalTerms) + pointDf <- data.frame(xPoint, yPoint) + + p <- p + ggplot2::geom_point(data = pointDf, mapping = ggplot2::aes(x = xPoint, y = yPoint), + shape = 21, size = 4, fill = "grey", stroke = 1) + } + + + + + # axes + xLab <- titles[i] + p <- p + + ggplot2::scale_x_continuous(name = bquote(sigma[.(xLab)]^2), breaks = jaspGraphs::getPrettyAxisBreaks(xLims), limits = xLims) + + ggplot2::scale_y_continuous(name = "Density", breaks = jaspGraphs::getPrettyAxisBreaks(yLims), limits = yLims) + + # theme + p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe(sides = "bl") + + tempPlot$plotObject <- p + variancePosteriors[[titles[i]]] <- tempPlot + } + + + + + # df <- samplesMat <- as.data.frame(jaspResults[["MCMCsamples"]][["object"]]) + # CrIs <- apply(df, 2, quantile, probs = c(0.025, 0.975)) + # parameters <- colnames(samplesMat) + # + # # axis labels + # cleanLabel <- sub("^g_", "", parameters) + # cleanLabel <- sub("sig2", "Error", cleanLabel) + # names(cleanLabel) <- parameters + # + # # Create label with sigma^2 + # axisLabs <- sapply(cleanLabel, function(x) bquote(sigma^2 ~ .(x)) ) + # + # + # for(i in seq_along(parameters)) { + # tempPlot <- createJaspPlot(title = gettext(parameters[i]), width = 600, height = 320) + # + # # obtain density from ggplot + # p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[[parameters[i]]])) + + # ggplot2::geom_density() + # + # density_data <- ggplot2::ggplot_build(p)$data[[1]] + # + # fillDensity <- density_data[density_data$x >= CrIs[, parameters[i]][1] & density_data$x <= CrIs[, parameters[i]][2], ] + # + # # x and y limits & coordinates for errorbar + # xLow <- floor(min(0, CrIs[, parameters[i]][1] - CrIs[, parameters[i]][1] * 0.1)) + # xUpper <- ceiling(max(CrIs[, parameters[i]][2] / 90 * 100, density_data[density_data$y < 0.005, "x"][1])) + # xLims <- c(xLow, xUpper) + # + # yLow <- 0 + # yUpper <- max(density_data$y) + 0.01 + # yLims <- c(yLow, yUpper) + # + # yErrorbar <- yUpper / 100 * 95 + # heightErrorbar <- yUpper / 100 * 5 + # + # + # tempPlot$plotObject <- ggplot2::ggplot(df, ggplot2::aes(x = .data[[parameters[i]]])) + + # ggplot2::geom_density() + + # ggplot2::geom_density(data = fillDensity, ggplot2::aes(x = x, y = y), fill = "blue", alpha = 0.4) + + # jaspGraphs::scale_y_continuous("Density", limits = yLims, breaks = jaspGraphs::getPrettyAxisBreaks(yLims)) + + # jaspGraphs::scale_x_continuous(axisLabs[[parameters[i]]], limits = xLims, breaks = jaspGraphs::getPrettyAxisBreaks(xLims)) + + # #ggplot2::geom_errorbarh(ggplot2::aes(xmin = CrIs[, parameters[i]][1], xmax = CrIs[, parameters[i]][2], y = 1), height = heightErrorbar) + + # jaspGraphs::themeJaspRaw() + + # jaspGraphs::geom_rangeframe(sides = "bl") + # + # variancePosteriors[[parameters[i]]] <- tempPlot + # + # } + return() +} + + + + + +# helper functions +.bfParameterNames <- function(parts, operators) { + sigmaPart <- paste0("g_", parts) + sigmaOperator <- paste0("g_", operators) + sigmaInter <- paste0("g_", parts, ":", operators) + + return(list(sigmaPart, sigmaOperator, sigmaInter)) +} + +.sourceNames <- function(){ + return(c("Total gauge r&R", + "Repeatability", + "Reproducibility", + "Operator", + "Part-to-part", + "Total variation")) +} + +.bfTableDependencies <- function() { + return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable", "bfFavorFull")) +} + +.varCompTableDependencies <- function() { + return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", + "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference", + "estimationType", "fullModel", "mainEffectsOnly")) +} + +.mcmcDependencies <- function() { + return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", + "mcmcChains", "mcmcBurnin", "mcmcIterations", + "estimationType", "fullModel", "mainEffectsOnly")) +} + +.postPlotDependencies <- function() { + return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", + "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot")) +} + +.optimalMetaLog <- function(fit, parameter, samplesMat) { + terms <- fit$params$term_limit + + error <- numeric(length(terms)) + + for(j in 2:terms){ + # quantiles + j <- as.numeric(j) + qmeta <- rmetalog::qmetalog(m = fit, y = c(0.025, 0.975), term = j) + qdata <- quantile(samplesMat[, parameter], probs = c(0.025, 0.975)) + + errorCrI <- sum(abs(qdata - qmeta)) + + # mean + meanMeta <- integrate(rmetalog::qmetalog, m = fit, term = j, lower = 0, upper = 1)$value # integrate over quantile function + meanData <- mean(samplesMat[, parameter]) + + errorMean <- abs(meanData - meanMeta) + + error[j] <- sum(errorCrI, errorMean) + } + #print(error) + return(which.min(error[-1]) + 1) +} + +.meanMetaLog <- function(fit) { + m <- integrate(rmetalog::qmetalog, m = fit, term = fit$optimalTerms, + lower = 0, upper = 1)$value +} + +.medianMetaLog <- function(fit) { + m <- rmetalog::qmetalog(m = fit, y = 0.5, term = fit$optimalTerms) +} + +.modeMetaLog <- function(fit) { + m <- optimize(rmetalog::dmetalog, interval = c(0, max(fit$dataValues[1])), + m = fit, term = fit$optimalTerms, maximum = TRUE)$maximum +} + +.centralInterMetaLog <- function(fit, mass) { + lower <- (1 - mass) / 2 + upper <- 1 - lower + int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$optimalTerms) +} + +.hdiMetaLog <- function(fit, mass) { + samples <- rmetalog::rmetalog(m = fit, n = 1e5, term = fit$optimalTerms) + int <- HDInterval::hdi(samples, credMass = mass) +} + +.customInterMetaLog <- function(fit, lower, upper) { + int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$optimalTerms) +} + +.convertOutputNames <- function(name, parts, operators, includeSigma = TRUE) { + sigmaPart <- paste0("g_", parts) + sigmaOperator <- paste0("g_", operators) + sigmaInter <- paste0("g_", parts, ":", operators) + if(includeSigma) { + replPart <- "\u03C32Part" + replOperator <- "\u03C32Operator" + replInter <- "\u03C32Part\u2009\u273B\u2009Operator" + replError <- "\u03C32Error" + } else { + replPart <- "Part" + replOperator <- "Operator" + replInter <- "Part\u2009\u273B\u2009Operator" + replError <- "Error" + } + + name <- sub(sigmaInter, replInter, name) + name <- sub(sigmaPart, replPart, name) + name <- sub(sigmaOperator, replOperator, name) + name <- sub("sig2", replError, name) + + return(name) +} + diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index bf342bbd..e2ec9666 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -130,6 +130,51 @@ Form { title: qsTr("Analysis options") + DropDown + { + name: "estimationType" + label: qsTr("Estimation") + id: estimationType + indexDefaultValue: 0 + values: + [ + { label: qsTr("Automatic"), value: "automatic" }, + { label: qsTr("Manual"), value: "manual" }, + ] + } + + DoubleField + { + name: "bfFavorFull" + label: qsTr("BF in favor of full model") + id: bfFavorFull + defaultValue: 1 + min: 0.001 + decimals: 3 + visible: estimationType.currentValue == "automatic" + } + + CheckBox + { + name: "fullModel" + label: qsTr("Full model") + id: fullModel + checked: false + enabled: !mainEffectsOnly.checked + visible: estimationType.currentValue == "manual" + } + + CheckBox + { + name: "mainEffectsOnly" + label: qsTr("Main effects only") + id: mainEffectsOnly + enabled: !fullModel.checked + checked: false + visible: estimationType.currentValue == "manual" + } + + DropDown { name: "processVariationReference" @@ -175,16 +220,6 @@ Form label: qsTr("r&R table") checked: true - DoubleField - { - name: "anovaBFForInteractionRemoval" - label: qsTr("BF interaction removal") - fieldWidth: 60 - defaultValue: 10 - min: 0 - decimals: 3 - } - DropDown { name: "studyVarianceMultiplierType" @@ -210,12 +245,12 @@ Form } } - CheckBox + /* CheckBox { name: "effectsTable" label: qsTr("Effects table") checked: false - } + } */ } Section @@ -229,14 +264,90 @@ Form { name: "priorPlot" label: qsTr("Prior") - checked: true + checked: false } CheckBox { name: "posteriorPlot" label: qsTr("Posterior") - checked: true + checked: false + + CheckBox + { + label: qsTr("Point estimate") + name: "posteriorPointEstimate" + childrenOnSameRow: true + + DropDown + { + name: "posteriorPointEstimateType" + label: "" + values: ["mean", "median", "mode"] + } + } + + CheckBox + { + name: "posteriorCi" + label: qsTr("CI") + id: posteriorCi + childrenOnSameRow: true + + DropDown + { + name: "posteriorCiType" + label: "" + values: ["central", "HPD", "custom"] + id: posteriorCiType + } + } + + Group + { + columns: 2 + + CIField + { + visible: posteriorCiType.currentText == "central" | posteriorCiType.currentText == "HPD" + enabled: posteriorCi.checked + name: "posteriorCiMass" + label: qsTr("Mass") + fieldWidth: 50 + defaultValue: 95 + min: 1 + max: 100 + inclusive: JASP.Min + } + + DoubleField + { + visible: posteriorCiType.currentText == "custom" + enabled: posteriorCi.checked + name: "posteriorCiLower" + label: qsTr("Lower") + id: posteriorCiLower + fieldWidth: 50 + defaultValue: 0.25 + min: 0 + max: plotsPriorMarginalUpper.value + inclusive: JASP.None + } + + DoubleField + { + visible: posteriorCiType.currentText == "custom" + enabled: posteriorCi.checked + name: "posteriorCiUpper" + label: qsTr("Upper") + id: plotsPriorMarginalUpper + fieldWidth: 50 + defaultValue: 0.75 + min: posteriorCiLower.value + max: 1 + inclusive: JASP.None + } + } } } From d80cb27cb592173006e72f34da2cdda3f48cfe5a Mon Sep 17 00:00:00 2001 From: jvli4n Date: Thu, 5 Jun 2025 18:52:21 +0200 Subject: [PATCH 05/65] Adding contour plot - QML and R code for contour plot - Update renv lock file --- R/msaBayesianGaugeRR.R | 120 +++++++++++++++++++++++++++++++- inst/qml/msaBayesianGaugeRR.qml | 30 ++++++++ renv.lock | 18 +++++ 3 files changed, 166 insertions(+), 2 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 7ce64b97..e84890f1 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -161,6 +161,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } } + # contour plot + if(options$contourPlot) { + .createContourPlot(jaspResults, parts, operators, measurements, dataset, options) + } + } @@ -706,10 +711,12 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } xLower <- 0 xLims <- c(xLower, xUpper) + xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) yUpper <- rmetalog::dmetalog(m = fits[[i]], q = modes[[i]], term = fits[[i]]$optimalTerms) yLower <- 0 yLims <- c(yLower, yUpper) + yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) p <- ggplot2::ggplot() @@ -745,8 +752,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # axes xLab <- titles[i] p <- p + - ggplot2::scale_x_continuous(name = bquote(sigma[.(xLab)]^2), breaks = jaspGraphs::getPrettyAxisBreaks(xLims), limits = xLims) + - ggplot2::scale_y_continuous(name = "Density", breaks = jaspGraphs::getPrettyAxisBreaks(yLims), limits = yLims) + ggplot2::scale_x_continuous(name = bquote(sigma[.(xLab)]^2), breaks = xBreaks, + limits = xLims, labels = xBreaks) + + ggplot2::scale_y_continuous(name = "Density", breaks = yBreaks, + limits = yLims, labels = yBreaks) # theme p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe(sides = "bl") @@ -810,6 +819,77 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } +.createContourPlot <- function(jaspResults, parts, operators, measurements, dataset, options) { + if(!is.null(jaspResults[["contourPlot"]])) { + return() + } + + contourPlot <- createJaspContainer(title = gettext("Contour Plot")) + contourPlot$position <- 5 + contourPlot$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue", + "contourPlot", "contourUSL", "contourLSL")) + + jaspResults[["contourPlot"]] <- contourPlot + + + tempPlot <- createJaspPlot(width = 600, height = 600) + samplesMat <- jaspResults[["MCMCsamples"]][["object"]] + excludeInter <- .evalInter(jaspResults, parts, operators, options) + compDf <-.getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) # note: should the historcial sd influence this if entered by the user? + + # obtain necessary data + contourDf <- compDf[, c("total", "part")] + mu <- mean(dataset[[measurements]]) # note: do I have to transform the variances to get a sensible result + + # data frame for plotting + meanEllipse = TRUE + plotDf <- .getEllipses(contourDf, mu, meanEllipse = meanEllipse, options = options) #note: add number of ellipses here; this could also be done with one ellipse based on the post. mean of the variances + + if(meanEllipse) { + p <- ggplot2::ggplot(plotDf, ggplot2::aes(x = x, y = y)) + } else { + p <- ggplot2::ggplot(plotDf, ggplot2::aes(x = x, y = y, group = iter)) + } + + p <- p + + ggplot2::geom_vline(xintercept = c(options$contourLSL, options$contourUSL), linetype = "dashed", color = "black", linewidth = 1) + + ggplot2::geom_hline(yintercept = c(options$contourLSL, options$contourUSL), linetype = "dashed", color = "black", linewidth = 1) + + ggplot2::geom_path(alpha = 0.5, colour = "steelblue", linewidth = 1) + + + # axes + xLower <- min(options$contourLSL, plotDf$x) + xUpper <- max(options$contourUSL, plotDf$x) + xLims <- c(xLower, xUpper) + xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) + + yLower <- min(options$contourLSL, plotDf$y) + yUpper <- max(options$contourUSL, plotDf$y) + yLims <- c(yLower, yUpper) + yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) + + p <- p + + ggplot2::scale_x_continuous(name = "Measurement", breaks = xBreaks, + limits = xLims, labels = xBreaks) + + ggplot2::scale_y_continuous(name = "True Value", breaks = yBreaks, + limits = yLims, labels = yBreaks) + + ggplot2::coord_equal() + + # theme + p <- p + + jaspGraphs::themeJaspRaw() + + jaspGraphs::geom_rangeframe(sides = "bl") + + tempPlot$plotObject <- p + + contourPlot[["plot"]] <- tempPlot + + # note: add a table with the posterior means and CrIs for the risks + + return() +} + @@ -934,3 +1014,39 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(name) } +.getEllipses <- function(contourDf, mu, options, numberEllipses = 20, meanEllipse = FALSE) { + + if(options$setSeed) { + set.seed(options$seed) + } + if(meanEllipse) { + sigmaP <- mean(contourDf$part) + sigmaTotal <- mean(contourDf$total) + + covMat <- matrix(c(sigmaTotal, sigmaP, + sigmaP, sigmaP), + nrow = 2, ncol = 2) + res <- as.data.frame(ellipse::ellipse(covMat, centre = c(mu, mu), level = 0.95)) + } else { + ind <- sample(1:nrow(contourDf), numberEllipses) + ellipseList <- lapply(ind, function(i) { + sigmaP <- contourDf[i, ]$part # part + sigmaTotal <- contourDf[i, ]$total # total + + covMat <- matrix(c(sigmaTotal, sigmaP, + sigmaP, sigmaP), + nrow = 2, ncol = 2) + + # ellipse + ellipseDf <- as.data.frame(ellipse::ellipse(covMat, centre = c(mu, mu), level = 0.95)) + ellipseDf$iter <- i + + return(ellipseDf) + }) + res <- do.call(rbind.data.frame, ellipseList) + } + + return(res) +} + + diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index e2ec9666..de1cc0c0 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -349,6 +349,36 @@ Form } } } + + CheckBox + { + name: "contourPlot" + label: qsTr("Contour plot") + + DoubleField + { + name: "contourLSL" + label: qsTr("Lower specification limit") + id: contourLSL + fieldWidth: 60 + defaultValue: -1 + min: -1000000 + max: contourUSL.value + inclusive: JASP.None + } + + DoubleField + { + name: "contourUSL" + label: qsTr("Upper specification limit") + id: contourUSL + fieldWidth: 60 + defaultValue: 1 + min: contourLSL.value + max: 1000000 + inclusive: JASP.None + } + } } Group diff --git a/renv.lock b/renv.lock index 1a0102b2..3e42f42b 100644 --- a/renv.lock +++ b/renv.lock @@ -108,6 +108,12 @@ "stats" ] }, + "HDInterval": { + "Package": "HDInterval", + "Version": "0.2.4", + "Source": "Repository", + "Repository": "CRAN" + }, "MASS": { "Package": "MASS", "Version": "7.3-65", @@ -556,6 +562,12 @@ "vctrs" ] }, + "ellipse": { + "Package": "ellipse", + "Version": "0.5.0", + "Source": "Repository", + "Repository": "CRAN" + }, "elliptic": { "Package": "elliptic", "Version": "1.4-0", @@ -1734,6 +1746,12 @@ "utils" ] }, + "rmetalog": { + "Package": "rmetalog", + "Version": "1.0.3", + "Source": "Repository", + "Repository": "CRAN" + }, "rsm": { "Package": "rsm", "Version": "2.10.6", From 4e555853fa896178fdd2ff1fb06ac23ce3742bc7 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Fri, 6 Jun 2025 13:42:17 +0200 Subject: [PATCH 06/65] Risk and % Contribution table - Separate % Contribution table - Risk table that goes along with contour plot --- R/msaBayesianGaugeRR.R | 144 +++++++++++++++++++++++++++++++++++------ 1 file changed, 126 insertions(+), 18 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index e84890f1..f53cde1e 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -147,6 +147,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # Variance components table .createVarCompTable(jaspResults, parts, operators, ready, options) + # % Contribution to total variation table + .createPercContribTable(jaspResults, options, parts, operators, ready) + # Gauge evaluation table .createGaugeEvalTable(jaspResults, parts, operators, ready, options) @@ -162,7 +165,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # contour plot - if(options$contourPlot) { + if(ready && options$contourPlot) { .createContourPlot(jaspResults, parts, operators, measurements, dataset, options) } @@ -259,7 +262,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } varCompTable <- createJaspTable(title = gettext("Variance Components")) - varCompTable$position <- 3 + varCompTable$position <- 2 varCompTable$dependOn(.varCompTableDependencies()) jaspResults[["varCompTable"]] <- varCompTable @@ -269,7 +272,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { varCompTable$addColumnInfo(name = "postSds", title = gettext("Std. Deviation"), type = "number") varCompTable$addColumnInfo(name = "postCrIlower", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval")) varCompTable$addColumnInfo(name = "postCrIupper", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval")) - varCompTable$addColumnInfo(name = "contribution", title = gettext("% Contribution
(Mean)"), type = "number") # set data if(ready) { @@ -288,6 +290,28 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } +.createPercContribTable <- function(jaspResults, options, parts, operators, ready) { + if(!is.null(jaspResults[["contribTable"]])) { + return() + } + contribTable <- createJaspTable(title = gettext("% Contribution to Total Variation")) + contribTable$position <- 3 + contribTable$dependOn(.varCompTableDependencies()) + jaspResults[["contribTable"]] <- contribTable + + contribTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + contribTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + contribTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") + contribTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + + if(ready) { + contribTable$setData(.getPercContrib(jaspResults, parts, operators, options)) + } else { + return() + } + return() +} + .createGaugeEvalTable <- function(jaspResults, parts, operators, ready, options) { if(!is.null(jaspResults[["gaugeEvalTable"]])) { @@ -295,7 +319,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } gaugeEvalTable <- createJaspTable(title = gettext("Gauge Evaluation")) - gaugeEvalTable$position <- 3 + gaugeEvalTable$position <- 4 gaugeEvalTable$dependOn(c(.varCompTableDependencies(), "tolerance", "toleranceValue", "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) @@ -388,18 +412,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # get components from MCMC samples internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) - # %Contribution to total variance - contribution <- matrix(ncol = ncol(internalDF), nrow = nrow(internalDF)) - for(i in 1:ncol(internalDF)){ - contribution[, i] <- internalDF[[i]] / internalDF$total * 100 - } - # calculate summary stats postMeans <- colMeans(internalDF) postSds <- apply(internalDF, 2, sd) postCrIlower <- apply(internalDF, 2, quantile, probs = 0.025) postCrIupper <- apply(internalDF, 2, quantile, probs = 0.975) - contribution <- colMeans(contribution) # remove some stats when historicalSd is specified if(options$processVariationReference == "historicalSd"){ @@ -418,8 +435,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { postMeans, postSds, postCrIlower, - postCrIupper, - contribution) + postCrIupper) ) } @@ -687,7 +703,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) - variancePosteriors$position <- 4 + variancePosteriors$position <- 5 variancePosteriors$dependOn(c(.mcmcDependencies(), .postPlotDependencies())) jaspResults[["variancePosteriors"]] <- variancePosteriors @@ -825,7 +841,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } contourPlot <- createJaspContainer(title = gettext("Contour Plot")) - contourPlot$position <- 5 + contourPlot$position <- 6 contourPlot$dependOn(c(.varCompTableDependencies(), "studyVarianceMultiplierType", "studyVarianceMultiplierValue", "contourPlot", "contourUSL", "contourLSL")) @@ -834,6 +850,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { tempPlot <- createJaspPlot(width = 600, height = 600) + tempPlot$position <- 2 + samplesMat <- jaspResults[["MCMCsamples"]][["object"]] excludeInter <- .evalInter(jaspResults, parts, operators, options) compDf <-.getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) # note: should the historcial sd influence this if entered by the user? @@ -870,9 +888,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) p <- p + - ggplot2::scale_x_continuous(name = "Measurement", breaks = xBreaks, + ggplot2::scale_x_continuous(name = "True Value", breaks = xBreaks, limits = xLims, labels = xBreaks) + - ggplot2::scale_y_continuous(name = "True Value", breaks = yBreaks, + ggplot2::scale_y_continuous(name = "Measurement", breaks = yBreaks, limits = yLims, labels = yBreaks) + ggplot2::coord_equal() @@ -885,7 +903,19 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { contourPlot[["plot"]] <- tempPlot - # note: add a table with the posterior means and CrIs for the risks + # table with the posterior means and CrIs for the risks + risksTable <- createJaspTable(title = gettext("Producer's (\u03b4) and Consumer's (\u03b2) Risk")) + risksTable$position <- 1 + + risksTable$addColumnInfo(name = "risks", title = gettext("Risk"), type = "string") + risksTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + risksTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") + risksTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + + risksTable$setData(.getRisks(contourDf, mu, options)) + + contourPlot[["table"]] <- risksTable + return() } @@ -1049,4 +1079,82 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(res) } +.getRisks <- function(contourDf, mu, options) { + + USL <- options$contourUSL + LSL <- options$contourLSL + producers <- consumers <- c() + + for (i in 1:nrow(contourDf)) { + sigmaP <- contourDf[i, ]$part # part + sigmaTotal <- contourDf[i, ]$total # total + + covMat <- matrix(c(sigmaTotal, sigmaP, + sigmaP, sigmaP), + nrow = 2, ncol = 2) + + # producer's risk (delta) + # probability that y falls outside although x is inside + numerator <- mvtnorm::pmvnorm(lower = c(-Inf, LSL), upper = c(LSL, USL), mean = c(mu, mu), + sigma = covMat) + + mvtnorm::pmvnorm(lower = c(USL, LSL), upper = c(Inf, USL), mean = c(mu, mu), sigma = covMat) + + denom <- pnorm(USL, mean = mu, sd = sqrt(sigmaP)) - pnorm(LSL, mean = mu, sd = sqrt(sigmaP)) + + producers[i] <- numerator / denom + + # consumers risk + # probability that y is inside although x falls outside + numerator <- mvtnorm::pmvnorm(lower = c(LSL, -Inf), upper = c(USL, LSL), mean = c(mu, mu), + sigma = covMat) + + mvtnorm::pmvnorm(lower = c(LSL, USL), upper = c(USL, Inf), mean = c(mu, mu), sigma = covMat) + + denom <- 1 - denom + + consumers[i] <- numerator / denom + } + + df <- data.frame(delta = producers, + beta = consumers) + # means + means <- apply(df, 2, mean) + + # CrIs + lower <- apply(df, 2, quantile, probs = 0.025) + upper <- apply(df, 2, quantile, probs = 0.975) + + # unicodes + risks <- c("\u03b4", "\u03b2") + + return(data.frame(risks, + means, + lower, + upper)) + +} + +.getPercContrib <- function(jaspResults, parts, operators, options) { + excludeInter <- .evalInter(jaspResults, parts, operators, options) + + # get components from MCMC samples + internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + + # %Contribution to total variance + contribution <- matrix(ncol = ncol(internalDF), nrow = nrow(internalDF)) + for(i in 1:ncol(internalDF)){ + contribution[, i] <- internalDF[[i]] / internalDF$total * 100 + } + sourceName <- .sourceNames() + means <- colMeans(contribution) + lower <- apply(contribution, 2, quantile, probs = 0.025) + upper <- apply(contribution, 2, quantile, probs = 0.975) + + return(data.frame(sourceName, + means, + lower, + upper) + + ) + +} From 5ad4e20fe1de4c17d4c3d463ca858368d9715d98 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Fri, 6 Jun 2025 15:10:51 +0200 Subject: [PATCH 07/65] Reworking gauge evaluation output - Gauge evaluation output now includes separate tables with uncertainty estimates --- R/msaBayesianGaugeRR.R | 283 +++++++++++++++++++++++++++-------------- 1 file changed, 188 insertions(+), 95 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index f53cde1e..0b7c7507 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -151,7 +151,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .createPercContribTable(jaspResults, options, parts, operators, ready) # Gauge evaluation table - .createGaugeEvalTable(jaspResults, parts, operators, ready, options) + .createGaugeEval(jaspResults, parts, operators, options, ready) # posteriors if(ready && options$posteriorPlot){ @@ -313,36 +313,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } -.createGaugeEvalTable <- function(jaspResults, parts, operators, ready, options) { - if(!is.null(jaspResults[["gaugeEvalTable"]])) { - return() - } - - gaugeEvalTable <- createJaspTable(title = gettext("Gauge Evaluation")) - gaugeEvalTable$position <- 4 - gaugeEvalTable$dependOn(c(.varCompTableDependencies(), - "tolerance", "toleranceValue", "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) - jaspResults[["gaugeEvalTable"]] <- gaugeEvalTable - - gaugeEvalTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - gaugeEvalTable$addColumnInfo(name = "meanSds", title = gettext("Std. dev."), type = "number") - gaugeEvalTable$addColumnInfo(name = "meanStudyVar", title = gettext("Study variation"), type = "number") - gaugeEvalTable$addColumnInfo(name = "percentStudy", title = gettext("% Study Variation
(Mean)"), type = "number") - - if(options$tolerance) { - gaugeEvalTable$addColumnInfo(name = "percentTol", title = gettext("% Study Tolerance
(Mean)"), type = "number") - } - - # set data - if(ready) { - gaugeEvalTable$setData(.getGaugeEval(jaspResults, operators, parts, options)) - } else { - return() - } - - return() -} .runMCMC <- function(jaspResults, dataset, measurements, parts, operators, options){ @@ -439,67 +410,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ) } -.getGaugeEval <- function(jaspResults, operators, parts, options){ - excludeInter <- .evalInter(jaspResults, parts, operators, options) - - internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) - - # standard deviation - sdDF <- sqrt(internalDF) - - # get factor for multiplication - if(options$studyVarianceMultiplierType == "sd") { - factorSd <- options$studyVarianceMultiplierValue - } else { - val <- options$studyVarianceMultiplierValue / 100 - q <- (1 - val) / 2 - factorSd <- abs(2 * qnorm(q)) - } - - studyVar <- sdDF * factorSd - - # % Study Variation - percStudy <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) - for(i in 1:ncol(studyVar)){ - percStudy[, i] <- studyVar[[i]] / studyVar$total * 100 - } - - # summaries - meanSds <- colMeans(sdDF) - meanStudyVar <- colMeans(studyVar) - percentStudy <- colMeans(percStudy) - # % Tolerance - if(options$tolerance) { - percTol <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) - for(i in 1:ncol(studyVar)){ - percTol[, i] <- studyVar[[i]] / options$toleranceValue * 100 - } - - percentTol <- colMeans(percTol) - - gaugeEvalDf <- data.frame(sourceName = .sourceNames(), - meanSds, - meanStudyVar, - percentStudy, - percentTol) - } else { - gaugeEvalDf <- data.frame(sourceName = .sourceNames(), - meanSds, - meanStudyVar, - percentStudy) - } - - # add footnotes - # number of distinct categories - nDistinct <- .gaugeNumberDistinctCategories(meanSds["part"], meanSds["gauge"]) - jaspResults[["gaugeEvalTable"]]$addFootnote(gettextf("Number of distinct categories = %d", nDistinct)) - - jaspResults[["gaugeEvalTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) - - - return(gaugeEvalDf) -} .evalInter <- function(jaspResults, parts, operators, options) { if(options$estimationType == "automatic") { @@ -544,6 +455,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # replace total variation with historical variance and adjust # part variation accordingly + # note: these calculations might be problematic since the uncertainty in gauge does not affect part anymore if(options$processVariationReference == "historicalSd"){ totalOld <- mean(total) total <- rep(options$historicalSdValue^2, length(repeatability)) @@ -1150,11 +1062,192 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { lower <- apply(contribution, 2, quantile, probs = 0.025) upper <- apply(contribution, 2, quantile, probs = 0.975) - return(data.frame(sourceName, - means, - lower, - upper) + df <- data.frame(sourceName, + means, + lower, + upper) - ) + # remove upper and lower CrI for total variation + df[df$sourceName == "Total variation", c("lower", "upper")] <- "" + + # remove upper and lower CrI for part variation if historicalSd is specified + if(options$processVariationReference == "historicalSd") { + df[df$sourceName == "Part-to-part", c("lower", "upper")] <- "" + } + + return(df) + +} + + + + + + +.createGaugeEval <- function(jaspResults, parts, operators, options, ready) { + if(!is.null(jaspResults[["gaugeEvaluation"]])) { + return() + } + + gaugeEvaluation <- createJaspContainer(title = gettext("Gauge Evaluation")) + gaugeEvaluation$position <- 4 + gaugeEvaluation$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue", + "tolerance", "toleranceValue")) + jaspResults[["gaugeEvaluation"]] <- gaugeEvaluation + + + + ### Standard deviation table + stdTable <- createJaspTable(title = gettext("Standard deviation")) + stdTable$position <- 1 + gaugeEvaluation[["stdTable"]] <- stdTable + + stdTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + stdTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + stdTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") + stdTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + + if(ready) { + stdTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "sd")) + } + + + ### Study variation table + studyVarTable <- createJaspTable(title = gettext("Study variation")) + studyVarTable$position <- 2 + gaugeEvaluation[["studyVarTable"]] <- studyVarTable + + studyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + studyVarTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + studyVarTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") + studyVarTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + + if(ready) { + studyVarTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")) + } + + ### Percent study variation table + percStudyVarTable <- createJaspTable(title = gettext("% Study variation")) + percStudyVarTable$position <- 3 + gaugeEvaluation[["percStudyVarTable"]] <- percStudyVarTable + + percStudyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + percStudyVarTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + percStudyVarTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") + percStudyVarTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + + if(ready) { + percStudyVarTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percStudyVar")) + } + + + ### Percent tolerance table + if(options$tolerance) { + percTolTable <- createJaspTable(title = gettext("% Tolerance")) + percTolTable$position <- 3 + gaugeEvaluation[["percTolTable"]] <- percTolTable + + percTolTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + percTolTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + percTolTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") + percTolTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + + if(ready) { + percTolTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percTol")) + } + } + + return() + +} + +.fillTablesGaugeEval <- function(jaspResults, parts, operators, options, whichTable = "sd") { + + excludeInter <- .evalInter(jaspResults, parts, operators, options) + + # get components from MCMC samples + internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + + sourceName <- .sourceNames() + sdDf <- sqrt(internalDF) + + # get factor for multiplication + if(options$studyVarianceMultiplierType == "sd") { + factorSd <- options$studyVarianceMultiplierValue + } else { + val <- options$studyVarianceMultiplierValue / 100 + q <- (1 - val) / 2 + factorSd <- abs(2 * qnorm(q)) + } + studyVar <- sdDf * factorSd + + # % Study Variation + percStudy <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) + for(i in 1:ncol(studyVar)){ + percStudy[, i] <- studyVar[[i]] / studyVar$total * 100 + } + + # % Tolerance + if(options$tolerance) { + percTol <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) + for(i in 1:ncol(studyVar)){ + percTol[, i] <- studyVar[[i]] / options$toleranceValue * 100 + } + } + + # output dependent on table + if(whichTable == "sd") { + # summaries + means <- colMeans(sdDf) + lower <- apply(sdDf, 2, quantile, probs = 0.025) + upper <- apply(sdDf, 2, quantile, probs = 0.975) + } + + if(whichTable == "studyVar") { + # summaries + means <- colMeans(studyVar) + lower <- apply(studyVar, 2, quantile, probs = 0.025) + upper <- apply(studyVar, 2, quantile, probs = 0.975) + } + + if(whichTable == "percStudyVar") { + # summaries + means <- colMeans(percStudy) + lower <- apply(percStudy, 2, quantile, probs = 0.025) + upper <- apply(percStudy, 2, quantile, probs = 0.975) + } + + if(whichTable == "percTol") { + # summaries + means <- colMeans(percTol) + lower <- apply(percTol, 2, quantile, probs = 0.025) + upper <- apply(percTol, 2, quantile, probs = 0.975) + } + + # add footnote + jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) + + df <- data.frame(sourceName, + means, + lower, + upper) + + if(whichTable == "percStudyVar") { + # remove upper and lower CrI for total variation + df[df$sourceName == "Total variation", c("lower", "upper")] <- "" + } + + + if(options$processVariationReference == "historicalSd") { + # remove upper and lower CrI for part variation if historicalSd is specified + df[df$sourceName == "Part-to-part", c("lower", "upper")] <- "" + + # remove upper and lower CrI for total variation + df[df$sourceName == "Total variation", c("lower", "upper")] <- "" + } + + return(df) } + From fbe99e41a5c29a9b0369678a832d2734d964c27e Mon Sep 17 00:00:00 2001 From: jvli4n Date: Fri, 13 Jun 2025 11:20:38 +0200 Subject: [PATCH 08/65] Adding R chart & minor changes --- R/msaBayesianGaugeRR.R | 53 +++++++++++++++++++++++++++++---- inst/qml/msaBayesianGaugeRR.qml | 2 +- 2 files changed, 49 insertions(+), 6 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 0b7c7507..c5161e1a 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -83,6 +83,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # dataset <- dataset[order(dataset[[parts]]),] # } + # note: I would probably have to convert the wide to long data for my analysis + if(ready && !options[["type3"]]){ crossed <- .checkIfCrossed(dataset, operators, parts, measurements) if(!crossed){ @@ -169,6 +171,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .createContourPlot(jaspResults, parts, operators, measurements, dataset, options) } + if(options$rChart) { + .createRChart(jaspResults, dataset, measurements, operators, parts, options, ready) + } + } @@ -194,7 +200,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # set data if(ready) { # this could also be sth like if(ncol(dataset) == 3) BFtable$setData(jaspResults[["modelComparison"]][["object"]]) - BFtable$addFootnote(gettext("BF10 compares the full model to the other models.")) + BFtable$addFootnote(gettext("BF10 compares the full model to the indicated model in each row.")) } return() @@ -247,7 +253,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { colnames(bfDf) <- c("comparisonBF", "error") bfDf$modelName <- jaspBase::gsubInteractionSymbol(rownames(bfDf)) - bfDF <- bfDf[order(-bfDf$comparisonBF), ] + bfDF <- bfDf[order(bfDf$comparisonBF), ] jaspResults[["modelComparison"]][["object"]] <- bfDf @@ -1205,6 +1211,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } if(whichTable == "studyVar") { + # add footnote + jaspResults[["gaugeEvaluation"]][["studyVarTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) + # summaries means <- colMeans(studyVar) lower <- apply(studyVar, 2, quantile, probs = 0.025) @@ -1225,9 +1234,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { upper <- apply(percTol, 2, quantile, probs = 0.975) } - # add footnote - jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) - df <- data.frame(sourceName, means, lower, @@ -1251,3 +1257,40 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } +.createRChart <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { + if(!is.null(jaspResults[["rChart"]])) { + return() + } + + jaspResults[["rChart"]] <- createJaspContainer(gettext("Range chart by operator")) + jaspResults[["rChart"]]$position <- 7 + jaspResults[["rChart"]]$dependOn(c("rChart", "measurementLongFormat", + "measurementsWideFormat", "report")) + jaspResults[["rChart"]][["plot"]] <- createJaspPlot(title = gettext("Range chart by operator"), width = 1200, height = 500) + if (ready) { + # converting data to wide format for the .controlChart function (note: this can be done more nicely) + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + rChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "R", + stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], + stagesSeparateCalculation = FALSE) + + jaspResults[["rChart"]][["plot"]]$plotObject <- rChart$plotObject + jaspResults[["rChart"]][["table"]] <- rChart$table + } + + return() +} + +.convertToWide <- function(dataset, measurements, parts, operators) { + dataset <- dataset[order(dataset[[operators]]),] + dataset <- dataset[order(dataset[[parts]]),] + nrep <- table(dataset[operators])[[1]]/length(unique(dataset[[parts]])) + index <- rep(paste("V", 1:nrep, sep = ""), nrow(dataset)/nrep) + dataset <- cbind(dataset, data.frame(index = index)) + dataset <- tidyr::spread(dataset, index, measurements) + measurements <- unique(index) + dataset <- dataset[,c(operators, parts, measurements)] + + return(dataset) +} diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index de1cc0c0..ad6a3109 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -146,7 +146,7 @@ Form DoubleField { name: "bfFavorFull" - label: qsTr("BF in favor of full model") + label: qsTr("Cut-off BF in favor of full model") id: bfFavorFull defaultValue: 1 min: 0.001 From 0ea2675adac15deb6a170179700a974815135786 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 17 Jun 2025 18:28:16 +0200 Subject: [PATCH 09/65] Multiple distributions & output - Allowing to fit metalog or generalised inverse Gaussian to MCMC samples - Merging some of the output tables together --- R/msaBayesianGaugeRR.R | 821 +++++++++++++++++++------------- inst/qml/msaBayesianGaugeRR.qml | 17 + renv.lock | 6 + 3 files changed, 522 insertions(+), 322 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index c5161e1a..a491fe40 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -143,7 +143,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # MCMC if(ready) { .runMCMC(jaspResults, dataset, measurements, parts, operators, options) - .fitMetaLog(jaspResults) + .fitDistToSamples(jaspResults, options, samplesMat = jaspResults[["MCMCsamples"]][["object"]]) } # Variance components table @@ -479,36 +479,36 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(internalDF) } -.fitMetaLog <- function(jaspResults) { - if(is.null(jaspResults[["metaLogFit"]])){ - metaLogFit <- createJaspState() - metaLogFit$dependOn(.mcmcDependencies()) - jaspResults[["metaLogFit"]] <- metaLogFit - } else { - return() - } - - samplesMat <- jaspResults[["MCMCsamples"]][["object"]] - - # fit metalog to each parameter - metaLogList <- apply(samplesMat, 2, - function(x) rmetalog::metalog(x, bounds = 0, boundedness = "sl")) - - # find optimal number of terms for each parameter - optimalTerms <- Map(.optimalMetaLog, metaLogList, names(metaLogList), - MoreArgs = list(samplesMat = samplesMat)) - - # add optimal terms to list - metaLogList <- Map(function(x, optimalTerms){ - x[["optimalTerms"]] <- optimalTerms - x - }, metaLogList, optimalTerms) - - metaLogFit[["object"]] <- metaLogList - - return() - -} +# .fitMetaLog <- function(jaspResults) { +# if(is.null(jaspResults[["metaLogFit"]])){ +# metaLogFit <- createJaspState() +# metaLogFit$dependOn(.mcmcDependencies()) +# jaspResults[["metaLogFit"]] <- metaLogFit +# } else { +# return() +# } +# +# samplesMat <- jaspResults[["MCMCsamples"]][["object"]] +# +# # fit metalog to each parameter +# metaLogList <- apply(samplesMat, 2, +# function(x) rmetalog::metalog(x, bounds = 0, boundedness = "sl")) +# +# # find optimal number of terms for each parameter +# optimalTerms <- Map(.optimalMetaLog, metaLogList, names(metaLogList), +# MoreArgs = list(samplesMat = samplesMat)) +# +# # add optimal terms to list +# metaLogList <- Map(function(x, optimalTerms){ +# x[["optimalTerms"]] <- optimalTerms +# x +# }, metaLogList, optimalTerms) +# +# metaLogFit[["object"]] <- metaLogList +# +# return() +# +# } .createPostSummaryTable <- function(jaspResults, options, parts, operators){ if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]])){ @@ -558,200 +558,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.fillPostSummaryTable <- function(jaspResults, options, parts, operators) { - if(is.null(jaspResults[["postSummaryStats"]]) && (options$posteriorCi || options$posteriorPointEstimate)){ - postSummaryStats <- createJaspState() - postSummaryStats$dependOn(c(.mcmcDependencies(), - .postPlotDependencies())) - jaspResults[["postSummaryStats"]] <- postSummaryStats - } else { - return() - } - - fits <- jaspResults[["metaLogFit"]][["object"]] - - parameter <- .convertOutputNames(names(fits), parts, operators) - - # point estimates - if(options$posteriorPointEstimate) { - - pointEstimate <- switch(options$posteriorPointEstimateType, - "mean" = unlist(lapply(fits, .meanMetaLog)), - "median" = unlist(lapply(fits, .medianMetaLog)), - "mode" = unlist(lapply(fits, .modeMetaLog))) # note: the mode still seems to be a bit off - } - - # intervals - if(options$posteriorCi) { - - intervals <- switch(options$posteriorCiType, - "central" = Map(.centralInterMetaLog, fits, mass = options$posteriorCiMass), - "HPD" = Map(.hdiMetaLog, fits, mass = options$posteriorCiMass), - "custom" = Map(.customInterMetaLog, fits, - lower = options$posteriorCiLower, - upper = options$posteriorCiUpper)) - - # lower and upper bounds separately - lower <- sapply(intervals, function(x) x[1]) - upper <- sapply(intervals, function(x) x[2]) - } - - if(options$posteriorPointEstimate && options$posteriorCi == FALSE) { - df <- data.frame(parameter, - pointEstimate) - } else if(options$posteriorPointEstimate == FALSE && options$posteriorCi) { - df <- data.frame(parameter, - ciLower = lower, - ciUpper = upper) - } else { - df <- data.frame(parameter, - pointEstimate, - ciLower = lower, - ciUpper = upper) - } - postSummaryStats[["object"]] <- df - - return() -} - -.plotVariancePosteriors <- function(jaspResults, options, parts, operators){ - - if(!is.null(jaspResults[["variancePosteriors"]])){ - return() - } - - variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) - variancePosteriors$position <- 5 - variancePosteriors$dependOn(c(.mcmcDependencies(), - .postPlotDependencies())) - jaspResults[["variancePosteriors"]] <- variancePosteriors - - fits <- jaspResults[["metaLogFit"]][["object"]] - titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) - postSummary <- jaspResults[["postSummaryStats"]][["object"]] - modes <- lapply(fits, .modeMetaLog) - - - for(i in seq_along(titles)) { - tempPlot <- createJaspPlot(title = gettext(titles[i]), width = 600, height = 320) - - # axis limits - dfTemp <- fits[[i]]$dataValues - - if(options$posteriorCi) { - xUpper <- ceiling(max(dfTemp[dfTemp$probs >= 0.975, ]$x_new[1], postSummary[i, "ciUpper"])) - } else { - xUpper <- ceiling(dfTemp[dfTemp$probs >= 0.975, ]$x_new[1]) - } - xLower <- 0 - xLims <- c(xLower, xUpper) - xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) - - yUpper <- rmetalog::dmetalog(m = fits[[i]], q = modes[[i]], term = fits[[i]]$optimalTerms) - yLower <- 0 - yLims <- c(yLower, yUpper) - yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) - - - p <- ggplot2::ggplot() - - # credible interval - if(options$posteriorCi) { - ciUpper <- postSummary[i, "ciUpper"] - ciLower <- postSummary[i, "ciLower"] - - p <- p + - ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$optimalTerms), - geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") - } - - p <- p + - ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$optimalTerms), - linewidth = 1) - - - # point estimate - if(options$posteriorPointEstimate) { - xPoint <- postSummary[i, "pointEstimate"] - yPoint <- rmetalog::dmetalog(m = fits[[i]], q = xPoint, term = fits[[i]]$optimalTerms) - pointDf <- data.frame(xPoint, yPoint) - - p <- p + ggplot2::geom_point(data = pointDf, mapping = ggplot2::aes(x = xPoint, y = yPoint), - shape = 21, size = 4, fill = "grey", stroke = 1) - } - - - - - # axes - xLab <- titles[i] - p <- p + - ggplot2::scale_x_continuous(name = bquote(sigma[.(xLab)]^2), breaks = xBreaks, - limits = xLims, labels = xBreaks) + - ggplot2::scale_y_continuous(name = "Density", breaks = yBreaks, - limits = yLims, labels = yBreaks) - - # theme - p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe(sides = "bl") - - tempPlot$plotObject <- p - variancePosteriors[[titles[i]]] <- tempPlot - } - - - - - # df <- samplesMat <- as.data.frame(jaspResults[["MCMCsamples"]][["object"]]) - # CrIs <- apply(df, 2, quantile, probs = c(0.025, 0.975)) - # parameters <- colnames(samplesMat) - # - # # axis labels - # cleanLabel <- sub("^g_", "", parameters) - # cleanLabel <- sub("sig2", "Error", cleanLabel) - # names(cleanLabel) <- parameters - # - # # Create label with sigma^2 - # axisLabs <- sapply(cleanLabel, function(x) bquote(sigma^2 ~ .(x)) ) - # - # - # for(i in seq_along(parameters)) { - # tempPlot <- createJaspPlot(title = gettext(parameters[i]), width = 600, height = 320) - # - # # obtain density from ggplot - # p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[[parameters[i]]])) + - # ggplot2::geom_density() - # - # density_data <- ggplot2::ggplot_build(p)$data[[1]] - # - # fillDensity <- density_data[density_data$x >= CrIs[, parameters[i]][1] & density_data$x <= CrIs[, parameters[i]][2], ] - # - # # x and y limits & coordinates for errorbar - # xLow <- floor(min(0, CrIs[, parameters[i]][1] - CrIs[, parameters[i]][1] * 0.1)) - # xUpper <- ceiling(max(CrIs[, parameters[i]][2] / 90 * 100, density_data[density_data$y < 0.005, "x"][1])) - # xLims <- c(xLow, xUpper) - # - # yLow <- 0 - # yUpper <- max(density_data$y) + 0.01 - # yLims <- c(yLow, yUpper) - # - # yErrorbar <- yUpper / 100 * 95 - # heightErrorbar <- yUpper / 100 * 5 - # - # - # tempPlot$plotObject <- ggplot2::ggplot(df, ggplot2::aes(x = .data[[parameters[i]]])) + - # ggplot2::geom_density() + - # ggplot2::geom_density(data = fillDensity, ggplot2::aes(x = x, y = y), fill = "blue", alpha = 0.4) + - # jaspGraphs::scale_y_continuous("Density", limits = yLims, breaks = jaspGraphs::getPrettyAxisBreaks(yLims)) + - # jaspGraphs::scale_x_continuous(axisLabs[[parameters[i]]], limits = xLims, breaks = jaspGraphs::getPrettyAxisBreaks(xLims)) + - # #ggplot2::geom_errorbarh(ggplot2::aes(xmin = CrIs[, parameters[i]][1], xmax = CrIs[, parameters[i]][2], y = 1), height = heightErrorbar) + - # jaspGraphs::themeJaspRaw() + - # jaspGraphs::geom_rangeframe(sides = "bl") - # - # variancePosteriors[[parameters[i]]] <- tempPlot - # - # } - return() -} .createContourPlot <- function(jaspResults, parts, operators, measurements, dataset, options) { if(!is.null(jaspResults[["contourPlot"]])) { @@ -881,62 +687,35 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .postPlotDependencies <- function() { return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", - "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot")) -} - -.optimalMetaLog <- function(fit, parameter, samplesMat) { - terms <- fit$params$term_limit - - error <- numeric(length(terms)) - - for(j in 2:terms){ - # quantiles - j <- as.numeric(j) - qmeta <- rmetalog::qmetalog(m = fit, y = c(0.025, 0.975), term = j) - qdata <- quantile(samplesMat[, parameter], probs = c(0.025, 0.975)) - - errorCrI <- sum(abs(qdata - qmeta)) - - # mean - meanMeta <- integrate(rmetalog::qmetalog, m = fit, term = j, lower = 0, upper = 1)$value # integrate over quantile function - meanData <- mean(samplesMat[, parameter]) - - errorMean <- abs(meanData - meanMeta) - - error[j] <- sum(errorCrI, errorMean) - } - #print(error) - return(which.min(error[-1]) + 1) -} - -.meanMetaLog <- function(fit) { - m <- integrate(rmetalog::qmetalog, m = fit, term = fit$optimalTerms, - lower = 0, upper = 1)$value -} - -.medianMetaLog <- function(fit) { - m <- rmetalog::qmetalog(m = fit, y = 0.5, term = fit$optimalTerms) -} - -.modeMetaLog <- function(fit) { - m <- optimize(rmetalog::dmetalog, interval = c(0, max(fit$dataValues[1])), - m = fit, term = fit$optimalTerms, maximum = TRUE)$maximum + "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", + "distType")) } -.centralInterMetaLog <- function(fit, mass) { - lower <- (1 - mass) / 2 - upper <- 1 - lower - int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$optimalTerms) -} - -.hdiMetaLog <- function(fit, mass) { - samples <- rmetalog::rmetalog(m = fit, n = 1e5, term = fit$optimalTerms) - int <- HDInterval::hdi(samples, credMass = mass) -} +# .optimalMetaLog <- function(fit, parameter, samplesMat) { +# terms <- fit$params$term_limit +# +# error <- numeric(length(terms)) +# +# for(j in 2:terms){ +# # quantiles +# j <- as.numeric(j) +# qmeta <- rmetalog::qmetalog(m = fit, y = c(0.025, 0.975), term = j) +# qdata <- quantile(samplesMat[, parameter], probs = c(0.025, 0.975)) +# +# errorCrI <- sum(abs(qdata - qmeta)) +# +# # mean +# meanMeta <- integrate(rmetalog::qmetalog, m = fit, term = j, lower = 0, upper = 1)$value # integrate over quantile function +# meanData <- mean(samplesMat[, parameter]) +# +# errorMean <- abs(meanData - meanMeta) +# +# error[j] <- sum(errorCrI, errorMean) +# } +# #print(error) +# return(which.min(error[-1]) + 1) +# } -.customInterMetaLog <- function(fit, lower, upper) { - int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$optimalTerms) -} .convertOutputNames <- function(name, parts, operators, includeSigma = TRUE) { sigmaPart <- paste0("g_", parts) @@ -1102,68 +881,93 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { "tolerance", "toleranceValue")) jaspResults[["gaugeEvaluation"]] <- gaugeEvaluation - - - ### Standard deviation table - stdTable <- createJaspTable(title = gettext("Standard deviation")) + ### Standard deviation & study variation table + stdTable <- createJaspTable(title = gettext("Standard Deviation & Study Variation")) stdTable$position <- 1 gaugeEvaluation[["stdTable"]] <- stdTable - stdTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - stdTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - stdTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") - stdTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + stdTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + stdTable$addColumnInfo(name = "meansStd", title = gettext("Mean
Std"), type = "number") + stdTable$addColumnInfo(name = "lowerStd", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
Std") + stdTable$addColumnInfo(name = "upperStd", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
Std") + stdTable$addColumnInfo(name = "meansStudyVar", title = gettext("Mean
Study Variation"), type = "number") + stdTable$addColumnInfo(name = "lowerStudyVar", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
Study Variation") + stdTable$addColumnInfo(name = "upperStudyVar", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
Study Variation") if(ready) { - stdTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "sd")) + stdData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "sd") + colnames(stdData) <- c("sourceName", "meansStd", "lowerStd", "upperStd") # note: this could already be part of the function + studyVarData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")[, -1] # remove source name + colnames(studyVarData) <- c("meansStudyVar", "lowerStudyVar", "upperStudyVar") + stdTable$setData(cbind(stdData, studyVarData)) } - ### Study variation table - studyVarTable <- createJaspTable(title = gettext("Study variation")) - studyVarTable$position <- 2 - gaugeEvaluation[["studyVarTable"]] <- studyVarTable - - studyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - studyVarTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - studyVarTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") - studyVarTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + # ### Study variation table + # studyVarTable <- createJaspTable(title = gettext("Study variation")) + # studyVarTable$position <- 2 + # gaugeEvaluation[["studyVarTable"]] <- studyVarTable + # + # studyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + # studyVarTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + # studyVarTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") + # studyVarTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + # + # if(ready) { + # studyVarTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")) + # } - if(ready) { - studyVarTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")) + ### Percent study variation & percent tolerance table + if(options$tolerance) { + title <- "% Study Variation & % Tolerance" + } else { + title <- "% Study Variation" } - - ### Percent study variation table - percStudyVarTable <- createJaspTable(title = gettext("% Study variation")) - percStudyVarTable$position <- 3 + percStudyVarTable <- createJaspTable(title = gettext(title)) + percStudyVarTable$position <- 2 gaugeEvaluation[["percStudyVarTable"]] <- percStudyVarTable - percStudyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - percStudyVarTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - percStudyVarTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") - percStudyVarTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + percStudyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + percStudyVarTable$addColumnInfo(name = "meansPercStudy", title = gettext("Mean
% Study Variation"), type = "number") + percStudyVarTable$addColumnInfo(name = "lowerPercStudy", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
% Study Variation") + percStudyVarTable$addColumnInfo(name = "upperPercStudy", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
% Study Variation") - if(ready) { - percStudyVarTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percStudyVar")) - } - - - ### Percent tolerance table if(options$tolerance) { - percTolTable <- createJaspTable(title = gettext("% Tolerance")) - percTolTable$position <- 3 - gaugeEvaluation[["percTolTable"]] <- percTolTable + percStudyVarTable$addColumnInfo(name = "meansPercTol", title = gettext("Mean
% Tolerance"), type = "number") + percStudyVarTable$addColumnInfo(name = "lowerPercTol", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
% Tolerance") + percStudyVarTable$addColumnInfo(name = "upperPercTol", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
% Tolerance") + } - percTolTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - percTolTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - percTolTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") - percTolTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + if(ready) { + percStudyData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percStudyVar") + colnames(percStudyData) <- c("sourceName", "meansPercStudy", "lowerPercStudy", "upperPercStudy") - if(ready) { - percTolTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percTol")) + if(!options$tolerance) { + percStudyVarTable$setData(percStudyData) + } else { + percTolData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percTol")[, -1] + colnames(percTolData) <- c("meansPercTol", "lowerPercTol", "upperPercTol") + percStudyVarTable$setData(cbind(percStudyData, percTolData)) } } + + # ### Percent tolerance table + # if(options$tolerance) { + # percTolTable <- createJaspTable(title = gettext("% Tolerance")) + # percTolTable$position <- 3 + # gaugeEvaluation[["percTolTable"]] <- percTolTable + # + # percTolTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + # percTolTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + # percTolTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") + # percTolTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + # + # if(ready) { + # percTolTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percTol")) + # } + # } + return() } @@ -1212,7 +1016,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(whichTable == "studyVar") { # add footnote - jaspResults[["gaugeEvaluation"]][["studyVarTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) + jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) # summaries means <- colMeans(studyVar) @@ -1294,3 +1098,376 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(dataset) } + + + +###### Distribution fitting + +### fit functions +.fitDistToSamples <- function(jaspResults, options, samplesMat) { + if(is.null(jaspResults[["distFit"]])){ + distFit <- createJaspState() # note: add dependency on user input for dist from qml + distFit$dependOn(c(.mcmcDependencies(), "distType")) + jaspResults[["distFit"]] <- distFit + } else { + return() + } + + # note: I could also pass a list with distribution names and fitting functions here + distType <- options$distType + + if(options$setSeed) { + set.seed(options$seed) + } + fit <- switch(distType, + "metalog" = .fitMetaLog(samplesMat, bounds = 0, boundedness = "sl", + term_lower_bound = 6, term_limit = 6), # 6 terms + "gig" = .fitGIG(samplesMat)) + + distFit[["object"]] <- fit + + return() +} + +## MetaLog +.fitMetaLog <- function(samplesMat, ...) { + # fit metalog to each parameter + metaLogList <- apply(samplesMat, 2, + function(x) rmetalog::metalog(x, ...)) + return(metaLogList) +} + +## Generalized Inverse Gaussian +.fitGIG <- function(samplesMat) { + gigFitList <- apply(samplesMat, 2, + function(x) GeneralizedHyperbolic::gigFit(x)) + + # add random samples + gigFitList <- lapply(gigFitList, + function(x) { + x$randData <- GeneralizedHyperbolic::rgig(1e5, param = x$param) + return(x) + }) + return(gigFitList) +} + + +### posterior summary +.fillPostSummaryTable <- function(jaspResults, options, parts, operators) { + if(is.null(jaspResults[["postSummaryStats"]]) && (options$posteriorCi || options$posteriorPointEstimate)){ + postSummaryStats <- createJaspState() + postSummaryStats$dependOn(c(.mcmcDependencies(), + .postPlotDependencies())) + jaspResults[["postSummaryStats"]] <- postSummaryStats + } else { + return() + } + + fits <- jaspResults[["distFit"]][["object"]] + + parameter <- .convertOutputNames(names(fits), parts, operators) # note: this should only happen when the fits are based on the variance parameters + + # point estimates + if(options$posteriorPointEstimate) { + # list with functions for different distributions + pointEstimateFunctions <- .pointEstimateFunctions() + + # select the right function + pointFun <- pointEstimateFunctions[[options$distType]][[options$posteriorPointEstimateType]] + + pointEstimate <- switch(options$posteriorPointEstimateType, + "mean" = unlist(lapply(fits, pointFun)), + "median" = unlist(lapply(fits, pointFun)), + "mode" = unlist(lapply(fits, pointFun))) # note: the mode still seems to be a bit off + } + + # intervals + if(options$posteriorCi) { + # list with functions for different distributions + intervalFunctions <- .intervalFunctions() + + # select the right function + interFun <- intervalFunctions[[options$distType]][[options$posteriorCiType]] + + if(options$setSeed) { + set.seed(options$seed) + } + + intervals <- switch(options$posteriorCiType, + "central" = Map(interFun, fits, mass = options$posteriorCiMass), + "HPD" = Map(interFun, fits, mass = options$posteriorCiMass), + "custom" = Map(interFun, fits, + lower = options$posteriorCiLower, + upper = options$posteriorCiUpper)) + + # lower and upper bounds separately + lower <- sapply(intervals, function(x) x[1]) + upper <- sapply(intervals, function(x) x[2]) + } + + if(options$posteriorPointEstimate && options$posteriorCi == FALSE) { + df <- data.frame(parameter, + pointEstimate) + } else if(options$posteriorPointEstimate == FALSE && options$posteriorCi) { + df <- data.frame(parameter, + ciLower = lower, + ciUpper = upper) + } else { + df <- data.frame(parameter, + pointEstimate, + ciLower = lower, + ciUpper = upper) + } + postSummaryStats[["object"]] <- df + + return() +} + + +### functions point estimates +.pointEstimateFunctions <- function() { + l <- list( + metalog = list( + mean = .meanMetaLog, + median = .medianMetaLog, + mode = .modeMetaLog + ), + gig = list( + mean = .meanGIG, + median = .medianGIG, + mode = .modeGIG + ) + ) + return(l) +} + +## MetaLog +.meanMetaLog <- function(fit) { + m <- integrate(rmetalog::qmetalog, m = fit, term = fit$params$term_limit, + lower = 0, upper = 1)$value +} + +.medianMetaLog <- function(fit) { + m <- rmetalog::qmetalog(m = fit, y = 0.5, term = fit$params$term_limit) +} + +.modeMetaLog <- function(fit) { + m <- optimize(rmetalog::dmetalog, interval = c(0, max(fit$dataValues[1])), + m = fit, term = fit$params$term_limit, maximum = TRUE)$maximum +} + +## Generalized Inverse Gaussian +.meanGIG <- function(fit) { + m <- GeneralizedHyperbolic::gigMean(param = fit$param) +} + +.medianGIG <- function(fit) { + m <- quantile(fit$randData, probs = 0.5) +} + +.modeGIG <- function(fit) { + m <- GeneralizedHyperbolic::gigMode(param = fit$param) +} + +### functions interval estimates +.intervalFunctions <- function() { + l <- list( + metalog = list( + central = .centralInterMetaLog, + HPD = .hdiMetaLog, + custom = .customInterMetaLog + ), + gig = list( + central = .centralInterGIG, + HPD = .hdiGIG, + custom = .customInterGIG + ) + ) +} + +## MetaLog +.centralInterMetaLog <- function(fit, mass) { + lower <- (1 - mass) / 2 + upper <- 1 - lower + int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$params$term_limit) +} + +.hdiMetaLog <- function(fit, mass) { + samples <- rmetalog::rmetalog(m = fit, n = 1e5, term = fit$params$term_limit) + int <- HDInterval::hdi(samples, credMass = mass) +} + +.customInterMetaLog <- function(fit, lower, upper) { + int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$params$term_limit) +} + +## Generalized inverse Gaussian +.centralInterGIG <- function(fit, mass) { + lower <- (1 - mass) / 2 + upper <- 1 - lower + int <- quantile(fit$randData, probs = c(lower, upper)) +} + +.hdiGIG <- function(fit, mass) { + int <- HDInterval::hdi(fit$randData, credMass = mass) +} + +.customInterGIG <- function(fit, lower, upper) { + int <- quantile(fit$randData, probs = c(lower, upper)) +} + + +### posterior plots +.plotVariancePosteriors <- function(jaspResults, options, parts, operators){ + + if(!is.null(jaspResults[["variancePosteriors"]])){ + return() + } + + variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) + variancePosteriors$position <- 5 + variancePosteriors$dependOn(c(.mcmcDependencies(), + .postPlotDependencies())) + jaspResults[["variancePosteriors"]] <- variancePosteriors + + fits <- jaspResults[["distFit"]][["object"]] + titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) # note: this function needs to be modified so it produces the right lables for the percentages as well + postSummary <- jaspResults[["postSummaryStats"]][["object"]] # note: this needs to be replaced if I plot dists for the percentages + + + + for(i in seq_along(titles)) { + tempPlot <- createJaspPlot(title = gettext(titles[i]), width = 600, height = 320) + + # select function for axis limits based on distribution + axisFun <- .axisLimFuns()[[options$distType]] + + lims <- axisFun(fits[[i]], postSummary, options, iter = i) + + p <- ggplot2::ggplot() + + # credible interval + if(options$posteriorCi) { + ciUpper <- postSummary[i, "ciUpper"] + ciLower <- postSummary[i, "ciLower"] + + p <- p + + if(options$distType == "metalog") { + ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), + geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") + # note: it might make sense to just pass some approximation of the density to the plotting function in case of the metalog + # so it only has to evaluate the density function once + } else { # note: this would be nicer with a list of functions again, but the functions take different arguments + ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), + geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") + } + } + + p <- p + + if(options$distType == "metalog") { + ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), + linewidth = 1) + } else { # note: see above + ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), + linewidth = 1) + } + + + # point estimate + if(options$posteriorPointEstimate) { + xPoint <- postSummary[i, "pointEstimate"] + yPoint <- ifelse(options$distType == "metalog", + rmetalog::dmetalog(m = fits[[i]], q = xPoint, term = fits[[i]]$params$term_limit), + GeneralizedHyperbolic::dgig(x = xPoint, param = fits[[i]]$param)) + pointDf <- data.frame(xPoint, yPoint) + + p <- p + ggplot2::geom_point(data = pointDf, mapping = ggplot2::aes(x = xPoint, y = yPoint), + shape = 21, size = 4, fill = "grey", stroke = 1) + } + + # axes + xLab <- titles[i] + p <- p + + ggplot2::scale_x_continuous(name = bquote(sigma[.(xLab)]^2), breaks = lims$x$breaks, + limits = lims$x$limits, labels = lims$x$breaks) + + ggplot2::scale_y_continuous(name = "Density", breaks = lims$y$breaks, + limits = lims$y$limits, labels = lims$y$breaks) + + # theme + p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe(sides = "bl") + + tempPlot$plotObject <- p + variancePosteriors[[titles[i]]] <- tempPlot + } + return() +} + +## axis limits +.axisLimFuns <- function() { + l <- list( + metalog = .axisLimsMetaLog, + gig = .axisLimsGIG + ) + return(l) +} + +# Metalog +.axisLimsMetaLog <- function(fit, postSummary, options, iter) { + + dfTemp <- fit$dataValues + m <- .modeMetaLog(fit) + + if(options$posteriorCi) { + xUpper <- ceiling(max(dfTemp[dfTemp$probs >= 0.975, ]$x_new[1], postSummary[iter, "ciUpper"])) + } else { + xUpper <- ceiling(dfTemp[dfTemp$probs >= 0.975, ]$x_new[1]) + } + xLower <- 0 + xLims <- c(xLower, xUpper) + xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) + + yUpper <- rmetalog::dmetalog(m = fit, q = m, term = fit$params$term_limit) + yLower <- 0 + yLims <- c(yLower, yUpper) + yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) + + l <- list( + x = list(limits = xLims, + breaks = xBreaks), + y = list(limits = yLims, + breaks = yBreaks) + ) + return(l) +} + +# Generalized inverse Gaussian +.axisLimsGIG <- function(fit, postSummary, options, iter) { + + quant <- quantile(fit$randData, 0.975) # for upper xLim + m <- .modeGIG(fit) + + if(options$posteriorCi) { + xUpper <- ceiling(max(quant, postSummary[iter, "ciUpper"])) + } else { + xUpper <- ceiling(quant) + } + xLower <- 0 + xLims <- c(xLower, xUpper) + xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) + + yUpper <- GeneralizedHyperbolic::dgig(x = m, param = fit$param) + yLower <- 0 + yLims <- c(yLower, yUpper) + yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) + + l <- list( + x = list(limits = xLims, + breaks = xBreaks), + y = list(limits = yLims, + breaks = yBreaks) + ) + return(l) +} + + + diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index ad6a3109..63d9c00c 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -518,6 +518,23 @@ Form fieldWidth: 60 } } + + Group + { + title: qsTr("Distribution fit to MCMC samples") + + DropDown + { + name: "distType" + label: qsTr("Distribution") + values: + [ + { label: qsTr("Generalized inverse Gaussian"), value: "gig" }, + { label: qsTr("Metalog"), value: "metalog" } + ] + indexDefaultValue: 0 + } + } } Section diff --git a/renv.lock b/renv.lock index 3e42f42b..389b8d2b 100644 --- a/renv.lock +++ b/renv.lock @@ -108,6 +108,12 @@ "stats" ] }, + "GeneralizedHyperbolic": { + "Package": "GeneralizedHyperbolic", + "Version": "0.8-7", + "Source": "Repository", + "Repository": "CRAN" + }, "HDInterval": { "Package": "HDInterval", "Version": "0.2.4", From c7667ba58b23362209c83647bcc6ff71af7058d9 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 18 Jun 2025 16:17:12 +0200 Subject: [PATCH 10/65] Fix parameter MCMC samples - Correction of the calculations for variance parameters - Storing % Contribution, Study Variation and Tolerance as JaspStates for plotting --- R/msaBayesianGaugeRR.R | 94 +++++++++++++++++++++++++++++++----------- 1 file changed, 71 insertions(+), 23 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index a491fe40..1ef82ea9 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -311,7 +311,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { contribTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") if(ready) { - contribTable$setData(.getPercContrib(jaspResults, parts, operators, options)) + .getPercContrib(jaspResults, parts, operators, options) + contribTable$setData(jaspResults[["percContribSamples"]][["object"]]) } else { return() } @@ -364,19 +365,16 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # select relevant parameters # names - # note this could be written into a helper function - sigmaPart <- paste0("g_", parts) - sigmaOperator <- paste0("g_", operators) - sigmaInter <- paste0("g_", parts, ":", operators) - - if(excludeInter){ - chains <- chains[, c(sigmaPart, sigmaOperator, "sig2")] - } else { - chains <- chains[, c(sigmaPart, sigmaOperator, sigmaInter, "sig2")] - } + paramNames <- .bfParameterNames(parts, operators, excludeInter) + chains <- chains[, c(paramNames, "sig2")] # including error variance samplesMat <- as.matrix(chains) + # multiply variances with the error variance to reverse standardization + for(i in paramNames) { + samplesMat[, i] <- samplesMat[, i] * samplesMat[, "sig2"] + } + MCMCsamples[["object"]] <- samplesMat return() @@ -649,15 +647,20 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # helper functions -.bfParameterNames <- function(parts, operators) { +.bfParameterNames <- function(parts, operators, excludeInter) { sigmaPart <- paste0("g_", parts) sigmaOperator <- paste0("g_", operators) sigmaInter <- paste0("g_", parts, ":", operators) - return(list(sigmaPart, sigmaOperator, sigmaInter)) + if(excludeInter) { + res <- c(sigmaPart, sigmaOperator) + } else { + res <- c(sigmaPart, sigmaOperator, sigmaInter) + } + return(res) } -.sourceNames <- function(){ +.sourceNames <- function() { return(c("Total gauge r&R", "Repeatability", "Reproducibility", @@ -831,6 +834,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } .getPercContrib <- function(jaspResults, parts, operators, options) { + if(is.null(jaspResults[["percContribSamples"]])) { + percContribSamples <- createJaspState() + percContribSamples$dependOn(.varCompTableDependencies()) + jaspResults[["percContribSamples"]] <- percContribSamples + } else { + return() + } + excludeInter <- .evalInter(jaspResults, parts, operators, options) # get components from MCMC samples @@ -860,8 +871,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { df[df$sourceName == "Part-to-part", c("lower", "upper")] <- "" } - return(df) + percContribSamples[["object"]] <- df + return() } @@ -972,6 +984,46 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } +.getPercStudy <- function(jaspResults, studyVar) { + if(is.null(jaspResults[["percStudySamples"]])) { + percStudySamples <- createJaspState() + percStudySamples$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["percStudySamples"]] <- percStudySamples + } else { + return() + } + + percStudy <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) + for(i in 1:ncol(studyVar)){ + percStudy[, i] <- studyVar[[i]] / studyVar$total * 100 + } + + percStudySamples[["object"]] <- percStudy + + return() +} + +.getPercTol <- function(jaspResults, studyVar, options) { + if(is.null(jaspResults[["percTolSamples"]])) { + percTolSamples <- createJaspState() + percTolSamples$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["percTolSamples"]] <- percTolSamples + } else { + return() + } + + percTol <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) + for(i in 1:ncol(studyVar)){ + percTol[, i] <- studyVar[[i]] / options$toleranceValue * 100 + } + + percTolSamples[["object"]] <- percTol + + return() +} + .fillTablesGaugeEval <- function(jaspResults, parts, operators, options, whichTable = "sd") { excludeInter <- .evalInter(jaspResults, parts, operators, options) @@ -993,17 +1045,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { studyVar <- sdDf * factorSd # % Study Variation - percStudy <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) - for(i in 1:ncol(studyVar)){ - percStudy[, i] <- studyVar[[i]] / studyVar$total * 100 - } + .getPercStudy(jaspResults, studyVar) + percStudy <- jaspResults[["percStudySamples"]][["object"]] # % Tolerance if(options$tolerance) { - percTol <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) - for(i in 1:ncol(studyVar)){ - percTol[, i] <- studyVar[[i]] / options$toleranceValue * 100 - } + .getPercTol(jaspResults, studyVar, options) + percTol <- jaspResults[["percTolSamples"]][["object"]] } # output dependent on table From d46de46ebca3fdfae86168294f13100d8eb9ce19 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Sat, 21 Jun 2025 16:18:05 +0200 Subject: [PATCH 11/65] Adding Plots 1) Adding posteriors for percentages 2) Adding descriptive plots that are already part of the frequentist module --- R/msaBayesianGaugeRR.R | 255 +++++++++++++++++++++++++++----- inst/qml/msaBayesianGaugeRR.qml | 21 ++- 2 files changed, 238 insertions(+), 38 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 1ef82ea9..56ab6024 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -140,10 +140,21 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # .createEffectsTable(effectsRes, jaspResults, measurements, parts, operators, ready) # } - # MCMC + if(ready) { + # MCMC .runMCMC(jaspResults, dataset, measurements, parts, operators, options) - .fitDistToSamples(jaspResults, options, samplesMat = jaspResults[["MCMCsamples"]][["object"]]) + + # compute percentages + .getStudyVariation(jaspResults, parts, operators, options) + .getPercContrib(jaspResults, parts, operators, options) + .getPercStudy(jaspResults) + + if(options$tolerance) { + .getPercTol(jaspResults, options) + } + + .fitDistToSamples(jaspResults, options) } # Variance components table @@ -171,10 +182,33 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .createContourPlot(jaspResults, parts, operators, measurements, dataset, options) } + # range chart if(options$rChart) { .createRChart(jaspResults, dataset, measurements, operators, parts, options, ready) } + # average chart + if(options$xBarChart) { + .createXbarChart(jaspResults, dataset, measurements, operators, parts, options, ready) + } + + # scatter plot + if(options$scatterPlot){ + .createScatterPlotOperators(jaspResults, dataset, measurements, operators, parts, options, ready) + } + + # measurement by part plot + if(ready && options$partMeasurementPlot) { + .createMeasureByPartPlot(jaspResults, dataset, measurements, operators, parts, options) + } + + if(ready && options$operatorMeasurementPlot) { + .createMeasureByOperatorPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) + } + + if(ready && options$partByOperatorMeasurementPlot) { + .createPartByOperatorInterPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) + } } @@ -311,8 +345,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { contribTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") if(ready) { - .getPercContrib(jaspResults, parts, operators, options) - contribTable$setData(jaspResults[["percContribSamples"]][["object"]]) + contribTable$setData(.percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options)) } else { return() } @@ -515,7 +548,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { postSummary <- createJaspTable(title = gettext("Posterior Summary")) postSummary$position <- 1 - postSummary$dependOn(c(.mcmcDependencies(), + postSummary$dependOn(c(.varCompTableDependencies(), .postPlotDependencies())) jaspResults[["variancePosteriors"]][["postSummary"]] <- postSummary @@ -539,7 +572,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { overtitle <- paste0(mass, "% ", "Credible Interval") - postSummary$addColumnInfo(name = "parameter", title = gettext("Parameter"), type = "string") + postSummary$addColumnInfo(name = "parameter", title = gettext("Source"), type = "string") if(options$posteriorPointEstimate) { postSummary$addColumnInfo(name = "pointEstimate", title = gettext(pointEst), type = "number") @@ -691,7 +724,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .postPlotDependencies <- function() { return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", - "distType")) + "distType", "posteriorPlotType", "tolerance", "toleranceValue")) } # .optimalMetaLog <- function(fit, parameter, samplesMat) { @@ -853,10 +886,16 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { contribution[, i] <- internalDF[[i]] / internalDF$total * 100 } + percContribSamples[["object"]] <- contribution + + return() +} + +.percentSampleSummaries <- function(samples, options) { sourceName <- .sourceNames() - means <- colMeans(contribution) - lower <- apply(contribution, 2, quantile, probs = 0.025) - upper <- apply(contribution, 2, quantile, probs = 0.975) + means <- colMeans(samples) + lower <- apply(samples, 2, quantile, probs = 0.025) + upper <- apply(samples, 2, quantile, probs = 0.975) df <- data.frame(sourceName, means, @@ -870,17 +909,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(options$processVariationReference == "historicalSd") { df[df$sourceName == "Part-to-part", c("lower", "upper")] <- "" } - - percContribSamples[["object"]] <- df - - return() + return(df) } - - - - .createGaugeEval <- function(jaspResults, parts, operators, options, ready) { if(!is.null(jaspResults[["gaugeEvaluation"]])) { return() @@ -984,7 +1016,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } -.getPercStudy <- function(jaspResults, studyVar) { +.getPercStudy <- function(jaspResults, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { if(is.null(jaspResults[["percStudySamples"]])) { percStudySamples <- createJaspState() percStudySamples$dependOn(c(.varCompTableDependencies(), @@ -1004,11 +1036,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.getPercTol <- function(jaspResults, studyVar, options) { +.getPercTol <- function(jaspResults, options, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { if(is.null(jaspResults[["percTolSamples"]])) { percTolSamples <- createJaspState() percTolSamples$dependOn(c(.varCompTableDependencies(), - "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + "studyVarianceMultiplierType", "studyVarianceMultiplierValue", "tolerance", "toleranceValue")) jaspResults[["percTolSamples"]] <- percTolSamples } else { return() @@ -1024,14 +1056,21 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.fillTablesGaugeEval <- function(jaspResults, parts, operators, options, whichTable = "sd") { +.getStudyVariation <- function(jaspResults, parts, operators, options) { + if(is.null(jaspResults[["studyVariation"]])) { + studyVariation <- createJaspState() + studyVariation$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["studyVariation"]] <- studyVariation + } else { + return() + } excludeInter <- .evalInter(jaspResults, parts, operators, options) # get components from MCMC samples internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) - sourceName <- .sourceNames() sdDf <- sqrt(internalDF) # get factor for multiplication @@ -1044,19 +1083,36 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } studyVar <- sdDf * factorSd + studyVariation[["object"]] <- list(studyVar, factorSd) + + return() +} + +.fillTablesGaugeEval <- function(jaspResults, parts, operators, options, whichTable = "sd") { + excludeInter <- .evalInter(jaspResults, parts, operators, options) + + # get components from MCMC samples + internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + + sourceName <- .sourceNames() + + sdDf <- sqrt(internalDF) + + # Study variation + studyVar <- jaspResults[["studyVariation"]][["object"]][[1]] + # % Study Variation - .getPercStudy(jaspResults, studyVar) percStudy <- jaspResults[["percStudySamples"]][["object"]] # % Tolerance if(options$tolerance) { - .getPercTol(jaspResults, studyVar, options) percTol <- jaspResults[["percTolSamples"]][["object"]] } # output dependent on table if(whichTable == "sd") { # summaries + # note: here i could use the .percentSampleSummaries function means <- colMeans(sdDf) lower <- apply(sdDf, 2, quantile, probs = 0.025) upper <- apply(sdDf, 2, quantile, probs = 0.975) @@ -1064,6 +1120,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(whichTable == "studyVar") { # add footnote + factorSd <- jaspResults[["studyVariation"]][["object"]][[2]] jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) # summaries @@ -1118,7 +1175,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["rChart"]]$position <- 7 jaspResults[["rChart"]]$dependOn(c("rChart", "measurementLongFormat", "measurementsWideFormat", "report")) - jaspResults[["rChart"]][["plot"]] <- createJaspPlot(title = gettext("Range chart by operator"), width = 1200, height = 500) + jaspResults[["rChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) if (ready) { # converting data to wide format for the .controlChart function (note: this can be done more nicely) dataset <- .convertToWide(dataset, measurements, parts, operators) @@ -1152,15 +1209,36 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ###### Distribution fitting ### fit functions -.fitDistToSamples <- function(jaspResults, options, samplesMat) { +.fitDistToSamples <- function(jaspResults, options) { if(is.null(jaspResults[["distFit"]])){ - distFit <- createJaspState() # note: add dependency on user input for dist from qml - distFit$dependOn(c(.mcmcDependencies(), "distType")) + distFit <- createJaspState() + distFit$dependOn(c(.mcmcDependencies(), "distType", "posteriorPlotType", "processVariationReference", + "tolerance", "toleranceValue")) jaspResults[["distFit"]] <- distFit } else { return() } + samplesMat <- switch(options$posteriorPlotType, + "var" = jaspResults[["MCMCsamples"]][["object"]], + "percContrib" = jaspResults[["percContribSamples"]][["object"]], + "percStudyVar" = jaspResults[["percStudySamples"]][["object"]], + "percTol" = jaspResults[["percTolSamples"]][["object"]]) + + saveRDS(samplesMat, "/Users/julian/Documents/Jasp files/samplesMat.rds") + + if(options$posteriorPlotType != "var") { + colnames(samplesMat) <- .sourceNames() + + # filter out columns that only have the same value + samplesMat <- samplesMat[, apply(samplesMat, 2, function(col) length(unique(col)) > 1)] + + # remove part-to-part variation if historical sd is specified + if(options$processVariationReference == "historicalSd"){ + samplesMat <- samplesMat[, !colnames(samplesMat) %in% "Part-to-part"] + } + } + # note: I could also pass a list with distribution names and fitting functions here distType <- options$distType @@ -1169,7 +1247,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } fit <- switch(distType, "metalog" = .fitMetaLog(samplesMat, bounds = 0, boundedness = "sl", - term_lower_bound = 6, term_limit = 6), # 6 terms + term_lower_bound = 5, term_limit = 5), # 5 terms "gig" = .fitGIG(samplesMat)) distFit[["object"]] <- fit @@ -1204,7 +1282,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .fillPostSummaryTable <- function(jaspResults, options, parts, operators) { if(is.null(jaspResults[["postSummaryStats"]]) && (options$posteriorCi || options$posteriorPointEstimate)){ postSummaryStats <- createJaspState() - postSummaryStats$dependOn(c(.mcmcDependencies(), + postSummaryStats$dependOn(c(.varCompTableDependencies(), .postPlotDependencies())) jaspResults[["postSummaryStats"]] <- postSummaryStats } else { @@ -1213,7 +1291,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { fits <- jaspResults[["distFit"]][["object"]] - parameter <- .convertOutputNames(names(fits), parts, operators) # note: this should only happen when the fits are based on the variance parameters + if(options$posteriorPlotType == "var") { + parameter <- .convertOutputNames(names(fits), parts, operators) # note: this should only happen when the fits are based on the variance parameters + } else { + parameter <- names(fits) + } # point estimates if(options$posteriorPointEstimate) { @@ -1374,12 +1456,17 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) variancePosteriors$position <- 5 - variancePosteriors$dependOn(c(.mcmcDependencies(), + variancePosteriors$dependOn(c(.varCompTableDependencies(), .postPlotDependencies())) jaspResults[["variancePosteriors"]] <- variancePosteriors fits <- jaspResults[["distFit"]][["object"]] - titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) # note: this function needs to be modified so it produces the right lables for the percentages as well + + if(options$posteriorPlotType == "var") { + titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) # note: this function needs to be modified so it produces the right lables for the percentages as well + } else { + titles <- names(fits) + } postSummary <- jaspResults[["postSummaryStats"]][["object"]] # note: this needs to be replaced if I plot dists for the percentages @@ -1434,9 +1521,18 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # axes - xLab <- titles[i] + xLab <- switch(options$posteriorPlotType, + "var" = titles[i], + "percContrib" = "% Contribution", + "percStudyVar" = "% Study Variation", + "percTol" = "% Tolerance") + if(options$posteriorPlotType == "var"){ + xLab <- bquote(sigma[.(xLab)]^2) + } + p <- p + - ggplot2::scale_x_continuous(name = bquote(sigma[.(xLab)]^2), breaks = lims$x$breaks, + ggplot2::scale_x_continuous(name = xLab, + breaks = lims$x$breaks, limits = lims$x$limits, labels = lims$x$breaks) + ggplot2::scale_y_continuous(name = "Density", breaks = lims$y$breaks, limits = lims$y$limits, labels = lims$y$breaks) @@ -1517,5 +1613,92 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(l) } +.createXbarChart <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { + if(!is.null(jaspResults[["xBarChart"]])) { + return() + } + + jaspResults[["xBarChart"]] <- createJaspContainer(gettext("Average chart by operator")) + jaspResults[["xBarChart"]]$position <- 8 + jaspResults[["xBarChart"]]$dependOn(c("xBarChart", "measurementLongFormat", + "measurementsWideFormat", "report")) + jaspResults[["xBarChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) + if (ready) { + # converting data to wide format for the .controlChart function (note: this can be done more nicely) + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + xBarChart <- .controlChart(dataset = dataset[c(measurements, operators)], + plotType = "xBar", xBarSdType = "r", stages = operators, + xAxisLabels = dataset[[parts]][order(dataset[[operators]])], + stagesSeparateCalculation = FALSE) + + jaspResults[["xBarChart"]][["plot"]]$plotObject <- xBarChart$plotObject + jaspResults[["xBarChart"]][["table"]] <- xBarChart$table + } + + return() +} + + +.createScatterPlotOperators <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { + if(!is.null(jaspResults[["gaugeScatterOperators"]]) || !ready) { + return() + } + + # note: I could convert the data in the main analysis function and then just pass it to the functions + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + + jaspResults[["gaugeScatterOperators"]] <- .gaugeScatterPlotOperators(jaspResults = jaspResults, dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready) + jaspResults[["gaugeScatterOperators"]]$position <- 9 + jaspResults[["gaugeScatterOperators"]]$dependOn(c("scatterPlot", "scatterPlotFitLine", "scatterPlotOriginLine")) + + + return() +} + +.createMeasureByPartPlot <- function(jaspResults, dataset, measurements, operators, parts, options) { + if (!is.null(jaspResults[["gaugeByPart"]])) { + return() + } + # note: I could convert the data in the main analysis function and then just pass it to the functions + datasetWide <- .convertToWide(dataset, measurements, parts, operators) + measurementsWide <- c("V1", "V2", "V3") + + jaspResults[["gaugeByPart"]] <- .gaugeByPartGraph(dataset = datasetWide, measurements = measurementsWide, parts = parts, operators = operators, options = options) + jaspResults[["gaugeByPart"]]$position <- 10 + jaspResults[["gaugeByPart"]]$dependOn("partMeasurementPlotAllValues") + + return() +} + +.createMeasureByOperatorPlot <- function(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) { + if(!is.null(jaspResults[["gaugeByOperator"]])) { + return() + } + # note: I could convert the data in the main analysis function and then just pass it to the functions + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + jaspResults[["gaugeByOperator"]] <- .gaugeByOperatorGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) + jaspResults[["gaugeByOperator"]]$position <- 11 + jaspResults[["gaugeByOperator"]]$dependOn("operatorMeasurementPlot") # note: should this also depend on type3? + return() +} + +.createPartByOperatorInterPlot <- function(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) { + if(!is.null(jaspResults[["gaugeByInteraction"]])) { + return() + } + # note: I could convert the data in the main analysis function and then just pass it to the functions + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + + jaspResults[["gaugeByInteraction"]] <- .gaugeByInteractionGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) + jaspResults[["gaugeByInteraction"]]$position <- 12 + jaspResults[["gaugeByInteraction"]]$dependOn("partByOperatorMeasurementPlot") # note: should this also depend on type3? + + return() + +} diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 63d9c00c..639b7bb7 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -202,6 +202,7 @@ Form { name: "tolerance" label: qsTr("Tolerance width") + id: tolerance childrenOnSameRow: true DoubleField @@ -273,6 +274,22 @@ Form label: qsTr("Posterior") checked: false + DropDown + { + name: "posteriorPlotType" + label: "" + values: tolerance.checked ? [ + { label: qsTr("Variances"), value: "var" }, + { label: qsTr("%Contribution"), value: "percContrib"}, + { label: qsTr("%Study variation"), value: "percStudyVar"}, + { label: qsTr("%Tolerance"), value: "percTol"} + ] : [ + { label: qsTr("Variances"), value: "var" }, + { label: qsTr("%Contribution"), value: "percContrib"}, + { label: qsTr("%Study variation"), value: "percStudyVar"} + ] + } + CheckBox { label: qsTr("Point estimate") @@ -330,7 +347,7 @@ Form fieldWidth: 50 defaultValue: 0.25 min: 0 - max: plotsPriorMarginalUpper.value + max: posteriorCiUpper.value inclusive: JASP.None } @@ -340,7 +357,7 @@ Form enabled: posteriorCi.checked name: "posteriorCiUpper" label: qsTr("Upper") - id: plotsPriorMarginalUpper + id: posteriorCiUpper fieldWidth: 50 defaultValue: 0.75 min: posteriorCiLower.value From 0b6b96cce5999aa9ace19a77932f3b8acf7c6300 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Mon, 23 Jun 2025 16:31:54 +0200 Subject: [PATCH 12/65] Prior & Long Format 1) Adding plot for g-prior 2) Function for conversion from wide to long format --- R/msaBayesianGaugeRR.R | 51 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 50 insertions(+), 1 deletion(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 56ab6024..3e79ff7e 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -83,7 +83,12 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # dataset <- dataset[order(dataset[[parts]]),] # } - # note: I would probably have to convert the wide to long data for my analysis + # Converting wide to long format + if(wideFormat && ready) { + dataset <- .convertToLong(dataset, measurements) + measurements <- "Measurements" # name assigned to the column inside the function + } + if(ready && !options[["type3"]]){ crossed <- .checkIfCrossed(dataset, operators, parts, measurements) @@ -166,6 +171,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # Gauge evaluation table .createGaugeEval(jaspResults, parts, operators, options, ready) + # prior + if(ready && options$priorPlot) { + .plotPrior(jaspResults, options) + } + # posteriors if(ready && options$posteriorPlot){ .fillPostSummaryTable(jaspResults, options, parts, operators) @@ -1702,3 +1712,42 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } + +.plotPrior <- function(jaspResults, options) { + if(!is.null(jaspResults[["priorPlot"]])) { + return() + } + priorPlot <- createJaspContainer(title = gettext("Prior Distribution")) + priorPlot$position <- 5 + priorPlot$dependOn("rscalePrior") + jaspResults[["priorPlot"]] <- priorPlot + + gPrior <- createJaspPlot(title = gettext("g-prior"), width = 600, height = 320) + + # axis limit + xUpper <- extraDistr::qinvchisq(0.75, nu = 1, tau = options$rscalePrior^2) + xBreaks <- jaspGraphs::getPrettyAxisBreaks(c(0, xUpper)) + + p <- ggplot2::ggplot() + + ggplot2::stat_function(fun = extraDistr::dinvchisq, + args = list(nu = 1, tau = options$rscalePrior^2), + linewidth = 1) + + # axes + p <- p + ggplot2::scale_y_continuous("Density") + + ggplot2::scale_x_continuous("g", breaks = xBreaks, limits = c(0, xUpper)) + + # JASP theme + p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe() + gPrior$plotObject <- p + + priorPlot[["plot"]] <- gPrior + + return() +} + +.convertToLong <- function(dataset, measurements) { + dataset <- tidyr::pivot_longer(dataset, cols = tidyr::all_of(measurements), + values_to = "Measurements", names_to = NULL) + return(dataset) +} From 9a738d19b2a4087935c8374fa7c93f588f440c26 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 24 Jun 2025 12:56:35 +0200 Subject: [PATCH 13/65] Plots - Adding variance components and traffic light charts to Bayesian module - Adjusting plotting functions from frequentist module to include intervals --- R/msaBayesianGaugeRR.R | 109 ++++++++++++++++++++++++++++++++++++++++- R/msaGaugeRR.R | 35 +++++++++++-- 2 files changed, 139 insertions(+), 5 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 3e79ff7e..6f15711f 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -155,6 +155,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .getPercContrib(jaspResults, parts, operators, options) .getPercStudy(jaspResults) + ##### delete + percContrib <- .percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options) + saveRDS(percContrib, "/Users/julian/Documents/Jasp files/percContrib.rds") + ##### if(options$tolerance) { .getPercTol(jaspResults, options) } @@ -187,6 +191,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } } + if(ready && options$varianceComponentsGraph) { + .createVarCompPlot(jaspResults, options) + } + # contour plot if(ready && options$contourPlot) { .createContourPlot(jaspResults, parts, operators, measurements, dataset, options) @@ -219,6 +227,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(ready && options$partByOperatorMeasurementPlot) { .createPartByOperatorInterPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) } + + if(ready && options$trafficLightChart) { + .createTrafficLightPlot(jaspResults, options) + } } @@ -913,7 +925,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { upper) # remove upper and lower CrI for total variation - df[df$sourceName == "Total variation", c("lower", "upper")] <- "" + df[df$sourceName == "Total variation", c("lower", "upper")] <- "" # note: this coerces the whole columns to be of type chr # remove upper and lower CrI for part variation if historicalSd is specified if(options$processVariationReference == "historicalSd") { @@ -1302,7 +1314,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { fits <- jaspResults[["distFit"]][["object"]] if(options$posteriorPlotType == "var") { - parameter <- .convertOutputNames(names(fits), parts, operators) # note: this should only happen when the fits are based on the variance parameters + parameter <- .convertOutputNames(names(fits), parts, operators) } else { parameter <- names(fits) } @@ -1751,3 +1763,96 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { values_to = "Measurements", names_to = NULL) return(dataset) } + +.createVarCompPlot <- function(jaspResults, options) { + if(!is.null(jaspResults[["varCompPlot"]])) { + return() + } + varCompPlot <- createJaspPlot(title = gettext("Components of variation"), width = 850, height = 500) + varCompPlot$position <- 6 + varCompPlot$dependOn(c(.varCompTableDependencies(), "varianceComponentsGraph", + "tolerance", "toleranceValue", + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["varCompPlot"]] <- varCompPlot + + # obtain summaries + percContrib <- .percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options) + percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) + + # remove unnecessary rows + percContrib <- percContrib[!percContrib$sourceName %in% c("Operator", "Total variation"), ] + percStudyVar <- percStudyVar[!percStudyVar$sourceName %in% c("Operator", "Total variation"), ] + + # values for credible intervals + errorbarDf <- rbind(percContrib[, c("lower", "upper")], percStudyVar[, c("lower", "upper")]) + + if(options$tolerance) { + percTol <- .percentSampleSummaries(jaspResults[["percTolSamples"]][["object"]], options) + + # remove unnecessary rows + percTol <- percTol[!percTol$sourceName %in% c("Operator", "Total variation"), ] + + errorbarDf <- rbind(errorbarDf, percTol[, c("lower", "upper")]) + + p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, percTol$means, + errorbarDf = errorbarDf) + } else { + p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, rep(NA, 4), + errorbarDf = errorbarDf) + } + + varCompPlot$plotObject <- p + + return() +} + +.createTrafficLightPlot <- function(jaspResults, options) { + if(!is.null(jaspResults[["trafficPlot"]])) { + return() + } + + trafficPlot <- createJaspContainer(title = gettext("Traffic light chart")) + trafficPlot$position <- 12 + trafficPlot$dependOn(c(.varCompTableDependencies(), "trafficLightChart", + "tolerance", "toleranceValue", + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["trafficPlot"]] <- trafficPlot + + # % Study var + trafficPlotStudy <- createJaspPlot(width = 1000) + trafficPlotStudy$position <- 1 + percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) + percStudyVar <- percStudyVar[percStudyVar$sourceName == "Total gauge r&R", ] + percStudyVarMean <- percStudyVar$means + percStudyVarCrI <- data.frame(lower = as.numeric(percStudyVar["lower"]), + upper = as.numeric(percStudyVar["upper"])) + + if(!options$tolerance) { + p <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = FALSE, + ToleranceVar = 0, + options = options, ready = TRUE, ggPlot = TRUE, StudyVarCi = percStudyVarCrI) + trafficPlotStudy$plotObject <- p + } else { + # % Tolerance + trafficPlotTol <- createJaspPlot(width = 1000) + trafficPlotTol$position <- 2 + percTol <- .percentSampleSummaries(jaspResults[["percTolSamples"]][["object"]], options) + percTol <- percTol[percTol$sourceName == "Total gauge r&R", ] + percTolMean <- percTol$means + percTolCrI <- data.frame(lower = as.numeric(percTol["lower"]), + upper = as.numeric(percTol["upper"])) + + plots <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = TRUE, + ToleranceVar = percTolMean, + options = options, ready = TRUE, ggPlot = TRUE, + StudyVarCi = percStudyVarCrI, + TolCi = percTolCrI) + + trafficPlotStudy$plotObject <- plots[[2]] + trafficPlotTol$plotObject <- plots[[1]] + trafficPlot[["trafficPlotTol"]] <- trafficPlotTol + } + + trafficPlot[["trafficPlotStudy"]] <- trafficPlotStudy + return() +} diff --git a/R/msaGaugeRR.R b/R/msaGaugeRR.R index 652e4984..47df5b8c 100644 --- a/R/msaGaugeRR.R +++ b/R/msaGaugeRR.R @@ -883,7 +883,7 @@ msaGaugeRR <- function(jaspResults, dataset, options, ...) { return(p) } -.gaugeVarCompGraph <- function(percentContributionValues, studyVariationValues, percentToleranceValues, Type3 = FALSE) { +.gaugeVarCompGraph <- function(percentContributionValues, studyVariationValues, percentToleranceValues, Type3 = FALSE, errorbarDf = NULL) { sources <- gettext(c('Gauge r&R', 'Repeat', 'Reprod', 'Part-to-part')) if (!all(is.na(percentToleranceValues))) { references <- gettextf(c('%% Contribution', '%% Study variation', '%% Tolerance')) @@ -904,7 +904,26 @@ msaGaugeRR <- function(jaspResults, dataset, options, ...) { p <- ggplot2::ggplot() + ggplot2::geom_bar(data = plotframe, mapping = ggplot2::aes(fill = reference, y = value, x = source), - position="dodge", stat = "identity") + + position="dodge", stat = "identity") + + # add errorbars + if(!is.null(errorbarDf)) { + errorbarDf$source <- plotframe$source + errorbarDf$reference <- plotframe$reference + errorbarDf$lower <- as.numeric(errorbarDf$lower) + errorbarDf$upper <- as.numeric(errorbarDf$upper) + + p <- p + ggplot2::geom_errorbar(data = errorbarDf, + ggplot2::aes(x = plotframe$source, + ymax = upper, ymin = lower, + fill = plotframe$reference), + position = ggplot2::position_dodge(0.9), + size = 0.5, width = 0.5) + yBreaks <- jaspGraphs::getPrettyAxisBreaks(c(0, plotframe$value, + errorbarDf$lower, + errorbarDf$upper)) + } + p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe() + ggplot2::theme(legend.position = 'right', legend.title = ggplot2::element_blank()) + @@ -1042,7 +1061,7 @@ msaGaugeRR <- function(jaspResults, dataset, options, ...) { } return(TRUE) } -.trafficplot <- function(StudyVar = "", ToleranceUsed = FALSE, ToleranceVar = "", options, ready, Xlab.StudySD = "", Xlab.Tol = "", ggPlot = FALSE) { +.trafficplot <- function(StudyVar = "", ToleranceUsed = FALSE, ToleranceVar = "", options, ready, Xlab.StudySD = "", Xlab.Tol = "", ggPlot = FALSE, StudyVarCi = NULL, TolCi = NULL) { if (!ready) return() @@ -1081,6 +1100,10 @@ msaGaugeRR <- function(jaspResults, dataset, options, ...) { if (Xlab.StudySD != "") p1 <- p1 + ggplot2::scale_x_continuous(breaks = c(0,10,30,100), labels = c("0%","10%","30%","100%"), name = gettext(Xlab.StudySD)) + if(!is.null(StudyVarCi)) { + p1 <- p1 + ggplot2::geom_errorbarh(data = StudyVarCi, ggplot2::aes(xmin = lower, xmax = upper, y = 1), + inherit.aes = FALSE, linewidth = 0.5, height = 0.5) + } if (ToleranceUsed){ p2 <- ggplot2::ggplot(mat[c(4:6),], ggplot2::aes(x = x, y = Yes, fill = fill)) + @@ -1099,6 +1122,12 @@ msaGaugeRR <- function(jaspResults, dataset, options, ...) { if (Xlab.Tol != "") p2 <- p2 + ggplot2::scale_x_continuous(breaks = c(0,10,30,100), labels = c("0%","10%","30%","100%"), name = gettext(Xlab.Tol)) + if(!is.null(TolCi)) { + TolCi$upper <- ifelse(TolCi$upper > 100, 100, TolCi$upper) + p2 <- p2 + ggplot2::geom_errorbarh(data = TolCi, ggplot2::aes(xmin = lower, xmax = upper, y = 1), + inherit.aes = FALSE, linewidth = 0.5, height = 0.5) + } + p3 <- jaspGraphs::ggMatrixPlot(plotList = list(p2, p1), layout = matrix(2:1, 2)) Plot$plotObject <- p3 From a699417df4cf631642f33672691eb73db04ba5ef Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 25 Jun 2025 10:45:16 +0200 Subject: [PATCH 14/65] Implementation Type3 Study --- R/msaBayesianGaugeRR.R | 201 ++++++++++++++++++++------------ inst/qml/msaBayesianGaugeRR.qml | 3 +- 2 files changed, 127 insertions(+), 77 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 6f15711f..3ad90201 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -272,31 +272,43 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } - - formula <- as.formula(paste(measurements, "~", parts, "*", operators)) - - if(options$setSeed) { set.seed(options$seed) } - # run general comparison for all potential models - bfFit <- BayesFactor::generalTestBF(formula, data = dataset, - whichRandom = c(operators, parts), - rscaleRandom = options$rscalePrior, - progress = FALSE) - bfDf <- as.data.frame(bfFit) + if(options$type3){ + formula <- as.formula(paste(measurements, "~", parts)) + bfFit <- BayesFactor::generalTestBF(formula, data = dataset, + whichRandom = c(operators, parts), + rscaleRandom = options$rscalePrior, + progress = FALSE) + bfDf <- as.data.frame(bfFit) + full <- parts + bfFullNull <- bfDf$bf + + } else { + formula <- as.formula(paste(measurements, "~", parts, "*", operators)) + + # run general comparison for all potential models + bfFit <- BayesFactor::generalTestBF(formula, data = dataset, + whichRandom = c(operators, parts), + rscaleRandom = options$rscalePrior, + progress = FALSE) + bfDf <- as.data.frame(bfFit) + + # extract full model and model with only main effects + main <- paste(parts, "+", operators) + full <- paste0(parts, " + ", operators, " + ", parts, ":", operators) + bfDf <- bfDf[c(main, full), ] + + bfFullNull <- bfDf[full, ]$bf + } - # extract full model and model with only main effects - main <- paste(parts, "+", operators) - full <- paste0(parts, " + ", operators, " + ", parts, ":", operators) - bfDf <- bfDf[c(main, full), ] # dropping unnecessary columns bfDf <- bfDf[, !colnames(bfDf) %in% c("time", "code")] # obtain BF comparing full model to other models - bfFullNull <- bfDf[full, ]$bf bfDf$bf <- bfFullNull / bfDf$bf # add null model @@ -307,9 +319,12 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # add model names & change colnames colnames(bfDf) <- c("comparisonBF", "error") - bfDf$modelName <- jaspBase::gsubInteractionSymbol(rownames(bfDf)) + bfDf$modelName <- rownames(bfDf) + if(!options$type3) { + bfDf$modelName <- jaspBase::gsubInteractionSymbol(bfDf$modelName) + } - bfDF <- bfDf[order(bfDf$comparisonBF), ] + bfDf <- bfDf[order(-bfDf$comparisonBF), ] jaspResults[["modelComparison"]][["object"]] <- bfDf @@ -339,7 +354,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(ready) { varCompTable$setData(.getVarianceComponents(jaspResults, parts, operators, options)) - if(.evalInter(jaspResults, parts, operators, options)) { + if(!options$type3 && .evalInter(jaspResults, parts, operators, options)) { varCompTable$addFootnote("The components are based on the model only including the main effects.") } else { varCompTable$addFootnote("The components are based on the full model.") @@ -387,18 +402,23 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } - # obtain BF in favor of full over main effects model - excludeInter <- .evalInter(jaspResults, parts, operators, options) - if(excludeInter){ - formula <- as.formula(paste(measurements, "~", parts, "+", operators)) + if(!options$type3){ + # obtain BF in favor of full over main effects model + excludeInter <- .evalInter(jaspResults, parts, operators, options) + if(excludeInter){ + formula <- as.formula(paste(measurements, "~", parts, "+", operators)) + } else { + formula <- as.formula(paste(measurements, "~", parts, "*", operators)) + } + # fit the model with BayesFactor + fit <- BayesFactor::lmBF(formula, whichRandom = c(parts, operators), + data = dataset, rscaleRandom = options$rscalePrior) } else { - formula <- as.formula(paste(measurements, "~", parts, "*", operators)) + formula <- as.formula(paste(measurements, "~", parts)) + fit <- BayesFactor::lmBF(formula, whichRandom = parts, + data = dataset, rscaleRandom = options$rscalePrior) } - # fit the model with BayesFactor - fit <- BayesFactor::lmBF(formula, whichRandom = c(parts, operators), - data = dataset, rscaleRandom = options$rscalePrior) - nchains <- options$mcmcChains burnin <- options$mcmcBurnin iter <- options$mcmcIterations @@ -420,7 +440,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # select relevant parameters # names - paramNames <- .bfParameterNames(parts, operators, excludeInter) + paramNames <- .bfParameterNames(parts, operators, excludeInter, options) chains <- chains[, c(paramNames, "sig2")] # including error variance samplesMat <- as.matrix(chains) @@ -459,7 +479,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } - sourceName <- .sourceNames() + sourceName <- .sourceNames(options) return(data.frame(sourceName, postMeans, @@ -500,16 +520,20 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { samplesMat <- jaspResults[["MCMCsamples"]][["object"]] - # obtain relevant components - if(excludeInter){ - reprod <- samplesMat[, sigmaOperator] - } else { - reprod <- samplesMat[, sigmaOperator] + samplesMat[, sigmaInter] - } repeatability <- samplesMat[, "sig2"] - gauge <- reprod + repeatability - operator <- samplesMat[, sigmaOperator] part <- samplesMat[, sigmaPart] + if(!options$type3) { + # obtain relevant components + if(excludeInter){ + reprod <- samplesMat[, sigmaOperator] + } else { + reprod <- samplesMat[, sigmaOperator] + samplesMat[, sigmaInter] + } + gauge <- reprod + repeatability + operator <- samplesMat[, sigmaOperator] + } else { + gauge <- repeatability + } total <- gauge + part # replace total variation with historical variance and adjust @@ -522,13 +546,20 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { part <- mean(part) + diffTotals } - internalDF <- data.frame(gauge, - repeatability, - reprod, - operator, - part, - total - ) + if(!options$type3) { + internalDF <- data.frame(gauge, + repeatability, + reprod, + operator, + part, + total + ) + } else { + internalDF <- data.frame(gauge, + repeatability, + part, + total) + } return(internalDF) } @@ -702,26 +733,39 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # helper functions -.bfParameterNames <- function(parts, operators, excludeInter) { +.bfParameterNames <- function(parts, operators, excludeInter, options) { sigmaPart <- paste0("g_", parts) sigmaOperator <- paste0("g_", operators) sigmaInter <- paste0("g_", parts, ":", operators) - if(excludeInter) { - res <- c(sigmaPart, sigmaOperator) + if(!options$type3) { + if(excludeInter) { + res <- c(sigmaPart, sigmaOperator) + } else { + res <- c(sigmaPart, sigmaOperator, sigmaInter) + } } else { - res <- c(sigmaPart, sigmaOperator, sigmaInter) + res <- sigmaPart } return(res) } -.sourceNames <- function() { - return(c("Total gauge r&R", - "Repeatability", - "Reproducibility", - "Operator", - "Part-to-part", - "Total variation")) +.sourceNames <- function(options) { + if(options$type3) { + res <- c("Total gauge r&R", + "Repeatability", + "Part-to-part", + "Total variation") + } else { + res <- c("Total gauge r&R", + "Repeatability", + "Reproducibility", + "Operator", + "Part-to-part", + "Total variation") + } + + return(res) } .bfTableDependencies <- function() { @@ -914,7 +958,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } .percentSampleSummaries <- function(samples, options) { - sourceName <- .sourceNames() + sourceName <- .sourceNames(options) means <- colMeans(samples) lower <- apply(samples, 2, quantile, probs = 0.025) upper <- apply(samples, 2, quantile, probs = 0.975) @@ -1116,7 +1160,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # get components from MCMC samples internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) - sourceName <- .sourceNames() + sourceName <- .sourceNames(options) sdDf <- sqrt(internalDF) @@ -1250,7 +1294,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { saveRDS(samplesMat, "/Users/julian/Documents/Jasp files/samplesMat.rds") if(options$posteriorPlotType != "var") { - colnames(samplesMat) <- .sourceNames() + colnames(samplesMat) <- .sourceNames(options) # filter out columns that only have the same value samplesMat <- samplesMat[, apply(samplesMat, 2, function(col) length(unique(col)) > 1)] @@ -1477,7 +1521,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) - variancePosteriors$position <- 5 + variancePosteriors$position <- 6 variancePosteriors$dependOn(c(.varCompTableDependencies(), .postPlotDependencies())) jaspResults[["variancePosteriors"]] <- variancePosteriors @@ -1786,6 +1830,12 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # values for credible intervals errorbarDf <- rbind(percContrib[, c("lower", "upper")], percStudyVar[, c("lower", "upper")]) + # adding NAs for the reproducibility row because the plotting function expects the row to be present + if(options$type3) { + percContrib <- rbind(percContrib[1:2, ], NA, percContrib[3, ]) + percStudyVar <- rbind(percStudyVar[1:2, ], NA, percStudyVar[3, ]) + } + if(options$tolerance) { percTol <- .percentSampleSummaries(jaspResults[["percTolSamples"]][["object"]], options) @@ -1794,11 +1844,15 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { errorbarDf <- rbind(errorbarDf, percTol[, c("lower", "upper")]) + if(options$type3) { + percTol <- rbind(percTol[1:2, ], NA, percTol[3, ]) + } + p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, percTol$means, - errorbarDf = errorbarDf) + errorbarDf = errorbarDf, Type3 = options$type3) } else { - p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, rep(NA, 4), - errorbarDf = errorbarDf) + p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, NA, + errorbarDf = errorbarDf, Type3 = options$type3) } varCompPlot$plotObject <- p @@ -1828,10 +1882,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { upper = as.numeric(percStudyVar["upper"])) if(!options$tolerance) { - p <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = FALSE, - ToleranceVar = 0, - options = options, ready = TRUE, ggPlot = TRUE, StudyVarCi = percStudyVarCrI) - trafficPlotStudy$plotObject <- p + p <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = FALSE, + ToleranceVar = 0, + options = options, ready = TRUE, StudyVarCi = percStudyVarCrI) } else { # % Tolerance trafficPlotTol <- createJaspPlot(width = 1000) @@ -1842,17 +1895,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { percTolCrI <- data.frame(lower = as.numeric(percTol["lower"]), upper = as.numeric(percTol["upper"])) - plots <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = TRUE, - ToleranceVar = percTolMean, - options = options, ready = TRUE, ggPlot = TRUE, - StudyVarCi = percStudyVarCrI, - TolCi = percTolCrI) - - trafficPlotStudy$plotObject <- plots[[2]] - trafficPlotTol$plotObject <- plots[[1]] - trafficPlot[["trafficPlotTol"]] <- trafficPlotTol + p <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = TRUE, + ToleranceVar = percTolMean, + options = options, ready = TRUE, + StudyVarCi = percStudyVarCrI, + TolCi = percTolCrI) } + trafficPlot[["trafficPlot"]] <- p - trafficPlot[["trafficPlotStudy"]] <- trafficPlotStudy return() } diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 639b7bb7..3a2069be 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -136,6 +136,7 @@ Form label: qsTr("Estimation") id: estimationType indexDefaultValue: 0 + visible: !type3.checked values: [ { label: qsTr("Automatic"), value: "automatic" }, @@ -151,7 +152,7 @@ Form defaultValue: 1 min: 0.001 decimals: 3 - visible: estimationType.currentValue == "automatic" + visible: !type3.checked && estimationType.currentValue == "automatic" } CheckBox From a9d331bb9456c690cd6cb26d0315a99b2131c3ef Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 25 Jun 2025 15:28:22 +0200 Subject: [PATCH 15/65] Informative error for distribution fitting --- R/msaBayesianGaugeRR.R | 11 ++++++++--- inst/qml/msaBayesianGaugeRR.qml | 2 ++ 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 3ad90201..f668fb9b 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -163,7 +163,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .getPercTol(jaspResults, options) } - .fitDistToSamples(jaspResults, options) + distFit <- try(.fitDistToSamples(jaspResults, options), silent = TRUE) } # Variance components table @@ -186,9 +186,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .plotVariancePosteriors(jaspResults, options, parts, operators) # summary table - if(options$posteriorCi || options$posteriorPointEstimate) { + #if(options$posteriorCi || options$posteriorPointEstimate) { .createPostSummaryTable(jaspResults, options, parts, operators) - } + if(inherits(distFit, "try-error")) { + jaspResults[["variancePosteriors"]][["postSummary"]]$setError(gettext( + "The currently selected distribution could not be fit to the samples. Please select another distribution under Advanced options.")) + return() + } + #} } if(ready && options$varianceComponentsGraph) { diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 3a2069be..313031a1 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -296,6 +296,7 @@ Form label: qsTr("Point estimate") name: "posteriorPointEstimate" childrenOnSameRow: true + checked: true DropDown { @@ -311,6 +312,7 @@ Form label: qsTr("CI") id: posteriorCi childrenOnSameRow: true + checked: true DropDown { From 8f96bbe96cc4ffa560fb7d78502dbb45f3d8474f Mon Sep 17 00:00:00 2001 From: jvli4n Date: Thu, 26 Jun 2025 19:55:41 +0200 Subject: [PATCH 16/65] MCMC diagnostics Adding diagnostics table --- R/msaBayesianGaugeRR.R | 99 +++++++++++++++++++++++++++++---- inst/qml/msaBayesianGaugeRR.qml | 34 +++++++++++ 2 files changed, 122 insertions(+), 11 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index f668fb9b..47e9406b 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -180,6 +180,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .plotPrior(jaspResults, options) } + # MCMC diagnostics + if(ready) { + if(options$diagnosticsTable || options$diagnosticsPlots) { + .mcmcDiagnostics(jaspResults, parts, operators, options) + } + } + # posteriors if(ready && options$posteriorPlot){ .fillPostSummaryTable(jaspResults, options, parts, operators) @@ -448,14 +455,23 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { paramNames <- .bfParameterNames(parts, operators, excludeInter, options) chains <- chains[, c(paramNames, "sig2")] # including error variance - samplesMat <- as.matrix(chains) - # multiply variances with the error variance to reverse standardization - for(i in paramNames) { - samplesMat[, i] <- samplesMat[, i] * samplesMat[, "sig2"] - } + # samplesMat <- as.matrix(chains) + + # # multiply variances with the error variance to reverse standardization + # for(i in paramNames) { + # samplesMat[, i] <- samplesMat[, i] * samplesMat[, "sig2"] + # } - MCMCsamples[["object"]] <- samplesMat + chains <- lapply(chains, function(x) { + for (i in paramNames) { + x[, i] <- x[, i] * x[, "sig2"] + } + return(x) + }) + + saveRDS(chains, "/Users/julian/Documents/Jasp files/chains.rds") + MCMCsamples[["object"]] <- coda::mcmc.list(chains) return() } @@ -523,7 +539,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { sigmaOperator <- paste0("g_", operators) sigmaInter <- paste0("g_", parts, ":", operators) - samplesMat <- jaspResults[["MCMCsamples"]][["object"]] + samplesMat <- as.matrix(jaspResults[["MCMCsamples"]][["object"]]) repeatability <- samplesMat[, "sig2"] part <- samplesMat[, sigmaPart] @@ -665,7 +681,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { tempPlot <- createJaspPlot(width = 600, height = 600) tempPlot$position <- 2 - samplesMat <- jaspResults[["MCMCsamples"]][["object"]] + samplesMat <- as.matrix(jaspResults[["MCMCsamples"]][["object"]]) excludeInter <- .evalInter(jaspResults, parts, operators, options) compDf <-.getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) # note: should the historcial sd influence this if entered by the user? @@ -1291,13 +1307,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } samplesMat <- switch(options$posteriorPlotType, - "var" = jaspResults[["MCMCsamples"]][["object"]], + "var" = as.matrix(jaspResults[["MCMCsamples"]][["object"]]), "percContrib" = jaspResults[["percContribSamples"]][["object"]], "percStudyVar" = jaspResults[["percStudySamples"]][["object"]], "percTol" = jaspResults[["percTolSamples"]][["object"]]) - saveRDS(samplesMat, "/Users/julian/Documents/Jasp files/samplesMat.rds") - if(options$posteriorPlotType != "var") { colnames(samplesMat) <- .sourceNames(options) @@ -1910,3 +1924,66 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } + + +### MCMC diagnostics + +## main function +.mcmcDiagnostics <- function(jaspResults, parts, operators, options) { + if(!is.null(jaspResults[["mcmcDiagnostics"]])) { + return() + } + mcmcDiagnostics <- createJaspContainer(title = gettext("MCMC diagnostics")) + mcmcDiagnostics$position <- 5 + mcmcDiagnostics$dependOn(c(.mcmcDependencies(), + "diagnosticsPlots", "diagnosticsPlotType", + "diagnosticsTable")) + jaspResults[["mcmcDiagnostics"]] <- mcmcDiagnostics + + # general input needed for the sub-functions + chains <- jaspResults[["MCMCsamples"]][["object"]] + excludeInter <- .evalInter(jaspResults, parts, operators, options) + + paramNames <- .bfParameterNames(parts, operators, excludeInter, options) + paramNames <- c(paramNames, "sig2") + + + if(options$diagnosticsTable) { + diagnosticsTable <- createJaspTable() + diagnosticsTable$position <- 1 + mcmcDiagnostics[["table"]] <- diagnosticsTable + + diagnosticsTable$addColumnInfo(name = "parameter", title = gettext("Parameter"), type = "string") + diagnosticsTable$addColumnInfo(name = "essBulk", title = gettext("ESS (Bulk)"), type = "number") + diagnosticsTable$addColumnInfo(name = "essTail", title = gettext("ESS (Tail)"), type = "number") + diagnosticsTable$addColumnInfo(name = "rhat", title = gettext("Rhat"), type = "number") + diagnosticsTable$addColumnInfo(name = "mcseMean", title = gettext("MCSE (Mean)"), type = "number") + diagnosticsTable$addColumnInfo(name = "mcseQuantileLower", title = gettext("0.025"), type = "number", overtitle = gettext("MCSE (Quantiles)")) + diagnosticsTable$addColumnInfo(name = "mcseQuantileUpper", title = gettext("0.975"), type = "number", overtitle = gettext("MCSE (Quantiles)")) + + diagnosticsTable$setData(.fillDiagnosticsTable(chains = posterior::as_draws_array(chains), + paramNames = .convertOutputNames(paramNames, parts, operators, includeSigma = TRUE))) + } + return() +} + +# function MCMC diagnostics table +.fillDiagnosticsTable <- function(chains, paramNames) { + # note: posterior::ess_bulk(posteriorChains[,, "sig2"]) # this gives a different result compared to using apply?? + essBulk <- apply(chains, 3, posterior::ess_bulk) + essTail <- apply(chains, 3, posterior::ess_tail) + rhat <- apply(chains, 3, posterior::rhat) + mcseMean <- apply(chains, 3, posterior::mcse_mean) + mcseQuantileLower <- apply(chains, 3, posterior::mcse_quantile, probs = c(0.025, 0.975))[1, ] # 0.025 + mcseQuantileUpper <- apply(chains, 3, posterior::mcse_quantile, probs = c(0.025, 0.975))[2, ] # 0.975 + + return(data.frame(parameter = paramNames, + essBulk, + essTail, + rhat, + mcseMean, + mcseQuantileLower, + mcseQuantileUpper + )) + +} diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 313031a1..cce536aa 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -476,6 +476,40 @@ Form } } } + + Section + { + title: qsTr("MCMC diagnostics") + columns: 1 + + CheckBox + { + label: qsTr("Diagnostics table") + name: "diagnosticsTable" + checked: true + } + + CheckBox + { + label: qsTr("Plots") + name: "diagnosticsPlots" + checked: false + childrenOnSameRow: true + + DropDown + { + name: "diagnosticsPlotType" + values: + [ + { label: qsTr("Traceplot"), value: "trace" }, + { label: qsTr("Autocorrelation"), value: "autocor" }, + { label: qsTr("Density"), value: "density"} + ] + indexDefaultValue: 0 + } + } + + } Section { From a390dbe7befa1822f5ea967ab939ce6d2bf4e69a Mon Sep 17 00:00:00 2001 From: jvli4n Date: Fri, 27 Jun 2025 21:07:21 +0200 Subject: [PATCH 17/65] Plots & tables 1) Adding footnotes to tables 2) Adding diagnostic plots 3) Changing axis limits and breaks for posterior plots as well as how functions are fit to the MCMC samples --- R/msaBayesianGaugeRR.R | 179 ++++++++++++++++++++++++++++---- inst/qml/msaBayesianGaugeRR.qml | 47 +++++---- renv.lock | 18 ++++ 3 files changed, 204 insertions(+), 40 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 47e9406b..b1878d11 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -42,7 +42,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # note this should also be in a function (I could also just make the dropdown include full model, main effects only and automatic) if(options$estimationType == "manual"){ - if(options$fullModel || options$mainEffectsOnly) { + if(options$modelType == "fullModel" || options$modelType == "mainEffectsOnly") { ready <- ready } else { ready <- FALSE @@ -163,7 +163,19 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .getPercTol(jaspResults, options) } - distFit <- try(.fitDistToSamples(jaspResults, options), silent = TRUE) + #distFit <- try(.fitDistToSamples(jaspResults, options), silent = TRUE) + + errorOccurred <- FALSE + + distFit <- tryCatch( + { + .fitDistToSamples(jaspResults, options) + }, + error = function(e) { + errorOccurred <<- TRUE + return(e$message) # or just return(NULL) + } + ) } # Variance components table @@ -195,11 +207,17 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # summary table #if(options$posteriorCi || options$posteriorPointEstimate) { .createPostSummaryTable(jaspResults, options, parts, operators) - if(inherits(distFit, "try-error")) { - jaspResults[["variancePosteriors"]][["postSummary"]]$setError(gettext( - "The currently selected distribution could not be fit to the samples. Please select another distribution under Advanced options.")) + # if(inherits(distFit, "try-error")) { + # jaspResults[["variancePosteriors"]][["postSummary"]]$setError(gettext( + # "The currently selected distribution could not be fit to the samples. Please select another distribution under Advanced options.")) + # return() + # } + + if(errorOccurred) { + jaspResults[["variancePosteriors"]][["postSummary"]]$setError(distFit) return() } + #} } @@ -365,6 +383,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # set data if(ready) { varCompTable$setData(.getVarianceComponents(jaspResults, parts, operators, options)) + varCompTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) if(!options$type3 && .evalInter(jaspResults, parts, operators, options)) { varCompTable$addFootnote("The components are based on the model only including the main effects.") @@ -395,6 +414,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(ready) { contribTable$setData(.percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options)) + contribTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) } else { return() } @@ -521,11 +541,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } if(options$estimationType == "manual"){ - if(options$fullModel){ + if(options$modelType == "fullModel"){ excludeInter <- FALSE } - if(options$mainEffectsOnly){ + if(options$modelType == "mainEffectsOnly"){ excludeInter <- TRUE } } @@ -540,6 +560,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { sigmaInter <- paste0("g_", parts, ":", operators) samplesMat <- as.matrix(jaspResults[["MCMCsamples"]][["object"]]) + saveRDS(samplesMat, "/Users/julian/Documents/Jasp files/samplesMat.rds") repeatability <- samplesMat[, "sig2"] part <- samplesMat[, sigmaPart] @@ -659,6 +680,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { postSummary$setData(jaspResults[["postSummaryStats"]][["object"]]) + postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) return() } @@ -798,14 +820,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference", - "estimationType", "fullModel", "mainEffectsOnly")) + "estimationType", "modelType")) } .mcmcDependencies <- function() { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", "mcmcChains", "mcmcBurnin", "mcmcIterations", - "estimationType", "fullModel", "mainEffectsOnly")) + "estimationType", "modelType")) } .postPlotDependencies <- function() { @@ -1031,6 +1053,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { studyVarData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")[, -1] # remove source name colnames(studyVarData) <- c("meansStudyVar", "lowerStudyVar", "upperStudyVar") stdTable$setData(cbind(stdData, studyVarData)) + + stdTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) } @@ -1080,6 +1104,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { colnames(percTolData) <- c("meansPercTol", "lowerPercTol", "upperPercTol") percStudyVarTable$setData(cbind(percStudyData, percTolData)) } + percStudyVarTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) } @@ -1331,8 +1356,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { set.seed(options$seed) } fit <- switch(distType, - "metalog" = .fitMetaLog(samplesMat, bounds = 0, boundedness = "sl", - term_lower_bound = 5, term_limit = 5), # 5 terms + "metalog" = + if(options$posteriorPlotType == "var" || options$posteriorPlotType == "percTol") { + .fitMetaLog(samplesMat, bounds = 0, boundedness = "sl", + term_lower_bound = 5, term_limit = 5) # 5 terms + } else { + .fitMetaLog(samplesMat, bounds = c(0, 100), boundedness = "b", + term_lower_bound = 5, term_limit = 5) # 5 terms + }, "gig" = .fitGIG(samplesMat)) distFit[["object"]] <- fit @@ -1548,13 +1579,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { fits <- jaspResults[["distFit"]][["object"]] if(options$posteriorPlotType == "var") { - titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) # note: this function needs to be modified so it produces the right lables for the percentages as well + titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) } else { titles <- names(fits) } - postSummary <- jaspResults[["postSummaryStats"]][["object"]] # note: this needs to be replaced if I plot dists for the percentages - - + postSummary <- jaspResults[["postSummaryStats"]][["object"]] for(i in seq_along(titles)) { tempPlot <- createJaspPlot(title = gettext(titles[i]), width = 600, height = 320) @@ -1647,18 +1676,25 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { m <- .modeMetaLog(fit) if(options$posteriorCi) { - xUpper <- ceiling(max(dfTemp[dfTemp$probs >= 0.975, ]$x_new[1], postSummary[iter, "ciUpper"])) + xUpper <- max(dfTemp[dfTemp$probs >= 0.99, ]$x_new[1], postSummary[iter, "ciUpper"]) } else { - xUpper <- ceiling(dfTemp[dfTemp$probs >= 0.975, ]$x_new[1]) + xUpper <- dfTemp[dfTemp$probs >= 0.99, ]$x_new[1] + } + + if(options$posteriorPlotType != "var" && options$posteriorPlotType != "percTol") { + xUpper <- 100 } + xLower <- 0 xLims <- c(xLower, xUpper) xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) + xLims <- c(xBreaks[1], xBreaks[length(xBreaks)]) yUpper <- rmetalog::dmetalog(m = fit, q = m, term = fit$params$term_limit) yLower <- 0 yLims <- c(yLower, yUpper) yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) + yLims <- c(yBreaks[1], yBreaks[length(yBreaks)]) l <- list( x = list(limits = xLims, @@ -1672,22 +1708,29 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # Generalized inverse Gaussian .axisLimsGIG <- function(fit, postSummary, options, iter) { - quant <- quantile(fit$randData, 0.975) # for upper xLim + quant <- quantile(fit$randData, 0.99) # for upper xLim m <- .modeGIG(fit) if(options$posteriorCi) { - xUpper <- ceiling(max(quant, postSummary[iter, "ciUpper"])) + xUpper <- max(quant, postSummary[iter, "ciUpper"]) } else { - xUpper <- ceiling(quant) + xUpper <- quant + } + + if(options$posteriorPlotType != "var" && options$posteriorPlotType != "percTol") { + xUpper <- 100 } + xLower <- 0 xLims <- c(xLower, xUpper) xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) + xLims <- c(xBreaks[1], xBreaks[length(xBreaks)]) yUpper <- GeneralizedHyperbolic::dgig(x = m, param = fit$param) yLower <- 0 yLims <- c(yLower, yUpper) yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) + yLims <- c(yBreaks[1], yBreaks[length(yBreaks)]) l <- list( x = list(limits = xLims, @@ -1964,6 +2007,18 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { diagnosticsTable$setData(.fillDiagnosticsTable(chains = posterior::as_draws_array(chains), paramNames = .convertOutputNames(paramNames, parts, operators, includeSigma = TRUE))) } + + if(options$diagnosticsPlots) { + switch(options$diagnosticsPlotType, + "trace" = .tracePlot(jaspResults, chains = posterior::as_draws_array(chains), paramNames, + xLabs = .convertOutputNames(paramNames, parts, operators, includeSigma = FALSE)), + "autocor" = .autocorPlot(jaspResults, chains = posterior::as_draws_array(chains), paramNames, + titles = .convertOutputNames(paramNames, parts, operators, includeSigma = FALSE)), + "density" = .densityDiagnosticsPlot(jaspResults, chains = posterior::as_draws_array(chains), paramNames, + xLabs = .convertOutputNames(paramNames, parts, operators, includeSigma = FALSE))) + + } + return() } @@ -1985,5 +2040,89 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { mcseQuantileLower, mcseQuantileUpper )) +} + +.tracePlot <- function(jaspResults, chains, paramNames, xLabs) { + colors <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), dim(chains)[2]) + + for(i in seq_along(paramNames)) { + tempPlot <- createJaspPlot(width = 600, height = 320) + + p <- bayesplot::mcmc_trace(chains, pars = paramNames[i]) + + ggplot2::scale_color_manual(values = colors) + + jaspGraphs::themeJaspRaw() + + jaspGraphs::geom_rangeframe() + + ggplot2::ylab(bquote(sigma[.(xLabs[i])]^2)) + + tempPlot$plotObject <- p + jaspResults[["mcmcDiagnostics"]][[paramNames[i]]] <- tempPlot + } + return() +} + +.autocorPlot <- function(jaspResults, chains, paramNames, titles) { + + for(i in seq_along(paramNames)) { + tempPlot <- createJaspPlot(width = 500, height = 500) + + p <- bayesplot::mcmc_acf(chains, pars = paramNames[i]) + + jaspGraphs::themeJaspRaw() + + jaspGraphs::geom_rangeframe() + + ggplot2::theme(strip.text = ggplot2::element_blank(), + title = ggplot2::element_text(size = 15)) + + ggplot2::labs(title = bquote(sigma[.(titles[i])]^2)) + + tempPlot$plotObject <- p + jaspResults[["mcmcDiagnostics"]][[paramNames[i]]] <- tempPlot + } + return() +} + +.densityDiagnosticsPlot <- function(jaspResults, chains, paramNames, xLabs) { + colors <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), dim(chains)[2]) + for(i in seq_along(paramNames)) { + tempPlot <- createJaspPlot(width = 600, height = 320) + + # density for axis limits + d <- apply(chains[, , paramNames[i]], 2, function(x) { + df <- data.frame(x = density(x)$x, + y = density(x)$y) + return(df) + }) + d <- do.call(rbind.data.frame, d) + xLims <- c(0, d$x[d$y < 1e-3 & d$x > 3][1]) # note: there should be a better way to handle the part with x > 3 + + manualScaleX <- FALSE + if(!any(is.na(xLims))) { + manualScaleX <- TRUE + axisBreaksX <- jaspGraphs::getPrettyAxisBreaks(xLims) + xLims <- c(axisBreaksX[1], axisBreaksX[length(axisBreaksX)]) # note: this ensures that the axis does not stop abruptly + } + + # note: the y lims do not work well for the operator plot + # yLims <- c(0, max(d$y)) + # axisBreaksY <- jaspGraphs::getPrettyAxisBreaks(yLims) + # yLims <- c(axisBreaksY[1], axisBreaksY[length(axisBreaksY)]) # note: this ensures that the axis does not stop abruptly + + p <- bayesplot::mcmc_dens_overlay(chains, pars = paramNames[i]) + + ggplot2::scale_color_manual(values = colors) + + ggplot2::xlab(bquote(sigma[.(xLabs[i])]^2)) + + ggplot2::xlim(xLims) + + if(manualScaleX) { + p <- p + ggplot2::scale_x_continuous(limits = xLims, + breaks = axisBreaksX) + } + + p <- p + jaspGraphs::themeJaspRaw() + + jaspGraphs::geom_rangeframe() + + # ggplot2::scale_y_continuous("Density", limits = yLims, breaks = axisBreaksY) + + ggplot2::scale_y_continuous("Density") + + ggplot2::theme(axis.ticks.y = ggplot2::element_line()) + + tempPlot$plotObject <- p + jaspResults[["mcmcDiagnostics"]][[paramNames[i]]] <- tempPlot + } + return() } diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index cce536aa..d321f083 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -154,26 +154,31 @@ Form decimals: 3 visible: !type3.checked && estimationType.currentValue == "automatic" } - - CheckBox + + RadioButtonGroup { - name: "fullModel" - label: qsTr("Full model") - id: fullModel - checked: false - enabled: !mainEffectsOnly.checked - visible: estimationType.currentValue == "manual" - } + name: "modelType" + visible: !type3.checked - CheckBox - { - name: "mainEffectsOnly" - label: qsTr("Main effects only") - id: mainEffectsOnly - enabled: !fullModel.checked - checked: false - visible: estimationType.currentValue == "manual" - } + RadioButton + { + name: "fullModel" + label: qsTr("Full model") + id: fullModel + checked: true + visible: estimationType.currentValue == "manual" + } + + RadioButton + { + name: "mainEffectsOnly" + label: qsTr("Main effects only") + id: mainEffectsOnly + checked: false + visible: estimationType.currentValue == "manual" + } + } + DropDown @@ -279,6 +284,7 @@ Form { name: "posteriorPlotType" label: "" + id: posteriorPlotType values: tolerance.checked ? [ { label: qsTr("Variances"), value: "var" }, { label: qsTr("%Contribution"), value: "percContrib"}, @@ -581,10 +587,11 @@ Form { name: "distType" label: qsTr("Distribution") - values: - [ + values: posteriorPlotType.currentValue == "var" ? [ { label: qsTr("Generalized inverse Gaussian"), value: "gig" }, { label: qsTr("Metalog"), value: "metalog" } + ] : [ + { label: qsTr("Metalog"), value: "metalog" } ] indexDefaultValue: 0 } diff --git a/renv.lock b/renv.lock index 389b8d2b..37e8187b 100644 --- a/renv.lock +++ b/renv.lock @@ -287,6 +287,12 @@ "R" ] }, + "bayesplot": { + "Package": "bayesplot", + "Version": "1.13.0", + "Source": "Repository", + "Repository": "CRAN" + }, "boot": { "Package": "boot", "Version": "1.3-31", @@ -1614,6 +1620,12 @@ "graphics" ] }, + "posterior": { + "Package": "posterior", + "Version": "1.6.1", + "Source": "Repository", + "Repository": "CRAN" + }, "processx": { "Package": "processx", "Version": "3.8.6", @@ -1766,6 +1778,12 @@ "estimability" ] }, + "rstan": { + "Package": "rstan", + "Version": "2.32.7", + "Source": "Repository", + "Repository": "CRAN" + }, "rvg": { "Package": "rvg", "Version": "0.3.5", From 1a671a02bb83bb76377d7c1223074105bef1e21c Mon Sep 17 00:00:00 2001 From: jvli4n Date: Sat, 28 Jun 2025 11:14:43 +0200 Subject: [PATCH 18/65] Data structures MCMC - New data structures for storing MCMC samples since the old ones seemed to lead to errors in JASP --- R/msaBayesianGaugeRR.R | 96 ++++++++++++++++++++++++++++++------------ 1 file changed, 70 insertions(+), 26 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index b1878d11..1fd215ae 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -455,7 +455,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { burnin <- options$mcmcBurnin iter <- options$mcmcIterations - chains <- coda::mcmc.list() + + # get relevant parameters + paramNames <- .bfParameterNames(parts, operators, excludeInter, options) + paramNames <- c(paramNames, "sig2") + + # initiate array + mcmcArray <- array(dim = c(iter - burnin, nchains, length(paramNames))) if(options$setSeed) { set.seed(options$seed) @@ -465,34 +471,63 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # run chain mcmcChain <- BayesFactor::posterior(fit, iterations = iter) - # exclude burn-in samples - chains[[i]] <- coda::as.mcmc(mcmcChain[-(1:burnin), ]) - } + # select subset + mcmcChain <- as.matrix(mcmcChain) + mcmcChain <- mcmcChain[, paramNames] + # discard burnin + mcmcChain <- mcmcChain[-(1:burnin), ] - # select relevant parameters - # names - paramNames <- .bfParameterNames(parts, operators, excludeInter, options) + # revert standardization + for(j in paramNames[paramNames != "sig2"]) { + mcmcChain[, j] <- mcmcChain[, j] * mcmcChain[, "sig2"] + } - chains <- chains[, c(paramNames, "sig2")] # including error variance + mcmcArray[, i, ] <- mcmcChain + } - # samplesMat <- as.matrix(chains) + dimnames(mcmcArray) <- list(NULL, NULL, paramNames) + MCMCsamples[["object"]] <- mcmcArray - # # multiply variances with the error variance to reverse standardization - # for(i in paramNames) { - # samplesMat[, i] <- samplesMat[, i] * samplesMat[, "sig2"] + ##### old code + # chains <- coda::mcmc.list() + # + # if(options$setSeed) { + # set.seed(options$seed) # } - - chains <- lapply(chains, function(x) { - for (i in paramNames) { - x[, i] <- x[, i] * x[, "sig2"] - } - return(x) - }) - - saveRDS(chains, "/Users/julian/Documents/Jasp files/chains.rds") - MCMCsamples[["object"]] <- coda::mcmc.list(chains) - + # + # for(i in 1:nchains) { + # # run chain + # mcmcChain <- BayesFactor::posterior(fit, iterations = iter) + # + # # exclude burn-in samples + # chains[[i]] <- coda::as.mcmc(mcmcChain[-(1:burnin), ]) + # } + # + # + # # select relevant parameters + # # names + # paramNames <- .bfParameterNames(parts, operators, excludeInter, options) + # + # chains <- chains[, c(paramNames, "sig2")] # including error variance + # + # # samplesMat <- as.matrix(chains) + # + # # # multiply variances with the error variance to reverse standardization + # # for(i in paramNames) { + # # samplesMat[, i] <- samplesMat[, i] * samplesMat[, "sig2"] + # # } + # + # chains <- lapply(chains, function(x) { + # for (i in paramNames) { + # x[, i] <- x[, i] * x[, "sig2"] + # } + # return(x) + # }) + # + # saveRDS(chains, "/Users/julian/Documents/Jasp files/chains.rds") + # MCMCsamples[["object"]] <- coda::mcmc.list(chains) + ##### return() } @@ -559,7 +594,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { sigmaOperator <- paste0("g_", operators) sigmaInter <- paste0("g_", parts, ":", operators) - samplesMat <- as.matrix(jaspResults[["MCMCsamples"]][["object"]]) + samplesMat <- .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]) + samplesMat <- as.matrix(samplesMat) saveRDS(samplesMat, "/Users/julian/Documents/Jasp files/samplesMat.rds") repeatability <- samplesMat[, "sig2"] @@ -703,7 +739,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { tempPlot <- createJaspPlot(width = 600, height = 600) tempPlot$position <- 2 - samplesMat <- as.matrix(jaspResults[["MCMCsamples"]][["object"]]) + samplesMat <- .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]) excludeInter <- .evalInter(jaspResults, parts, operators, options) compDf <-.getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) # note: should the historcial sd influence this if entered by the user? @@ -1332,7 +1368,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } samplesMat <- switch(options$posteriorPlotType, - "var" = as.matrix(jaspResults[["MCMCsamples"]][["object"]]), + "var" = .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]), "percContrib" = jaspResults[["percContribSamples"]][["object"]], "percStudyVar" = jaspResults[["percStudySamples"]][["object"]], "percTol" = jaspResults[["percTolSamples"]][["object"]]) @@ -2042,6 +2078,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { )) } +# plotting functions for diagnostics .tracePlot <- function(jaspResults, chains, paramNames, xLabs) { colors <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), dim(chains)[2]) @@ -2126,3 +2163,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } return() } + + +.arrayToMat <- function(array) { + mat <- matrix(array, nrow = prod(dim(array)[1:2]), ncol = dim(array)[3]) + colnames(mat) <- dimnames(array)[[3]] + return(mat) +} From 620acbc71bfd028dbce1f8acda78bc6dcd20c47d Mon Sep 17 00:00:00 2001 From: jvli4n Date: Sat, 28 Jun 2025 12:21:06 +0200 Subject: [PATCH 19/65] Diagnostic plots 1) Fixing trace plot y limits 2) Manual plot for autocorrelations with multiple chains in one plot --- R/msaBayesianGaugeRR.R | 31 ++++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 1fd215ae..c42b1c6c 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -2048,7 +2048,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { switch(options$diagnosticsPlotType, "trace" = .tracePlot(jaspResults, chains = posterior::as_draws_array(chains), paramNames, xLabs = .convertOutputNames(paramNames, parts, operators, includeSigma = FALSE)), - "autocor" = .autocorPlot(jaspResults, chains = posterior::as_draws_array(chains), paramNames, + "autocor" = .autocorPlot(jaspResults, chains = chains, paramNames, titles = .convertOutputNames(paramNames, parts, operators, includeSigma = FALSE)), "density" = .densityDiagnosticsPlot(jaspResults, chains = posterior::as_draws_array(chains), paramNames, xLabs = .convertOutputNames(paramNames, parts, operators, includeSigma = FALSE))) @@ -2085,11 +2085,18 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { for(i in seq_along(paramNames)) { tempPlot <- createJaspPlot(width = 600, height = 320) + # obtain y lims + dat <- chains[, , paramNames[i]] + yBreaks <- jaspGraphs::getPrettyAxisBreaks(c(min(dat), max(dat))) + yLims <- c(yBreaks[1], yBreaks[length(yBreaks)]) + p <- bayesplot::mcmc_trace(chains, pars = paramNames[i]) + ggplot2::scale_color_manual(values = colors) + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe() + - ggplot2::ylab(bquote(sigma[.(xLabs[i])]^2)) + ggplot2::scale_y_continuous(bquote(sigma[.(xLabs[i])]^2), + breaks = yBreaks, + limits = yLims) tempPlot$plotObject <- p jaspResults[["mcmcDiagnostics"]][[paramNames[i]]] <- tempPlot @@ -2098,15 +2105,25 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } .autocorPlot <- function(jaspResults, chains, paramNames, titles) { + colors <- rep_len(rstan:::rstanvis_aes_ops("chain_colors"), dim(chains)[2]) for(i in seq_along(paramNames)) { - tempPlot <- createJaspPlot(width = 500, height = 500) - - p <- bayesplot::mcmc_acf(chains, pars = paramNames[i]) + + tempPlot <- createJaspPlot(width = 500, height = 320) + + # obtain data for plotting + dat <- chains[, , paramNames[i]] + l <- apply(dat, 2, acf, lag.max = 20, plot = FALSE) + l <- lapply(l, function(x) list(acf = x$acf, lag = x$lag)) + df <- do.call(rbind.data.frame, l) + df$chain <- factor(rep(1:dim(dat)[2], each = length(l[[1]]$lag))) + + p <- ggplot2::ggplot(df, ggplot2::aes(x = lag, y = acf, color = chain)) + + ggplot2::geom_line() + + ggplot2::geom_hline(yintercept = 0, alpha = 0.5) + + ggplot2::scale_color_manual(values = colors) + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe() + - ggplot2::theme(strip.text = ggplot2::element_blank(), - title = ggplot2::element_text(size = 15)) + + ggplot2::labs(x = "Lag", y = "Autocorrelation") + ggplot2::labs(title = bquote(sigma[.(titles[i])]^2)) tempPlot$plotObject <- p From c6ece3966b7088b79c7da4b70045fbb62fb2eb98 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Sat, 28 Jun 2025 13:33:52 +0200 Subject: [PATCH 20/65] Histogram MCMC samples - Adding histogram outlines for MCMC samples - Adjusting y-limit functions accordingly - Moving footnote for posterior summary table so it is only displayed if CrI is enabled --- R/msaBayesianGaugeRR.R | 35 ++++++++++++++++++++++++--------- inst/qml/msaBayesianGaugeRR.qml | 8 +++++++- 2 files changed, 33 insertions(+), 10 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index c42b1c6c..9ece18fe 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -712,11 +712,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(options$posteriorCi) { postSummary$addColumnInfo(name = "ciLower", title = gettext("Lower"), type = "number", overtitle = gettext(overtitle)) postSummary$addColumnInfo(name = "ciUpper", title = gettext("Upper"), type = "number", overtitle = gettext(overtitle)) + postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) } postSummary$setData(jaspResults[["postSummaryStats"]][["object"]]) - postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) return() } @@ -869,7 +869,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .postPlotDependencies <- function() { return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", - "distType", "posteriorPlotType", "tolerance", "toleranceValue")) + "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram")) } # .optimalMetaLog <- function(fit, parameter, samplesMat) { @@ -1613,6 +1613,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["variancePosteriors"]] <- variancePosteriors fits <- jaspResults[["distFit"]][["object"]] + samplesMat <- switch(options$posteriorPlotType, + "var" = .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]), + "percContrib" = jaspResults[["percContribSamples"]][["object"]], + "percStudyVar" = jaspResults[["percStudySamples"]][["object"]], + "percTol" = jaspResults[["percTolSamples"]][["object"]]) if(options$posteriorPlotType == "var") { titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) @@ -1624,12 +1629,22 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { for(i in seq_along(titles)) { tempPlot <- createJaspPlot(title = gettext(titles[i]), width = 600, height = 320) + p <- ggplot2::ggplot() + + # add histogram outlines + if(options$posteriorHistogram) { + p <- p + ggplot2::geom_step(data = data.frame(x = samplesMat[, i]), + ggplot2::aes(x = x, y = ggplot2::after_stat(density)), + stat = "bin", direction = "mid", linewidth = 1) + pBuild <- ggplot2::ggplot_build(p) + maxHistDens <- max(pBuild$data[[1]][, "density"]) + } + # select function for axis limits based on distribution axisFun <- .axisLimFuns()[[options$distType]] - lims <- axisFun(fits[[i]], postSummary, options, iter = i) - - p <- ggplot2::ggplot() + lims <- axisFun(fits[[i]], postSummary, options, iter = i, + histDens = ifelse(options$posteriorHistogram, maxHistDens, 0)) # credible interval if(options$posteriorCi) { @@ -1706,7 +1721,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # Metalog -.axisLimsMetaLog <- function(fit, postSummary, options, iter) { +.axisLimsMetaLog <- function(fit, postSummary, options, iter, histDens = 0) { dfTemp <- fit$dataValues m <- .modeMetaLog(fit) @@ -1726,7 +1741,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) xLims <- c(xBreaks[1], xBreaks[length(xBreaks)]) - yUpper <- rmetalog::dmetalog(m = fit, q = m, term = fit$params$term_limit) + yUpper <- max(rmetalog::dmetalog(m = fit, q = m, term = fit$params$term_limit), + histDens) yLower <- 0 yLims <- c(yLower, yUpper) yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) @@ -1742,7 +1758,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # Generalized inverse Gaussian -.axisLimsGIG <- function(fit, postSummary, options, iter) { +.axisLimsGIG <- function(fit, postSummary, options, iter, histDens = 0) { quant <- quantile(fit$randData, 0.99) # for upper xLim m <- .modeGIG(fit) @@ -1762,7 +1778,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) xLims <- c(xBreaks[1], xBreaks[length(xBreaks)]) - yUpper <- GeneralizedHyperbolic::dgig(x = m, param = fit$param) + yUpper <- max(GeneralizedHyperbolic::dgig(x = m, param = fit$param), + histDens) yLower <- 0 yLims <- c(yLower, yUpper) yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index d321f083..d6be6753 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -297,6 +297,12 @@ Form ] } + CheckBox + { + label: qsTr("Display histogram") + name: "posteriorHistogram" + } + CheckBox { label: qsTr("Point estimate") @@ -318,7 +324,7 @@ Form label: qsTr("CI") id: posteriorCi childrenOnSameRow: true - checked: true + checked: false DropDown { From 9d0bd1845c49155f88d21ac46c8f7191e92ee96a Mon Sep 17 00:00:00 2001 From: jvli4n Date: Sat, 28 Jun 2025 17:55:07 +0200 Subject: [PATCH 21/65] Report - Adding report with metadata and plots --- R/msaBayesianGaugeRR.R | 311 ++++++++++++++++++++++++++++++----------- 1 file changed, 230 insertions(+), 81 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 9ece18fe..a1af23fc 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -136,7 +136,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # Model comparison table - if(options[["RRTable"]]){ + if(options[["RRTable"]] && !options$report){ # I should probably add && !report here .createBFtable(jaspResults, dataset, options, measurements, parts, operators, ready) } @@ -178,34 +178,39 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ) } - # Variance components table - .createVarCompTable(jaspResults, parts, operators, ready, options) + # insert report here + if(options$report) { + .createGaugeReport(jaspResults, dataset, measurements, parts, operators, options, ready) + } else { - # % Contribution to total variation table - .createPercContribTable(jaspResults, options, parts, operators, ready) + # Variance components table + .createVarCompTable(jaspResults, parts, operators, ready, options) - # Gauge evaluation table - .createGaugeEval(jaspResults, parts, operators, options, ready) + # % Contribution to total variation table + .createPercContribTable(jaspResults, options, parts, operators, ready) - # prior - if(ready && options$priorPlot) { - .plotPrior(jaspResults, options) - } + # Gauge evaluation table + .createGaugeEval(jaspResults, parts, operators, options, ready) - # MCMC diagnostics - if(ready) { - if(options$diagnosticsTable || options$diagnosticsPlots) { - .mcmcDiagnostics(jaspResults, parts, operators, options) + # prior + if(ready && options$priorPlot) { + .plotPrior(jaspResults, options) + } + + # MCMC diagnostics + if(ready) { + if(options$diagnosticsTable || options$diagnosticsPlots) { + .mcmcDiagnostics(jaspResults, parts, operators, options) + } } - } - # posteriors - if(ready && options$posteriorPlot){ - .fillPostSummaryTable(jaspResults, options, parts, operators) - .plotVariancePosteriors(jaspResults, options, parts, operators) + # posteriors + if(ready && options$posteriorPlot){ + .fillPostSummaryTable(jaspResults, options, parts, operators) + .plotVariancePosteriors(jaspResults, options, parts, operators) - # summary table - #if(options$posteriorCi || options$posteriorPointEstimate) { + # summary table + #if(options$posteriorCi || options$posteriorPointEstimate) { .createPostSummaryTable(jaspResults, options, parts, operators) # if(inherits(distFit, "try-error")) { # jaspResults[["variancePosteriors"]][["postSummary"]]$setError(gettext( @@ -218,48 +223,49 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } - #} - } + #} + } - if(ready && options$varianceComponentsGraph) { - .createVarCompPlot(jaspResults, options) - } + if(ready && options$varianceComponentsGraph) { + .createVarCompPlot(jaspResults, options) + } - # contour plot - if(ready && options$contourPlot) { - .createContourPlot(jaspResults, parts, operators, measurements, dataset, options) - } + # contour plot + if(ready && options$contourPlot) { + .createContourPlot(jaspResults, parts, operators, measurements, dataset, options) + } - # range chart - if(options$rChart) { - .createRChart(jaspResults, dataset, measurements, operators, parts, options, ready) - } + # range chart + if(options$rChart) { + .createRChart(jaspResults, dataset, measurements, operators, parts, options, ready) + } - # average chart - if(options$xBarChart) { - .createXbarChart(jaspResults, dataset, measurements, operators, parts, options, ready) - } + # average chart + if(options$xBarChart) { + .createXbarChart(jaspResults, dataset, measurements, operators, parts, options, ready) + } - # scatter plot - if(options$scatterPlot){ - .createScatterPlotOperators(jaspResults, dataset, measurements, operators, parts, options, ready) - } + # scatter plot + if(options$scatterPlot){ + .createScatterPlotOperators(jaspResults, dataset, measurements, operators, parts, options, ready) + } - # measurement by part plot - if(ready && options$partMeasurementPlot) { - .createMeasureByPartPlot(jaspResults, dataset, measurements, operators, parts, options) - } + # measurement by part plot + if(ready && options$partMeasurementPlot) { + .createMeasureByPartPlot(jaspResults, dataset, measurements, operators, parts, options) + } - if(ready && options$operatorMeasurementPlot) { - .createMeasureByOperatorPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) - } + if(ready && options$operatorMeasurementPlot) { + .createMeasureByOperatorPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) + } - if(ready && options$partByOperatorMeasurementPlot) { - .createPartByOperatorInterPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) - } + if(ready && options$partByOperatorMeasurementPlot) { + .createPartByOperatorInterPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) + } - if(ready && options$trafficLightChart) { - .createTrafficLightPlot(jaspResults, options) + if(ready && options$trafficLightChart) { + .createTrafficLightPlot(jaspResults, options) + } } } @@ -1923,17 +1929,18 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(dataset) } -.createVarCompPlot <- function(jaspResults, options) { - if(!is.null(jaspResults[["varCompPlot"]])) { - return() +.createVarCompPlot <- function(jaspResults, options, plotOnly = FALSE) { + if(!plotOnly) { + if(!is.null(jaspResults[["varCompPlot"]])) { + return() + } + varCompPlot <- createJaspPlot(title = gettext("Components of variation"), width = 850, height = 500) + varCompPlot$position <- 6 + varCompPlot$dependOn(c(.varCompTableDependencies(), "varianceComponentsGraph", + "tolerance", "toleranceValue", + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["varCompPlot"]] <- varCompPlot } - varCompPlot <- createJaspPlot(title = gettext("Components of variation"), width = 850, height = 500) - varCompPlot$position <- 6 - varCompPlot$dependOn(c(.varCompTableDependencies(), "varianceComponentsGraph", - "tolerance", "toleranceValue", - "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) - jaspResults[["varCompPlot"]] <- varCompPlot - # obtain summaries percContrib <- .percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options) percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) @@ -1970,26 +1977,31 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { errorbarDf = errorbarDf, Type3 = options$type3) } - varCompPlot$plotObject <- p + if(plotOnly) { + return(p) + } else { + varCompPlot$plotObject <- p + } return() } -.createTrafficLightPlot <- function(jaspResults, options) { - if(!is.null(jaspResults[["trafficPlot"]])) { - return() - } - - trafficPlot <- createJaspContainer(title = gettext("Traffic light chart")) - trafficPlot$position <- 12 - trafficPlot$dependOn(c(.varCompTableDependencies(), "trafficLightChart", - "tolerance", "toleranceValue", - "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) - jaspResults[["trafficPlot"]] <- trafficPlot +.createTrafficLightPlot <- function(jaspResults, options, plotOnly = FALSE) { + if(!plotOnly) { + if(!is.null(jaspResults[["trafficPlot"]])) { + return() + } + trafficPlot <- createJaspContainer(title = gettext("Traffic light chart")) + trafficPlot$position <- 12 + trafficPlot$dependOn(c(.varCompTableDependencies(), "trafficLightChart", + "tolerance", "toleranceValue", + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["trafficPlot"]] <- trafficPlot + } # % Study var - trafficPlotStudy <- createJaspPlot(width = 1000) - trafficPlotStudy$position <- 1 + # trafficPlotStudy <- createJaspPlot(width = 1000) + # trafficPlotStudy$position <- 1 percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) percStudyVar <- percStudyVar[percStudyVar$sourceName == "Total gauge r&R", ] percStudyVarMean <- percStudyVar$means @@ -2014,10 +2026,15 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ToleranceVar = percTolMean, options = options, ready = TRUE, StudyVarCi = percStudyVarCrI, - TolCi = percTolCrI) + TolCi = percTolCrI, + ggPlot = plotOnly) } - trafficPlot[["trafficPlot"]] <- p + if(plotOnly) { + return(p) + } else { + trafficPlot[["trafficPlot"]] <- p + } return() } @@ -2204,3 +2221,135 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { colnames(mat) <- dimnames(array)[[3]] return(mat) } + + +### Report + +.reportDependencies <- function() { + return(c("report", "reportMetaData", "reportTitle", + "reportTitleText", "reportPartName", "reportPartNameText", "reportGaugeName", + "reportGaugeNameText", "reportCharacteristic", "reportCharacteristicText", + "reportGaugeNumber", "reportGaugeNumberText", "reportTolerance", "reportToleranceText", + "reportLocation", "reportLocationText", "reportPerformedBy", "reportPerformedByText", + "reportDate", "reportDateText", "reportVariationComponents", "reportMeasurementsByPartPlot", + "reportRChartByOperator", "reportMeasurementsByOperatorPlot", "reportAverageChartByOperator", + "reportPartByOperatorPlot", "reportTrafficLightChart", "reportMetaData")) +} + +.getReportTitle <- function(options) { + if (options[["reportTitle"]] ) { + title <- if (options[["reportTitleText"]] == "") gettext("Gauge r&R report") else options[["reportTitleText"]] + } else { + title <- "" + } + return(title) +} + +.getReportMetaData <- function(options) { + if (options[["reportMetaData"]]) { + text <- c() + text <- if (options[["reportPartName"]]) c(text, gettextf("Part name: %s", options[["reportPartNameText"]])) else text + text <- if (options[["reportGaugeName"]]) c(text, gettextf("Gauge name: %s", options[["reportGaugeNameText"]])) else text + text <- if (options[["reportCharacteristic"]]) c(text, gettextf("Characteristic: %s", options[["reportCharacteristicText"]])) else text + text <- if (options[["reportGaugeNumber"]]) c(text, gettextf("Gauge number: %s", options[["reportGaugeNumberText"]])) else text + text <- if (options[["reportTolerance"]]) c(text, gettextf("Tolerance: %s", options[["reportToleranceText"]])) else text + text <- if (options[["reportLocation"]]) c(text, gettextf("Location: %s", options[["reportLocationText"]])) else text + text <- if (options[["reportPerformedBy"]]) c(text, gettextf("Performed by: %s", options[["reportPerformedByText"]])) else text + text <- if (options[["reportDate"]]) c(text, gettextf("Date: %s", options[["reportDateText"]])) else text + } else { + text <- NULL + } + + return(text) +} + +.getReportPlots <- function(jaspResults, dataset, measurements, parts, operators, options) { + # note: I could convert the data in the main analysis function and then just pass it to the functions + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + + + plots <- list() + plotIndexCounter <- 1 + if (options[["reportVariationComponents"]]) { + plots[[plotIndexCounter]] <- .createVarCompPlot(jaspResults, options, plotOnly = TRUE) + plotIndexCounter <- plotIndexCounter + 1 + } + if (options[["reportMeasurementsByPartPlot"]]) { + plots[[plotIndexCounter]] <- .gaugeByPartGraphPlotObject(dataset, measurements, parts, operators, displayAll = FALSE) #measurement by part plot + plotIndexCounter <- plotIndexCounter + 1 + } + if (options[["reportRChartByOperator"]]) { + plots[[plotIndexCounter]] <- .controlChart(dataset = dataset[c(measurements, operators)], + plotType = "R", stages = operators, + xAxisLabels = dataset[[parts]][order(dataset[[operators]])], + stagesSeparateCalculation = FALSE)$plotObject + plotIndexCounter <- plotIndexCounter + 1 + } + if (options[["reportMeasurementsByOperatorPlot"]]) { + plots[[plotIndexCounter]] <- .gaugeByOperatorGraphPlotObject(dataset, measurements, parts, operators, options, Type3 = options$type3) #Measurements by operator plot + plotIndexCounter <- plotIndexCounter + 1 + } + if (options[["reportAverageChartByOperator"]]) { + plots[[plotIndexCounter]] <- .controlChart(dataset = dataset[c(measurements, operators)], + plotType = "xBar", xBarSdType = "r", stages = operators, + xAxisLabels = dataset[[parts]][order(dataset[[operators]])], + stagesSeparateCalculation = FALSE)$plotObject + plotIndexCounter <- plotIndexCounter + 1 + } + if (options[["reportPartByOperatorPlot"]]) { + plots[[plotIndexCounter]] <- .gaugeByInteractionGraphPlotFunction(dataset, measurements, parts, operators, options, + Type3 = options$type3, ggPlot = TRUE) # Part x Operator interaction plot + plotIndexCounter <- plotIndexCounter + 1 + } + + if (options[["reportTrafficLightChart"]]) { + trafficPlots <- .createTrafficLightPlot(jaspResults, options, plotOnly = TRUE) + if (options[["tolerance"]]) { + plots[[plotIndexCounter]] <- trafficPlots$p1 + plotIndexCounter <- plotIndexCounter + 1 + plots[[plotIndexCounter]] <- trafficPlots$p2 + } else { + plots[[plotIndexCounter]] <- trafficPlots$plotObject + } + } + + return(plots) +} + +.createGaugeReport <- function(jaspResults, dataset, measurements, parts, operators, options, ready) { + nElements <- sum(options[["reportVariationComponents"]], options[["reportMeasurementsByPartPlot"]], options[["reportRChartByOperator"]], + options[["reportMeasurementsByOperatorPlot"]], options[["reportAverageChartByOperator"]], + options[["reportPartByOperatorPlot"]], options[["reportTrafficLightChart"]], options[["reportMetaData"]]) + plotHeight <- ceiling(nElements/2) * 500 + reportPlot <- createJaspPlot(title = gettext("Gauge r&R report"), width = 1250, height = plotHeight) + jaspResults[["report"]] <- reportPlot + jaspResults[["report"]]$dependOn(c("type3", "tolerance", "toleranceValue", "studyVarianceMultiplierType", + "studyVarianceMultiplierValue", "scatterPlotFitLine", "scatterPlotOriginLine", + "partMeasurementPlotAllValues", .varCompTableDependencies(), .reportDependencies())) + + if (nElements == 0) { + reportPlot$setError(gettext("No report components selected.")) + return() + } + + if(!ready) { + return() + } + + # title + title <- .getReportTitle(options) + + # meta data + text <- .getReportMetaData(options) + + # plots + plots <- .getReportPlots(jaspResults, dataset, measurements, parts, operators, options) + + reportPlotObject <- .qcReport(text = text, plots = plots, tables = NULL, textMaxRows = 8, + tableTitles = "", reportTitle = title, tableSize = 6) + reportPlot$plotObject <- reportPlotObject + + return() + +} From e30451eccdbe7b07f3558456366268a26feb21c4 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Sun, 29 Jun 2025 15:42:56 +0200 Subject: [PATCH 22/65] Adding tables to report - Code for adding tables to gauge r&R report - Update dependencies --- R/msaBayesianGaugeRR.R | 72 +++++++++++++++++++++++++++++++++++------- 1 file changed, 61 insertions(+), 11 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index a1af23fc..b9d8eb34 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -855,27 +855,27 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .bfTableDependencies <- function() { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable", "bfFavorFull")) + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable", "bfFavorFull", "report")) } .varCompTableDependencies <- function() { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference", - "estimationType", "modelType")) + "estimationType", "modelType", "report")) } .mcmcDependencies <- function() { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", "mcmcChains", "mcmcBurnin", "mcmcIterations", - "estimationType", "modelType")) + "estimationType", "modelType", "report")) } .postPlotDependencies <- function() { return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", - "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram")) + "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram", "report")) } # .optimalMetaLog <- function(fit, parameter, samplesMat) { @@ -1242,7 +1242,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.fillTablesGaugeEval <- function(jaspResults, parts, operators, options, whichTable = "sd") { +.fillTablesGaugeEval <- function(jaspResults, parts, operators, options, whichTable = "sd", gaugeReport = FALSE) { excludeInter <- .evalInter(jaspResults, parts, operators, options) # get components from MCMC samples @@ -1273,9 +1273,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } if(whichTable == "studyVar") { - # add footnote - factorSd <- jaspResults[["studyVariation"]][["object"]][[2]] - jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) + if(!gaugeReport) { + # add footnote + factorSd <- jaspResults[["studyVariation"]][["object"]][[2]] + jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) + } # summaries means <- colMeans(studyVar) @@ -1896,7 +1898,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } priorPlot <- createJaspContainer(title = gettext("Prior Distribution")) priorPlot$position <- 5 - priorPlot$dependOn("rscalePrior") + priorPlot$dependOn(c("rscalePrior", "report")) jaspResults[["priorPlot"]] <- priorPlot gPrior <- createJaspPlot(title = gettext("g-prior"), width = 600, height = 320) @@ -2317,6 +2319,46 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(plots) } +.getReportTable <- function(jaspResults, parts, operators, options) { + dfs <- list() + tables <- c("sd", "studyVar", "percStudyVar") + colNames <- c("Source", "Std. dev.", "Study variation", "%Study variation") + if(options$tolerance) { + tables <- c(tables, "percTol") + colNames <- c(colNames, "%Tolerance") + } + + for(i in seq_along(tables)) { + dfs[[i]] <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = tables[i], + gaugeReport = TRUE) + } + saveRDS(dfs, "/Users/julian/Documents/Jasp files/dfs.rds") + + out <- lapply(dfs, .extractCiAndPaste) + out <- lapply(out, function(x) sub(" \\(NA, NA\\)", "", x)) # remove empty CrIs + out <- do.call(cbind.data.frame, out) + out <- cbind.data.frame(dfs[[1]]$sourceName, out) + colnames(out) <- colNames + + # split data frame as it would otherwise be cut off in the report + if(options$tolerance) { + tolOut <- out[, c("Source", "%Tolerance")] + out <- out[, colnames(out) != "%Tolerance"] + return(list(out, tolOut)) + } + + return(list(out)) +} + +.extractCiAndPaste <- function(df) { + means <- as.numeric(df$means) + lower <- as.numeric(df$lower) + upper <- as.numeric(df$upper) + res <- paste0(round(means, 2), " (", round(lower, 2), ", ", round(upper, 2), ")") + + return(res) +} + .createGaugeReport <- function(jaspResults, dataset, measurements, parts, operators, options, ready) { nElements <- sum(options[["reportVariationComponents"]], options[["reportMeasurementsByPartPlot"]], options[["reportRChartByOperator"]], options[["reportMeasurementsByOperatorPlot"]], options[["reportAverageChartByOperator"]], @@ -2346,8 +2388,16 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # plots plots <- .getReportPlots(jaspResults, dataset, measurements, parts, operators, options) - reportPlotObject <- .qcReport(text = text, plots = plots, tables = NULL, textMaxRows = 8, - tableTitles = "", reportTitle = title, tableSize = 6) + # table + tables <- .getReportTable(jaspResults, parts, operators, options) + if(options$tolerance) { + tableTitles <- list("Gauge evaluation", "") + } else { + tableTitles <- list("Gauge evaluation") + } + + reportPlotObject <- .qcReport(text = text, plots = plots, tables = tables, textMaxRows = 8, + tableTitles = tableTitles, reportTitle = title, tableSize = 6) reportPlot$plotObject <- reportPlotObject return() From 23bbc84e11378520d3d49a84a8fc6f412b8516c4 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Mon, 30 Jun 2025 20:27:48 +0200 Subject: [PATCH 23/65] Bug fixes, distinct categories & clean-up - Fixing dependencies & posterior plots - Adding number of distinct categories - Cleaning up the code --- R/msaBayesianGaugeRR.R | 277 +++++++------------------------- R/msaGaugeRR.R | 1 + inst/qml/msaBayesianGaugeRR.qml | 12 +- 3 files changed, 64 insertions(+), 226 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index b9d8eb34..d26c85ec 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -40,7 +40,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ready <- (!identical(measurements, "") && !identical(parts, "")) } - # note this should also be in a function (I could also just make the dropdown include full model, main effects only and automatic) if(options$estimationType == "manual"){ if(options$modelType == "fullModel" || options$modelType == "mainEffectsOnly") { ready <- ready @@ -49,47 +48,33 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } } - numeric.vars <- measurements numeric.vars <- numeric.vars[numeric.vars != ""] factor.vars <- c(parts, operators) factor.vars <- factor.vars[factor.vars != ""] if (is.null(dataset)) { - dataset <- .readDataSetToEnd(columns.as.numeric = numeric.vars, columns.as.factor = factor.vars) + dataset <- .readDataSetToEnd(columns.as.numeric = numeric.vars, columns.as.factor = factor.vars) if (options$type3){ dataset$operators <- rep(1, nrow(dataset)) operators <- "operators" } } + saveRDS(dataset, "/Users/julian/Documents/Jasp files/dataset.rds") + # Checking for infinity and missingValues .hasErrors(dataset, type = c('infinity', 'missingValues'), infinity.target = measurements, missingValues.target = c(measurements, parts, operators), exitAnalysisIfErrors = TRUE) - #Converting long to wide data - # if (!wideFormat && ready) { - # dataset <- dataset[order(dataset[[operators]]),] - # dataset <- dataset[order(dataset[[parts]]),] - # nrep <- table(dataset[operators])[[1]]/length(unique(dataset[[parts]])) - # index <- rep(paste("V", 1:nrep, sep = ""), nrow(dataset)/nrep) - # dataset <- cbind(dataset, data.frame(index = index)) - # dataset <- tidyr::spread(dataset, index, measurements) - # measurements <- unique(index) - # dataset <- dataset[,c(operators, parts, measurements)] - # } else if (ready) { - # dataset <- dataset[order(dataset[[parts]]),] - # } - # Converting wide to long format if(wideFormat && ready) { dataset <- .convertToLong(dataset, measurements) measurements <- "Measurements" # name assigned to the column inside the function } - if(ready && !options[["type3"]]){ crossed <- .checkIfCrossed(dataset, operators, parts, measurements) if(!crossed){ @@ -125,7 +110,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { saveRDS(options, "/Users/julian/Documents/Jasp files/options.rds") - saveRDS(dataset, "/Users/julian/Documents/Jasp files/dataset.rds") saveRDS(measurements, "/Users/julian/Documents/Jasp files/measurements.rds") saveRDS(operators, "/Users/julian/Documents/Jasp files/operators.rds") saveRDS(parts, "/Users/julian/Documents/Jasp files/parts.rds") @@ -140,12 +124,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .createBFtable(jaspResults, dataset, options, measurements, parts, operators, ready) } - # # Effects table - # if(options[["effectsTable"]]){ - # .createEffectsTable(effectsRes, jaspResults, measurements, parts, operators, ready) - # } - - if(ready) { # MCMC .runMCMC(jaspResults, dataset, measurements, parts, operators, options) @@ -155,31 +133,24 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .getPercContrib(jaspResults, parts, operators, options) .getPercStudy(jaspResults) - ##### delete - percContrib <- .percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options) - saveRDS(percContrib, "/Users/julian/Documents/Jasp files/percContrib.rds") - ##### if(options$tolerance) { .getPercTol(jaspResults, options) } - #distFit <- try(.fitDistToSamples(jaspResults, options), silent = TRUE) - errorOccurred <- FALSE - distFit <- tryCatch( { .fitDistToSamples(jaspResults, options) }, error = function(e) { errorOccurred <<- TRUE - return(e$message) # or just return(NULL) + return(e$message) } ) } # insert report here - if(options$report) { + if(ready && options$report) { .createGaugeReport(jaspResults, dataset, measurements, parts, operators, options, ready) } else { @@ -210,20 +181,12 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .plotVariancePosteriors(jaspResults, options, parts, operators) # summary table - #if(options$posteriorCi || options$posteriorPointEstimate) { .createPostSummaryTable(jaspResults, options, parts, operators) - # if(inherits(distFit, "try-error")) { - # jaspResults[["variancePosteriors"]][["postSummary"]]$setError(gettext( - # "The currently selected distribution could not be fit to the samples. Please select another distribution under Advanced options.")) - # return() - # } if(errorOccurred) { jaspResults[["variancePosteriors"]][["postSummary"]]$setError(distFit) return() } - - #} } if(ready && options$varianceComponentsGraph) { @@ -290,7 +253,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { BFtable$addColumnInfo(name = "error", title = gettext("error %"), type = "number") # set data - if(ready) { # this could also be sth like if(ncol(dataset) == 3) + if(ready) { BFtable$setData(jaspResults[["modelComparison"]][["object"]]) BFtable$addFootnote(gettext("BF10 compares the full model to the indicated model in each row.")) } @@ -340,7 +303,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { bfFullNull <- bfDf[full, ]$bf } - # dropping unnecessary columns bfDf <- bfDf[, !colnames(bfDf) %in% c("time", "code")] @@ -365,10 +327,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["modelComparison"]][["object"]] <- bfDf return() - } - .createVarCompTable <- function(jaspResults, parts, operators, ready, options) { if(!is.null(jaspResults[["varCompTable"]])) { return() @@ -427,10 +387,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } - - - - .runMCMC <- function(jaspResults, dataset, measurements, parts, operators, options){ if(is.null(jaspResults[["MCMCsamples"]])){ MCMCsamples <- createJaspState() @@ -461,7 +417,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { burnin <- options$mcmcBurnin iter <- options$mcmcIterations - # get relevant parameters paramNames <- .bfParameterNames(parts, operators, excludeInter, options) paramNames <- c(paramNames, "sig2") @@ -495,45 +450,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { dimnames(mcmcArray) <- list(NULL, NULL, paramNames) MCMCsamples[["object"]] <- mcmcArray - ##### old code - # chains <- coda::mcmc.list() - # - # if(options$setSeed) { - # set.seed(options$seed) - # } - # - # for(i in 1:nchains) { - # # run chain - # mcmcChain <- BayesFactor::posterior(fit, iterations = iter) - # - # # exclude burn-in samples - # chains[[i]] <- coda::as.mcmc(mcmcChain[-(1:burnin), ]) - # } - # - # - # # select relevant parameters - # # names - # paramNames <- .bfParameterNames(parts, operators, excludeInter, options) - # - # chains <- chains[, c(paramNames, "sig2")] # including error variance - # - # # samplesMat <- as.matrix(chains) - # - # # # multiply variances with the error variance to reverse standardization - # # for(i in paramNames) { - # # samplesMat[, i] <- samplesMat[, i] * samplesMat[, "sig2"] - # # } - # - # chains <- lapply(chains, function(x) { - # for (i in paramNames) { - # x[, i] <- x[, i] * x[, "sig2"] - # } - # return(x) - # }) - # - # saveRDS(chains, "/Users/julian/Documents/Jasp files/chains.rds") - # MCMCsamples[["object"]] <- coda::mcmc.list(chains) - ##### return() } @@ -559,8 +475,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { postCrIupper["part"] <- "" postCrIupper["total"] <- "" } - - sourceName <- .sourceNames(options) return(data.frame(sourceName, @@ -622,7 +536,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # replace total variation with historical variance and adjust # part variation accordingly - # note: these calculations might be problematic since the uncertainty in gauge does not affect part anymore if(options$processVariationReference == "historicalSd"){ totalOld <- mean(total) total <- rep(options$historicalSdValue^2, length(repeatability)) @@ -647,36 +560,25 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(internalDF) } -# .fitMetaLog <- function(jaspResults) { -# if(is.null(jaspResults[["metaLogFit"]])){ -# metaLogFit <- createJaspState() -# metaLogFit$dependOn(.mcmcDependencies()) -# jaspResults[["metaLogFit"]] <- metaLogFit -# } else { -# return() -# } -# -# samplesMat <- jaspResults[["MCMCsamples"]][["object"]] -# -# # fit metalog to each parameter -# metaLogList <- apply(samplesMat, 2, -# function(x) rmetalog::metalog(x, bounds = 0, boundedness = "sl")) -# -# # find optimal number of terms for each parameter -# optimalTerms <- Map(.optimalMetaLog, metaLogList, names(metaLogList), -# MoreArgs = list(samplesMat = samplesMat)) -# -# # add optimal terms to list -# metaLogList <- Map(function(x, optimalTerms){ -# x[["optimalTerms"]] <- optimalTerms -# x -# }, metaLogList, optimalTerms) -# -# metaLogFit[["object"]] <- metaLogList -# -# return() -# -# } +.getDistinctCategories <- function(jaspResults, parts, operators, options) { + excludeInter <- .evalInter(jaspResults, parts, operators, options) + internalDf <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + + # subset with relevant variables + internalDf <- internalDf[, colnames(internalDf) %in% c("gauge", "part")] + sdDf <- sqrt(internalDf) + + # number distinct categories + nCat <- (sdDf$part / sdDf$gauge) * 1.41 + mean <- mean(nCat) + lower <- quantile(nCat, probs = 0.025) + upper <- quantile(nCat, probs = 0.975) + + # for footnote and report + res <- paste0(round(mean, 2), " (", round(lower, 2), ", ", round(upper, 2), ")") + + return(res) +} .createPostSummaryTable <- function(jaspResults, options, parts, operators){ if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]])){ @@ -721,7 +623,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) } - postSummary$setData(jaspResults[["postSummaryStats"]][["object"]]) return() @@ -741,7 +642,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["contourPlot"]] <- contourPlot - tempPlot <- createJaspPlot(width = 600, height = 600) tempPlot$position <- 2 @@ -751,7 +651,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # obtain necessary data contourDf <- compDf[, c("total", "part")] - mu <- mean(dataset[[measurements]]) # note: do I have to transform the variances to get a sensible result + mu <- mean(dataset[[measurements]]) # data frame for plotting meanEllipse = TRUE @@ -768,17 +668,18 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ggplot2::geom_hline(yintercept = c(options$contourLSL, options$contourUSL), linetype = "dashed", color = "black", linewidth = 1) + ggplot2::geom_path(alpha = 0.5, colour = "steelblue", linewidth = 1) - # axes xLower <- min(options$contourLSL, plotDf$x) xUpper <- max(options$contourUSL, plotDf$x) xLims <- c(xLower, xUpper) xBreaks <- jaspGraphs::getPrettyAxisBreaks(xLims) + xLims <- c(xBreaks[1], xBreaks[length(xBreaks)]) yLower <- min(options$contourLSL, plotDf$y) yUpper <- max(options$contourUSL, plotDf$y) yLims <- c(yLower, yUpper) yBreaks <- jaspGraphs::getPrettyAxisBreaks(yLims) + yLims <- c(yBreaks[1], yBreaks[length(yBreaks)]) p <- p + ggplot2::scale_x_continuous(name = "True Value", breaks = xBreaks, @@ -809,15 +710,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { contourPlot[["table"]] <- risksTable - return() } - - - - -# helper functions +#### helper functions .bfParameterNames <- function(parts, operators, excludeInter, options) { sigmaPart <- paste0("g_", parts) sigmaOperator <- paste0("g_", operators) @@ -855,55 +751,30 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .bfTableDependencies <- function() { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable", "bfFavorFull", "report")) + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable", "bfFavorFull", "report", "type3")) } .varCompTableDependencies <- function() { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference", - "estimationType", "modelType", "report")) + "estimationType", "modelType", "report", "type3")) } .mcmcDependencies <- function() { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", "mcmcChains", "mcmcBurnin", "mcmcIterations", - "estimationType", "modelType", "report")) + "estimationType", "modelType", "report", "type3")) } .postPlotDependencies <- function() { return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", - "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram", "report")) + "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram", "report", "type3", + "processVariationReference", "historicalSdValue")) # note: the processVariationReference could be added to the function with an if-statement } -# .optimalMetaLog <- function(fit, parameter, samplesMat) { -# terms <- fit$params$term_limit -# -# error <- numeric(length(terms)) -# -# for(j in 2:terms){ -# # quantiles -# j <- as.numeric(j) -# qmeta <- rmetalog::qmetalog(m = fit, y = c(0.025, 0.975), term = j) -# qdata <- quantile(samplesMat[, parameter], probs = c(0.025, 0.975)) -# -# errorCrI <- sum(abs(qdata - qmeta)) -# -# # mean -# meanMeta <- integrate(rmetalog::qmetalog, m = fit, term = j, lower = 0, upper = 1)$value # integrate over quantile function -# meanData <- mean(samplesMat[, parameter]) -# -# errorMean <- abs(meanData - meanMeta) -# -# error[j] <- sum(errorCrI, errorMean) -# } -# #print(error) -# return(which.min(error[-1]) + 1) -# } - - .convertOutputNames <- function(name, parts, operators, includeSigma = TRUE) { sigmaPart <- paste0("g_", parts) sigmaOperator <- paste0("g_", operators) @@ -1063,7 +934,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(df) } - .createGaugeEval <- function(jaspResults, parts, operators, options, ready) { if(!is.null(jaspResults[["gaugeEvaluation"]])) { return() @@ -1097,22 +967,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { stdTable$setData(cbind(stdData, studyVarData)) stdTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) - } - - # ### Study variation table - # studyVarTable <- createJaspTable(title = gettext("Study variation")) - # studyVarTable$position <- 2 - # gaugeEvaluation[["studyVarTable"]] <- studyVarTable - # - # studyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - # studyVarTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - # studyVarTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") - # studyVarTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") - # - # if(ready) { - # studyVarTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")) - # } + # number of distinct categories + nDistinct <- .getDistinctCategories(jaspResults, parts, operators, options) + stdTable$addFootnote(gettext(paste("Number of distinct categories:", nDistinct))) + } ### Percent study variation & percent tolerance table if(options$tolerance) { @@ -1149,25 +1008,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { percStudyVarTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) } - - # ### Percent tolerance table - # if(options$tolerance) { - # percTolTable <- createJaspTable(title = gettext("% Tolerance")) - # percTolTable$position <- 3 - # gaugeEvaluation[["percTolTable"]] <- percTolTable - # - # percTolTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - # percTolTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - # percTolTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") - # percTolTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") - # - # if(ready) { - # percTolTable$setData(.fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percTol")) - # } - # } - return() - } .getPercStudy <- function(jaspResults, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { @@ -1360,15 +1201,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(dataset) } - - ###### Distribution fitting ### fit functions .fitDistToSamples <- function(jaspResults, options) { if(is.null(jaspResults[["distFit"]])){ distFit <- createJaspState() - distFit$dependOn(c(.mcmcDependencies(), "distType", "posteriorPlotType", "processVariationReference", + distFit$dependOn(c(.mcmcDependencies(), "distType", "posteriorPlotType", + "processVariationReference", "historicalSdValue", "tolerance", "toleranceValue")) jaspResults[["distFit"]] <- distFit } else { @@ -1401,7 +1241,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } fit <- switch(distType, "metalog" = - if(options$posteriorPlotType == "var" || options$posteriorPlotType == "percTol") { + if(options$posteriorPlotType == "var" || options$posteriorPlotType == "percTol" || + options$processVariationReference == "historicalSd") { .fitMetaLog(samplesMat, bounds = 0, boundedness = "sl", term_lower_bound = 5, term_limit = 5) # 5 terms } else { @@ -1468,7 +1309,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { pointEstimate <- switch(options$posteriorPointEstimateType, "mean" = unlist(lapply(fits, pointFun)), "median" = unlist(lapply(fits, pointFun)), - "mode" = unlist(lapply(fits, pointFun))) # note: the mode still seems to be a bit off + "mode" = unlist(lapply(fits, pointFun))) } # intervals @@ -1680,7 +1521,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { linewidth = 1) } - # point estimate if(options$posteriorPointEstimate) { xPoint <- postSummary[i, "pointEstimate"] @@ -1740,7 +1580,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { xUpper <- dfTemp[dfTemp$probs >= 0.99, ]$x_new[1] } - if(options$posteriorPlotType != "var" && options$posteriorPlotType != "percTol") { + if(options$posteriorPlotType != "var" && options$posteriorPlotType != "percTol" && + options$processVariationReference != "historicalSd") { xUpper <- 100 } @@ -2002,8 +1843,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["trafficPlot"]] <- trafficPlot } # % Study var - # trafficPlotStudy <- createJaspPlot(width = 1000) - # trafficPlotStudy$position <- 1 percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) percStudyVar <- percStudyVar[percStudyVar$sourceName == "Total gauge r&R", ] percStudyVarMean <- percStudyVar$means @@ -2062,7 +1901,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { paramNames <- .bfParameterNames(parts, operators, excludeInter, options) paramNames <- c(paramNames, "sig2") - if(options$diagnosticsTable) { diagnosticsTable <- createJaspTable() diagnosticsTable$position <- 1 @@ -2088,7 +1926,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { titles = .convertOutputNames(paramNames, parts, operators, includeSigma = FALSE)), "density" = .densityDiagnosticsPlot(jaspResults, chains = posterior::as_draws_array(chains), paramNames, xLabs = .convertOutputNames(paramNames, parts, operators, includeSigma = FALSE))) - } return() @@ -2187,14 +2024,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(!any(is.na(xLims))) { manualScaleX <- TRUE axisBreaksX <- jaspGraphs::getPrettyAxisBreaks(xLims) - xLims <- c(axisBreaksX[1], axisBreaksX[length(axisBreaksX)]) # note: this ensures that the axis does not stop abruptly + xLims <- c(axisBreaksX[1], axisBreaksX[length(axisBreaksX)]) } - # note: the y lims do not work well for the operator plot - # yLims <- c(0, max(d$y)) - # axisBreaksY <- jaspGraphs::getPrettyAxisBreaks(yLims) - # yLims <- c(axisBreaksY[1], axisBreaksY[length(axisBreaksY)]) # note: this ensures that the axis does not stop abruptly - p <- bayesplot::mcmc_dens_overlay(chains, pars = paramNames[i]) + ggplot2::scale_color_manual(values = colors) + ggplot2::xlab(bquote(sigma[.(xLabs[i])]^2)) + @@ -2207,7 +2039,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe() + - # ggplot2::scale_y_continuous("Density", limits = yLims, breaks = axisBreaksY) + ggplot2::scale_y_continuous("Density") + ggplot2::theme(axis.ticks.y = ggplot2::element_line()) @@ -2226,7 +2057,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ### Report - .reportDependencies <- function() { return(c("report", "reportMetaData", "reportTitle", "reportTitleText", "reportPartName", "reportPartNameText", "reportGaugeName", @@ -2332,7 +2162,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { dfs[[i]] <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = tables[i], gaugeReport = TRUE) } - saveRDS(dfs, "/Users/julian/Documents/Jasp files/dfs.rds") out <- lapply(dfs, .extractCiAndPaste) out <- lapply(out, function(x) sub(" \\(NA, NA\\)", "", x)) # remove empty CrIs @@ -2340,14 +2169,19 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { out <- cbind.data.frame(dfs[[1]]$sourceName, out) colnames(out) <- colNames + # number of distinct categories + nDistinctDf <- data.frame("Number of distinct categories", + .getDistinctCategories(jaspResults, parts, operators, options)) + colnames(nDistinctDf) <- NULL + # split data frame as it would otherwise be cut off in the report if(options$tolerance) { tolOut <- out[, c("Source", "%Tolerance")] out <- out[, colnames(out) != "%Tolerance"] - return(list(out, tolOut)) + return(list(list(out, nDistinctDf), tolOut)) } - return(list(out)) + return(list(list(out, nDistinctDf))) } .extractCiAndPaste <- function(df) { @@ -2391,9 +2225,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # table tables <- .getReportTable(jaspResults, parts, operators, options) if(options$tolerance) { - tableTitles <- list("Gauge evaluation", "") + tableTitles <- list(list("Gauge evaluation", ""), "") } else { - tableTitles <- list("Gauge evaluation") + tableTitles <- list(list("Gauge evaluation", "")) } reportPlotObject <- .qcReport(text = text, plots = plots, tables = tables, textMaxRows = 8, @@ -2401,5 +2235,4 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { reportPlot$plotObject <- reportPlotObject return() - } diff --git a/R/msaGaugeRR.R b/R/msaGaugeRR.R index 47df5b8c..daf11f14 100644 --- a/R/msaGaugeRR.R +++ b/R/msaGaugeRR.R @@ -1101,6 +1101,7 @@ msaGaugeRR <- function(jaspResults, dataset, options, ...) { p1 <- p1 + ggplot2::scale_x_continuous(breaks = c(0,10,30,100), labels = c("0%","10%","30%","100%"), name = gettext(Xlab.StudySD)) if(!is.null(StudyVarCi)) { + StudyVarCi$upper <- ifelse(StudyVarCi$upper > 100, 100, StudyVarCi$upper) p1 <- p1 + ggplot2::geom_errorbarh(data = StudyVarCi, ggplot2::aes(xmin = lower, xmax = upper, y = 1), inherit.aes = FALSE, linewidth = 0.5, height = 0.5) } diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index d6be6753..af63b6af 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -797,28 +797,32 @@ Form { name: "reportRChartByOperator" label: qsTr("Show range charts by operator") - checked: true + checked: !type3.checked + enabled: !type3.checked } CheckBox { name: "reportMeasurementsByOperatorPlot" label: qsTr("Show measurements by operator") - checked: true + checked: !type3.checked + enabled: !type3.checked } CheckBox { name: "reportAverageChartByOperator" label: qsTr("Show average charts by operator") - checked: true + checked: !type3.checked + enabled: !type3.checked } CheckBox { name: "reportPartByOperatorPlot" label: qsTr("Show part × operator interaction") - checked: true + checked: !type3.checked + enabled: !type3.checked } CheckBox From 7ed83f4ce440b5f04337686a551264d9f4306dcc Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 1 Jul 2025 01:23:22 +0200 Subject: [PATCH 24/65] Adding unit tests - Unit tests and snapshots --- .../l-gauge-r-r-report-subplot-1.svg | 33 + .../l-gauge-r-r-report-subplot-10.svg | 122 ++ .../l-gauge-r-r-report-subplot-11.svg | 122 ++ .../l-gauge-r-r-report-subplot-12.svg | 56 + .../l-gauge-r-r-report-subplot-13.svg | 483 ++++++ .../l-gauge-r-r-report-subplot-14.svg | 32 + .../l-gauge-r-r-report-subplot-2.svg | 123 ++ .../l-gauge-r-r-report-subplot-3.svg | 85 + .../l-gauge-r-r-report-subplot-4.svg | 67 + .../l-gauge-r-r-report-subplot-5.svg | 123 ++ .../l-gauge-r-r-report-subplot-6.svg | 56 + .../l-gauge-r-r-report-subplot-7.svg | 242 +++ .../l-gauge-r-r-report-subplot-8.svg | 34 + .../l-gauge-r-r-report-subplot-9.svg | 41 + .../l1-components-of-variation.svg | 123 ++ .../msaBayesianGaugeRR/l1-contour-plot.svg | 75 + .../_snaps/msaBayesianGaugeRR/l1-error.svg | 69 + .../_snaps/msaBayesianGaugeRR/l1-g-prior.svg | 64 + ...l1-matrix-plot-for-operators-subplot-1.svg | 34 + ...1-matrix-plot-for-operators-subplot-10.svg | 32 + ...1-matrix-plot-for-operators-subplot-11.svg | 32 + ...1-matrix-plot-for-operators-subplot-12.svg | 34 + ...1-matrix-plot-for-operators-subplot-13.svg | 79 + ...1-matrix-plot-for-operators-subplot-14.svg | 79 + ...1-matrix-plot-for-operators-subplot-15.svg | 32 + ...l1-matrix-plot-for-operators-subplot-2.svg | 34 + ...l1-matrix-plot-for-operators-subplot-3.svg | 34 + ...l1-matrix-plot-for-operators-subplot-4.svg | 34 + ...l1-matrix-plot-for-operators-subplot-5.svg | 32 + ...l1-matrix-plot-for-operators-subplot-6.svg | 32 + ...l1-matrix-plot-for-operators-subplot-7.svg | 32 + ...l1-matrix-plot-for-operators-subplot-8.svg | 34 + ...l1-matrix-plot-for-operators-subplot-9.svg | 79 + .../l1-measurements-by-operator.svg | 67 + .../l1-measurements-by-part.svg | 175 ++ .../_snaps/msaBayesianGaugeRR/l1-operator.svg | 71 + .../l1-part-by-operator-interaction.svg | 123 ++ .../_snaps/msaBayesianGaugeRR/l1-part.svg | 71 + .../_snaps/msaBayesianGaugeRR/l1-rchart.svg | 122 ++ .../l1-trace-plot-error.svg | 66 + .../l1-trace-plot-operators.svg | 68 + .../l1-trace-plot-parts.svg | 64 + .../l1-traffic-light-chart-subplot-1.svg | 56 + .../l1-traffic-light-chart-subplot-2.svg | 56 + .../msaBayesianGaugeRR/l1-xbar-chart.svg | 122 ++ .../l2-autocor-plot-error.svg | 66 + .../l2-autocor-plot-inter.svg | 66 + .../l2-autocor-plot-operators.svg | 66 + .../l2-autocor-plot-parts.svg | 66 + .../l2-components-of-variation.svg | 123 ++ .../_snaps/msaBayesianGaugeRR/l2-operator.svg | 73 + .../msaBayesianGaugeRR/l2-part-to-part.svg | 75 + .../msaBayesianGaugeRR/l2-repeatability.svg | 69 + .../msaBayesianGaugeRR/l2-reproducibility.svg | 73 + .../msaBayesianGaugeRR/l2-total-gauge-r-r.svg | 71 + .../l2-traffic-light-chart-subplot-1.svg | 56 + .../l2-traffic-light-chart-subplot-2.svg | 56 + .../l3-components-of-variation.svg | 109 ++ .../l3-density-plot-type-3-error.svg | 61 + .../l3-density-plot-type3-parts.svg | 65 + .../msaBayesianGaugeRR/l3-part-to-part.svg | 69 + .../msaBayesianGaugeRR/l3-repeatability.svg | 73 + .../msaBayesianGaugeRR/l3-total-gauge-r-r.svg | 73 + .../msaBayesianGaugeRR/l3-total-variation.svg | 69 + .../l3-traffic-light-chart-subplot-1.svg | 56 + .../l3-traffic-light-chart-subplot-2.svg | 56 + .../l4-components-of-variation.svg | 110 ++ .../l4-density-plot-histsd-error.svg | 59 + .../l4-density-plot-histsd-operators.svg | 69 + .../l4-density-plot-histsd-parts.svg | 65 + .../_snaps/msaBayesianGaugeRR/l4-operator.svg | 71 + .../msaBayesianGaugeRR/l4-repeatability.svg | 71 + .../msaBayesianGaugeRR/l4-reproducibility.svg | 71 + .../msaBayesianGaugeRR/l4-total-gauge-r-r.svg | 75 + .../l4-traffic-light-chart-subplot-1.svg | 56 + .../l4-traffic-light-chart-subplot-2.svg | 56 + .../w-gauge-r-r-report-subplot-1.svg | 33 + .../w-gauge-r-r-report-subplot-10.svg | 120 ++ .../w-gauge-r-r-report-subplot-11.svg | 124 ++ .../w-gauge-r-r-report-subplot-12.svg | 56 + .../w-gauge-r-r-report-subplot-13.svg | 483 ++++++ .../w-gauge-r-r-report-subplot-14.svg | 32 + .../w-gauge-r-r-report-subplot-2.svg | 117 ++ .../w-gauge-r-r-report-subplot-3.svg | 85 + .../w-gauge-r-r-report-subplot-4.svg | 67 + .../w-gauge-r-r-report-subplot-5.svg | 125 ++ .../w-gauge-r-r-report-subplot-6.svg | 56 + .../w-gauge-r-r-report-subplot-7.svg | 242 +++ .../w-gauge-r-r-report-subplot-8.svg | 34 + .../w-gauge-r-r-report-subplot-9.svg | 41 + .../w1-components-of-variation.svg | 117 ++ .../w1-contour-plot-wide.svg | 83 + .../_snaps/msaBayesianGaugeRR/w1-error.svg | 81 + .../_snaps/msaBayesianGaugeRR/w1-g-prior.svg | 64 + ...w1-matrix-plot-for-operators-subplot-1.svg | 34 + ...1-matrix-plot-for-operators-subplot-10.svg | 32 + ...1-matrix-plot-for-operators-subplot-11.svg | 32 + ...1-matrix-plot-for-operators-subplot-12.svg | 34 + ...1-matrix-plot-for-operators-subplot-13.svg | 81 + ...1-matrix-plot-for-operators-subplot-14.svg | 79 + ...1-matrix-plot-for-operators-subplot-15.svg | 32 + ...w1-matrix-plot-for-operators-subplot-2.svg | 34 + ...w1-matrix-plot-for-operators-subplot-3.svg | 34 + ...w1-matrix-plot-for-operators-subplot-4.svg | 34 + ...w1-matrix-plot-for-operators-subplot-5.svg | 32 + ...w1-matrix-plot-for-operators-subplot-6.svg | 32 + ...w1-matrix-plot-for-operators-subplot-7.svg | 32 + ...w1-matrix-plot-for-operators-subplot-8.svg | 34 + ...w1-matrix-plot-for-operators-subplot-9.svg | 81 + .../w1-measurements-by-operator.svg | 67 + .../w1-measurements-by-part.svg | 173 ++ .../_snaps/msaBayesianGaugeRR/w1-operator.svg | 71 + .../w1-part-by-operator-interaction.svg | 125 ++ .../_snaps/msaBayesianGaugeRR/w1-part.svg | 73 + .../msaBayesianGaugeRR/w1-rchart-wide.svg | 120 ++ .../w1-trace-plot-error-wide.svg | 70 + .../w1-trace-plot-operators-wide.svg | 64 + .../w1-trace-plot-parts-wide.svg | 68 + .../w1-traffic-light-chart-wide-subplot-1.svg | 56 + .../w1-traffic-light-chart-wide-subplot-2.svg | 56 + .../msaBayesianGaugeRR/w1-xbar-chart-wide.svg | 124 ++ .../w2-autocor-plot-error-wide.svg | 66 + .../w2-autocor-plot-inter-wide.svg | 66 + .../w2-autocor-plot-operators-wide.svg | 66 + .../w2-autocor-plot-parts-wide.svg | 66 + .../w2-components-of-variation.svg | 117 ++ .../_snaps/msaBayesianGaugeRR/w2-operator.svg | 69 + .../msaBayesianGaugeRR/w2-part-to-part.svg | 71 + .../msaBayesianGaugeRR/w2-repeatability.svg | 71 + .../msaBayesianGaugeRR/w2-reproducibility.svg | 75 + .../msaBayesianGaugeRR/w2-total-gauge-r-r.svg | 69 + .../w2-traffic-light-chart-wide-subplot-1.svg | 56 + .../w2-traffic-light-chart-wide-subplot-2.svg | 56 + .../w3-components-of-variation.svg | 103 ++ .../w3-density-plot-type-3-error-wide.svg | 61 + .../w3-density-plot-type3-parts-wide.svg | 69 + .../msaBayesianGaugeRR/w3-part-to-part.svg | 67 + .../msaBayesianGaugeRR/w3-repeatability.svg | 75 + .../msaBayesianGaugeRR/w3-total-gauge-r-r.svg | 75 + .../msaBayesianGaugeRR/w3-total-variation.svg | 71 + .../w3-traffic-light-chart-wide-subplot-1.svg | 56 + .../w3-traffic-light-chart-wide-subplot-2.svg | 56 + .../w4-components-of-variation.svg | 110 ++ .../w4-density-plot-histsd-error-wide.svg | 61 + .../w4-density-plot-histsd-operators-wide.svg | 63 + .../w4-density-plot-histsd-parts-wide.svg | 69 + .../_snaps/msaBayesianGaugeRR/w4-operator.svg | 69 + .../msaBayesianGaugeRR/w4-repeatability.svg | 77 + .../msaBayesianGaugeRR/w4-reproducibility.svg | 69 + .../msaBayesianGaugeRR/w4-total-gauge-r-r.svg | 73 + .../w4-traffic-light-chart-wide-subplot-1.svg | 56 + .../w4-traffic-light-chart-wide-subplot-2.svg | 56 + tests/testthat/test-msaBayesianGaugeRR.R | 1456 +++++++++++++++++ 153 files changed, 13142 insertions(+) create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-10.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-11.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-12.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-13.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-14.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-3.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-4.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-5.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-6.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-7.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-8.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-9.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-components-of-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-contour-plot.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-error.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-g-prior.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-10.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-11.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-12.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-13.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-14.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-15.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-3.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-4.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-5.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-6.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-7.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-8.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-9.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-measurements-by-operator.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-measurements-by-part.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-operator.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-part-by-operator-interaction.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-part.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-rchart.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-error.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-operators.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-parts.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-traffic-light-chart-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-traffic-light-chart-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l1-xbar-chart.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-error.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-inter.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-operators.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-parts.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-components-of-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-operator.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-part-to-part.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-repeatability.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-reproducibility.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-total-gauge-r-r.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-traffic-light-chart-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l2-traffic-light-chart-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-components-of-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type-3-error.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type3-parts.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-part-to-part.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-repeatability.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-total-gauge-r-r.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-total-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-traffic-light-chart-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l3-traffic-light-chart-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-components-of-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-error.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-operators.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-parts.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-operator.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-repeatability.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-reproducibility.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-total-gauge-r-r.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-traffic-light-chart-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/l4-traffic-light-chart-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-10.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-11.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-12.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-13.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-14.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-3.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-4.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-5.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-6.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-7.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-8.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-9.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-components-of-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-contour-plot-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-error.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-g-prior.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-10.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-11.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-12.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-13.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-14.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-15.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-3.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-4.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-5.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-6.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-7.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-8.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-9.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-measurements-by-operator.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-measurements-by-part.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-operator.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-part-by-operator-interaction.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-part.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-rchart-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-error-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-operators-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-parts-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-traffic-light-chart-wide-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-traffic-light-chart-wide-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w1-xbar-chart-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-error-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-inter-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-operators-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-parts-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-components-of-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-operator.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-part-to-part.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-repeatability.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-reproducibility.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-total-gauge-r-r.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-traffic-light-chart-wide-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w2-traffic-light-chart-wide-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-components-of-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type-3-error-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type3-parts-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-part-to-part.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-repeatability.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-total-gauge-r-r.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-total-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-traffic-light-chart-wide-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w3-traffic-light-chart-wide-subplot-2.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-components-of-variation.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-error-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-operators-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-parts-wide.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-operator.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-repeatability.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-reproducibility.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-total-gauge-r-r.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-traffic-light-chart-wide-subplot-1.svg create mode 100644 tests/testthat/_snaps/msaBayesianGaugeRR/w4-traffic-light-chart-wide-subplot-2.svg create mode 100644 tests/testthat/test-msaBayesianGaugeRR.R diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-1.svg new file mode 100644 index 00000000..8edc1c35 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-1.svg @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + + + + +L gauge-r-r-report-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-10.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-10.svg new file mode 100644 index 00000000..506179a8 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-10.svg @@ -0,0 +1,122 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Operator A +Operator B +Operator C + +CL = 0.45 + +LCL = 0 + +UCL = 1.16 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 +1.2 + + + + + + + + + + + + + + + +1 +5 +10 +5 +10 +5 +10 +Sample +Sample range +L gauge-r-r-report-subplot-10 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-11.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-11.svg new file mode 100644 index 00000000..bf8be36c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-11.svg @@ -0,0 +1,122 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Operator A +Operator B +Operator C + +CL = -4.56 + +LCL = -5.02 + +UCL = -4.1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + +1 +5 +10 +5 +10 +5 +10 +Sample +Sample average +L gauge-r-r-report-subplot-11 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-12.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-12.svg new file mode 100644 index 00000000..73ae3b09 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-12.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +31.65% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +L gauge-r-r-report-subplot-12 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-13.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-13.svg new file mode 100644 index 00000000..89a753b2 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-13.svg @@ -0,0 +1,483 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Source + + + + +Total gauge r&R + + + + +Std. dev. + + + + +Repeatability + + + + +Study variation + + + + +Reproducibility + + + + +%Study variation + + + + +Operator + + + + +Part-to-part + + + + +Total variation + + + + +0.53 (0.37, 1.04) + + + + +0.37 (0.32, 0.43) + + + + +0.35 (0.14, 0.97) + + + + +0.35 (0.14, 0.97) + + + + +3.39 (2.19, 5.42) + + + + +3.44 (2.25, 5.46) + + + + +3.16 (2.21, 6.25) + + + + +2.22 (1.9, 2.6) + + + + +2.11 (0.84, 5.83) + + + + +2.11 (0.84, 5.83) + + + + +20.32 (13.13, 32.51) + + + + +20.61 (13.5, 32.75) + + + + +16.06 (8.2, 32.7) + + + + +11.36 (6.54, 16.98) + + + + +10.62 (3.59, 29.78) + + + + +10.62 (3.59, 29.78) + + + + +98.46 (94.5, 99.66) + + + + +100 + + + + + + + + + + + + + + + + + + + + + + + + +Number of distinct categories + + + + +9.77 (4.07, 17.13) + + +Gauge evaluation + + +L gauge-r-r-report-subplot-13 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-14.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-14.svg new file mode 100644 index 00000000..d64076b5 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-14.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +L gauge-r-r-report-subplot-14 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-2.svg new file mode 100644 index 00000000..8f76d8f1 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-2.svg @@ -0,0 +1,123 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 +250 +300 +350 + + + + + + + + + + + + + +Gauge r&R +Repeat +Reprod +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +L gauge-r-r-report-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-3.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-3.svg new file mode 100644 index 00000000..75d2f889 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-3.svg @@ -0,0 +1,85 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +Parts +Measurement +L gauge-r-r-report-subplot-3 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-4.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-4.svg new file mode 100644 index 00000000..c1c04319 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-4.svg @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-9 +-6 +-3 +0 + + + + + + + + +Operator A +Operator B +Operator C +Operators +Measurement +L gauge-r-r-report-subplot-4 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-5.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-5.svg new file mode 100644 index 00000000..8395f3d2 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-5.svg @@ -0,0 +1,123 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +Part +Average + + +Operator + + + + + + + + + +Operator A +Operator B +Operator C +L gauge-r-r-report-subplot-5 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-6.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-6.svg new file mode 100644 index 00000000..4f76a86e --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-6.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +16.06% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +L gauge-r-r-report-subplot-6 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-7.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-7.svg new file mode 100644 index 00000000..0b1f97c6 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-7.svg @@ -0,0 +1,242 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Source + + + + +Total gauge r&R + + + + +%Tolerance + + + + +Repeatability + + + + +Reproducibility + + + + +Operator + + + + +Part-to-part + + + + +Total variation + + + + +31.65 (22.14, 62.49) + + + + +22.21 (19.02, 26.04) + + + + +21.05 (8.36, 58.27) + + + + +21.05 (8.36, 58.27) + + + + +203.15 (131.34, 325.13) + + + + +206.13 (134.97, 327.45) + + + + +L gauge-r-r-report-subplot-7 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-8.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-8.svg new file mode 100644 index 00000000..49af4b08 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-8.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Gauge r&R report + + +L gauge-r-r-report-subplot-8 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-9.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-9.svg new file mode 100644 index 00000000..1eeca8ac --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l-gauge-r-r-report-subplot-9.svg @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + +Part name: +Gauge name: +Characteristic: +Gauge number: +Tolerance: +Location: +Performed by: +Date: + + +L gauge-r-r-report-subplot-9 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-components-of-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-components-of-variation.svg new file mode 100644 index 00000000..93430bb6 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-components-of-variation.svg @@ -0,0 +1,123 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 +250 +300 +350 + + + + + + + + + + + + + +Gauge r&R +Repeat +Reprod +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +L1 components-of-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-contour-plot.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-contour-plot.svg new file mode 100644 index 00000000..9ae124ea --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-contour-plot.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-15 +-10 +-5 +0 +5 + + + + + + + + + + + +-15 +-10 +-5 +0 +5 +True Value +Measurement +L1 Contour plot + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-error.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-error.svg new file mode 100644 index 00000000..9fcfa346 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-error.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +5 +10 +15 +20 + + + + + + + + + + + +0 +0.05 +0.1 +0.15 +0.2 +σ +Error +2 +Density +L1 error + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-g-prior.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-g-prior.svg new file mode 100644 index 00000000..40329a91 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-g-prior.svg @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +g +Density +L1 g-prior + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-1.svg new file mode 100644 index 00000000..ac266abf --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-1.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator A + + +L1 matrix-plot-for-operators-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-10.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-10.svg new file mode 100644 index 00000000..15fd0d06 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-10.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +L1 matrix-plot-for-operators-subplot-10 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-11.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-11.svg new file mode 100644 index 00000000..e9a70cad --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-11.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +L1 matrix-plot-for-operators-subplot-11 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-12.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-12.svg new file mode 100644 index 00000000..57489fa7 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-12.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator C + + +L1 matrix-plot-for-operators-subplot-12 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-13.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-13.svg new file mode 100644 index 00000000..78e5eae5 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-13.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 +L1 matrix-plot-for-operators-subplot-13 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-14.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-14.svg new file mode 100644 index 00000000..0746d540 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-14.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 +L1 matrix-plot-for-operators-subplot-14 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-15.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-15.svg new file mode 100644 index 00000000..f72a3b60 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-15.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +L1 matrix-plot-for-operators-subplot-15 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-2.svg new file mode 100644 index 00000000..bd04833e --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-2.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator B + + +L1 matrix-plot-for-operators-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-3.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-3.svg new file mode 100644 index 00000000..ca62640d --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-3.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator C + + +L1 matrix-plot-for-operators-subplot-3 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-4.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-4.svg new file mode 100644 index 00000000..b6b68b0f --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-4.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator A + + +L1 matrix-plot-for-operators-subplot-4 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-5.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-5.svg new file mode 100644 index 00000000..5ff97564 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-5.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +L1 matrix-plot-for-operators-subplot-5 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-6.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-6.svg new file mode 100644 index 00000000..2402713e --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-6.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +L1 matrix-plot-for-operators-subplot-6 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-7.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-7.svg new file mode 100644 index 00000000..c7627d0e --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-7.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +L1 matrix-plot-for-operators-subplot-7 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-8.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-8.svg new file mode 100644 index 00000000..246537d3 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-8.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator B + + +L1 matrix-plot-for-operators-subplot-8 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-9.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-9.svg new file mode 100644 index 00000000..40e7be24 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-matrix-plot-for-operators-subplot-9.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 +L1 matrix-plot-for-operators-subplot-9 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-measurements-by-operator.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-measurements-by-operator.svg new file mode 100644 index 00000000..688cb46b --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-measurements-by-operator.svg @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-9 +-6 +-3 +0 + + + + + + + + +Operator A +Operator B +Operator C +Operators +Measurement +L1 measurements-by-operator + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-measurements-by-part.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-measurements-by-part.svg new file mode 100644 index 00000000..83630dfe --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-measurements-by-part.svg @@ -0,0 +1,175 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +Parts +Measurement +L1 measurements-by-part + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-operator.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-operator.svg new file mode 100644 index 00000000..0dce3ab2 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-operator.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 + + + + + + + + + + + + +0 +0.5 +1 +1.5 +2 +σ +Operator +2 +Density +L1 operator + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-part-by-operator-interaction.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-part-by-operator-interaction.svg new file mode 100644 index 00000000..53729796 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-part-by-operator-interaction.svg @@ -0,0 +1,123 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +Part +Average + + +Operator + + + + + + + + + +Operator A +Operator B +Operator C +L1 part-by-operator-interaction + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-part.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-part.svg new file mode 100644 index 00000000..06187628 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-part.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.02 +0.04 +0.06 +0.08 +0.1 + + + + + + + + + + + + +0 +10 +20 +30 +40 +σ +Part +2 +Density +L1 part + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-rchart.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-rchart.svg new file mode 100644 index 00000000..4ba7cb4b --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-rchart.svg @@ -0,0 +1,122 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Operator A +Operator B +Operator C + +CL = 0.45 + +LCL = 0 + +UCL = 1.16 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 +1.2 + + + + + + + + + + + + + + + +1 +5 +10 +5 +10 +5 +10 +Sample +Sample range +L1 rChart + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-error.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-error.svg new file mode 100644 index 00000000..7707b93c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-error.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 + + + + + + + + + + + + +0 +2000 +4000 +6000 +8000 +σ +Error +2 +L1 Trace plot error + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-operators.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-operators.svg new file mode 100644 index 00000000..c54bfd1e --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-operators.svg @@ -0,0 +1,68 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +5 +10 +15 +20 +25 +30 + + + + + + + + + + + + + +0 +2000 +4000 +6000 +8000 +σ +Operator +2 +L1 Trace plot operators + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-parts.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-parts.svg new file mode 100644 index 00000000..e53f1635 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-trace-plot-parts.svg @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 + + + + + + + + + + + +0 +2000 +4000 +6000 +8000 +σ +Part +2 +L1 Trace plot parts + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-traffic-light-chart-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-traffic-light-chart-subplot-1.svg new file mode 100644 index 00000000..559a9ef7 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-traffic-light-chart-subplot-1.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +16.06% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +L1 Traffic light chart-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-traffic-light-chart-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-traffic-light-chart-subplot-2.svg new file mode 100644 index 00000000..712a2562 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-traffic-light-chart-subplot-2.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +31.65% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +L1 Traffic light chart-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l1-xbar-chart.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-xbar-chart.svg new file mode 100644 index 00000000..5bd02478 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l1-xbar-chart.svg @@ -0,0 +1,122 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Operator A +Operator B +Operator C + +CL = -4.56 + +LCL = -5.02 + +UCL = -4.1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-12 +-10 +-8 +-6 +-4 +-2 +0 + + + + + + + + + + + + + + + +1 +5 +10 +5 +10 +5 +10 +Sample +Sample average +L1 xBar chart + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-error.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-error.svg new file mode 100644 index 00000000..af2b5853 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-error.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +5 +10 +15 +20 +Lag +Autocorrelation +σ +Error +2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-inter.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-inter.svg new file mode 100644 index 00000000..4d0ec566 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-inter.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +5 +10 +15 +20 +Lag +Autocorrelation +σ +Part ✻ Operator +2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-operators.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-operators.svg new file mode 100644 index 00000000..69bf7100 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-operators.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +5 +10 +15 +20 +Lag +Autocorrelation +σ +Operator +2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-parts.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-parts.svg new file mode 100644 index 00000000..cdfe8427 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-autocor-plot-parts.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +5 +10 +15 +20 +Lag +Autocorrelation +σ +Part +2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-components-of-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-components-of-variation.svg new file mode 100644 index 00000000..17dc1d60 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-components-of-variation.svg @@ -0,0 +1,123 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 +250 +300 +350 + + + + + + + + + + + + + +Gauge r&R +Repeat +Reprod +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +L2 components-of-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-operator.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-operator.svg new file mode 100644 index 00000000..f5e61d3c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-operator.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.02 +0.04 +0.06 +0.08 +0.1 +0.12 + + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +L2 operator + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-part-to-part.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-part-to-part.svg new file mode 100644 index 00000000..d41ec1c3 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-part-to-part.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 + + + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +L2 part-to-part + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-repeatability.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-repeatability.svg new file mode 100644 index 00000000..24465f7c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-repeatability.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.05 +0.1 +0.15 +0.2 + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +L2 repeatability + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-reproducibility.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-reproducibility.svg new file mode 100644 index 00000000..a5154011 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-reproducibility.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.02 +0.04 +0.06 +0.08 +0.1 +0.12 + + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +L2 reproducibility + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-total-gauge-r-r.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-total-gauge-r-r.svg new file mode 100644 index 00000000..e3b6b595 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-total-gauge-r-r.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.02 +0.04 +0.06 +0.08 +0.1 + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +L2 total-gauge-r-r + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-traffic-light-chart-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-traffic-light-chart-subplot-1.svg new file mode 100644 index 00000000..a78344da --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-traffic-light-chart-subplot-1.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +16.33% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +L2 Traffic light chart-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l2-traffic-light-chart-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-traffic-light-chart-subplot-2.svg new file mode 100644 index 00000000..4f02d329 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l2-traffic-light-chart-subplot-2.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +32.25% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +L2 Traffic light chart-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-components-of-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-components-of-variation.svg new file mode 100644 index 00000000..5bc894e3 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-components-of-variation.svg @@ -0,0 +1,109 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 +250 +300 +350 + + + + + + + + + + + + +Gauge r&R +Repeat +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +L3 components-of-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type-3-error.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type-3-error.svg new file mode 100644 index 00000000..5273a775 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type-3-error.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +5 +10 +15 + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +σ +Error +2 +Density +L3 Density plot type 3 error + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type3-parts.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type3-parts.svg new file mode 100644 index 00000000..a97201f3 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type3-parts.svg @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.000 +0.025 +0.050 +0.075 +0.100 + + + + + + + + + + + +0 +10 +20 +30 +40 +σ +Part +2 +Density +L3 Density plot type3 parts + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-part-to-part.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-part-to-part.svg new file mode 100644 index 00000000..5bd69509 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-part-to-part.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.002 +0.004 +0.006 +0.008 +0.01 + + + + + + + + + + + + +0 +100 +200 +300 +400 +% Tolerance +Density +L3 part-to-part + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-repeatability.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-repeatability.svg new file mode 100644 index 00000000..485df23d --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-repeatability.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.05 +0.1 +0.15 +0.2 +0.25 + + + + + + + + + + + + + + +0 +5 +10 +15 +20 +25 +30 +% Tolerance +Density +L3 repeatability + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-total-gauge-r-r.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-total-gauge-r-r.svg new file mode 100644 index 00000000..bdbe19c1 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-total-gauge-r-r.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.05 +0.1 +0.15 +0.2 +0.25 + + + + + + + + + + + + + + +0 +5 +10 +15 +20 +25 +30 +% Tolerance +Density +L3 total-gauge-r-r + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-total-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-total-variation.svg new file mode 100644 index 00000000..5acb166f --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-total-variation.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.002 +0.004 +0.006 +0.008 +0.01 + + + + + + + + + + + + +0 +100 +200 +300 +400 +% Tolerance +Density +L3 total-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-traffic-light-chart-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-traffic-light-chart-subplot-1.svg new file mode 100644 index 00000000..c892f756 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-traffic-light-chart-subplot-1.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +12.22% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +L3 Traffic light chart-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-traffic-light-chart-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-traffic-light-chart-subplot-2.svg new file mode 100644 index 00000000..273eea5a --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-traffic-light-chart-subplot-2.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +23.75% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +L3 Traffic light chart-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-components-of-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-components-of-variation.svg new file mode 100644 index 00000000..f975bffc --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-components-of-variation.svg @@ -0,0 +1,110 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 + + + + + + + + + + + +Gauge r&R +Repeat +Reprod +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +L4 components-of-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-error.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-error.svg new file mode 100644 index 00000000..84819a01 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-error.svg @@ -0,0 +1,59 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +5 +10 +15 + + + + + + + + +0.0 +0.1 +0.2 +σ +Error +2 +Density +L4 Density plot histSd error + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-operators.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-operators.svg new file mode 100644 index 00000000..f5b07fa9 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-operators.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +2.5 +5.0 +7.5 + + + + + + + + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 +σ +Operator +2 +Density +L4 Density plot histSd operators + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-parts.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-parts.svg new file mode 100644 index 00000000..8b885740 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-parts.svg @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.000 +0.025 +0.050 +0.075 +0.100 + + + + + + + + + + + +0 +10 +20 +30 +40 +σ +Part +2 +Density +L4 Density plot histSd parts + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-operator.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-operator.svg new file mode 100644 index 00000000..6ced1432 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-operator.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.05 +0.1 +0.15 +0.2 +0.25 + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Contribution +Density +L4 operator + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-repeatability.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-repeatability.svg new file mode 100644 index 00000000..e2f59abb --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-repeatability.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.1 +0.2 +0.3 +0.4 +0.5 + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +% Contribution +Density +L4 repeatability + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-reproducibility.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-reproducibility.svg new file mode 100644 index 00000000..0c30c4f0 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-reproducibility.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.05 +0.1 +0.15 +0.2 +0.25 + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Contribution +Density +L4 reproducibility + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-total-gauge-r-r.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-total-gauge-r-r.svg new file mode 100644 index 00000000..2491a04a --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-total-gauge-r-r.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.02 +0.04 +0.06 +0.08 +0.1 +0.12 +0.14 + + + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Contribution +Density +L4 total-gauge-r-r + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-traffic-light-chart-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-traffic-light-chart-subplot-1.svg new file mode 100644 index 00000000..a1fa2b83 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-traffic-light-chart-subplot-1.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +35.16% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +L4 Traffic light chart-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-traffic-light-chart-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-traffic-light-chart-subplot-2.svg new file mode 100644 index 00000000..2772a9c0 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-traffic-light-chart-subplot-2.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +31.65% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +L4 Traffic light chart-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-1.svg new file mode 100644 index 00000000..d0950727 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-1.svg @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + + + + +W gauge-r-r-report-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-10.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-10.svg new file mode 100644 index 00000000..62c5331c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-10.svg @@ -0,0 +1,120 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +A +B +C + +CL = 1.65 + +LCL = 0 + +UCL = 4.24 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + +1 +5 +10 +5 +10 +5 +10 +Sample +Sample range +W gauge-r-r-report-subplot-10 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-11.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-11.svg new file mode 100644 index 00000000..3d55cebe --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-11.svg @@ -0,0 +1,124 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +A +B +C + +CL = 8.08 + +LCL = 6.39 + +UCL = 9.76 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +12 + + + + + + + + + + + + + + + + +1 +5 +10 +5 +10 +5 +10 +Sample +Sample average +W gauge-r-r-report-subplot-11 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-12.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-12.svg new file mode 100644 index 00000000..ae9d855a --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-12.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +74.75% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +W gauge-r-r-report-subplot-12 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-13.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-13.svg new file mode 100644 index 00000000..0299779b --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-13.svg @@ -0,0 +1,483 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Source + + + + +Total gauge r&R + + + + +Std. dev. + + + + +Repeatability + + + + +Study variation + + + + +Reproducibility + + + + +%Study variation + + + + +Operator + + + + +Part-to-part + + + + +Total variation + + + + +1.25 (0.9, 2.34) + + + + +0.92 (0.79, 1.08) + + + + +0.78 (0.31, 2.15) + + + + +0.78 (0.31, 2.15) + + + + +1.77 (1.12, 2.86) + + + + +2.2 (1.56, 3.4) + + + + +7.47 (5.4, 14.02) + + + + +5.54 (4.75, 6.49) + + + + +4.65 (1.86, 12.87) + + + + +4.65 (1.86, 12.87) + + + + +10.65 (6.72, 17.16) + + + + +13.21 (9.35, 20.4) + + + + +57 (35.11, 83.28) + + + + +43.69 (26.64, 59.6) + + + + +34.28 (13.85, 74.97) + + + + +34.28 (13.85, 74.97) + + + + +80.7 (55.35, 93.63) + + + + +100 + + + + + + + + + + + + + + + + + + + + + + + + +Number of distinct categories + + + + +2.14 (0.94, 3.76) + + +Gauge evaluation + + +W gauge-r-r-report-subplot-13 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-14.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-14.svg new file mode 100644 index 00000000..21326ef5 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-14.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +W gauge-r-r-report-subplot-14 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-2.svg new file mode 100644 index 00000000..efb5d1c5 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-2.svg @@ -0,0 +1,117 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 + + + + + + + + + + +Gauge r&R +Repeat +Reprod +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +W gauge-r-r-report-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-3.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-3.svg new file mode 100644 index 00000000..c64b9657 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-3.svg @@ -0,0 +1,85 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +Part +Measurement +W gauge-r-r-report-subplot-3 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-4.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-4.svg new file mode 100644 index 00000000..4d359742 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-4.svg @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +6 +8 +10 +12 + + + + + + + + +A +B +C +Operator +Measurement +W gauge-r-r-report-subplot-4 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-5.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-5.svg new file mode 100644 index 00000000..4a1a7940 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-5.svg @@ -0,0 +1,125 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +12 + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +Part +Average + + +Operator + + + + + + + + + +A +B +C +W gauge-r-r-report-subplot-5 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-6.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-6.svg new file mode 100644 index 00000000..849bbddc --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-6.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +57.00% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +W gauge-r-r-report-subplot-6 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-7.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-7.svg new file mode 100644 index 00000000..00229886 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-7.svg @@ -0,0 +1,242 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Source + + + + +Total gauge r&R + + + + +%Tolerance + + + + +Repeatability + + + + +Reproducibility + + + + +Operator + + + + +Part-to-part + + + + +Total variation + + + + +74.75 (54.03, 140.23) + + + + +55.43 (47.45, 64.91) + + + + +46.51 (18.64, 128.7) + + + + +46.51 (18.64, 128.7) + + + + +106.47 (67.2, 171.62) + + + + +132.14 (93.51, 203.98) + + + + +W gauge-r-r-report-subplot-7 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-8.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-8.svg new file mode 100644 index 00000000..2d03f857 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-8.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Gauge r&R report + + +W gauge-r-r-report-subplot-8 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-9.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-9.svg new file mode 100644 index 00000000..671f20a4 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w-gauge-r-r-report-subplot-9.svg @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + +Part name: +Gauge name: +Characteristic: +Gauge number: +Tolerance: +Location: +Performed by: +Date: + + +W gauge-r-r-report-subplot-9 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-components-of-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-components-of-variation.svg new file mode 100644 index 00000000..aaefd8b4 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-components-of-variation.svg @@ -0,0 +1,117 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 + + + + + + + + + + +Gauge r&R +Repeat +Reprod +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +W1 components-of-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-contour-plot-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-contour-plot-wide.svg new file mode 100644 index 00000000..45b54719 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-contour-plot-wide.svg @@ -0,0 +1,83 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +4 +6 +8 +10 +12 +14 + + + + + + + + + + + + + + + +2 +4 +6 +8 +10 +12 +14 +True Value +Measurement +W1 Contour plot wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-error.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-error.svg new file mode 100644 index 00000000..045d3be4 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-error.svg @@ -0,0 +1,81 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.5 +1 +1.5 +2 +2.5 +3 +3.5 + + + + + + + + + + + + + + + + + +0 +0.2 +0.4 +0.6 +0.8 +1 +1.2 +1.4 +σ +Error +2 +Density +W1 error + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-g-prior.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-g-prior.svg new file mode 100644 index 00000000..a2441cda --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-g-prior.svg @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +g +Density +W1 g-prior + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-1.svg new file mode 100644 index 00000000..d924d4a4 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-1.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator A + + +W1 matrix-plot-for-operators-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-10.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-10.svg new file mode 100644 index 00000000..0280e24f --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-10.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +W1 matrix-plot-for-operators-subplot-10 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-11.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-11.svg new file mode 100644 index 00000000..df8b0418 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-11.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +W1 matrix-plot-for-operators-subplot-11 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-12.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-12.svg new file mode 100644 index 00000000..3607c871 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-12.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator C + + +W1 matrix-plot-for-operators-subplot-12 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-13.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-13.svg new file mode 100644 index 00000000..d2a71f8a --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-13.svg @@ -0,0 +1,81 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +12 + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +W1 matrix-plot-for-operators-subplot-13 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-14.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-14.svg new file mode 100644 index 00000000..5f277597 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-14.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +W1 matrix-plot-for-operators-subplot-14 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-15.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-15.svg new file mode 100644 index 00000000..df4e3098 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-15.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +W1 matrix-plot-for-operators-subplot-15 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-2.svg new file mode 100644 index 00000000..abd09f68 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-2.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator B + + +W1 matrix-plot-for-operators-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-3.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-3.svg new file mode 100644 index 00000000..7c314e62 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-3.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator C + + +W1 matrix-plot-for-operators-subplot-3 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-4.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-4.svg new file mode 100644 index 00000000..6f2e7514 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-4.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator A + + +W1 matrix-plot-for-operators-subplot-4 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-5.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-5.svg new file mode 100644 index 00000000..5f8f2f81 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-5.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +W1 matrix-plot-for-operators-subplot-5 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-6.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-6.svg new file mode 100644 index 00000000..cfeb4f04 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-6.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +W1 matrix-plot-for-operators-subplot-6 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-7.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-7.svg new file mode 100644 index 00000000..fc2eaabf --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-7.svg @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +W1 matrix-plot-for-operators-subplot-7 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-8.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-8.svg new file mode 100644 index 00000000..842ac9ea --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-8.svg @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + +Operator B + + +W1 matrix-plot-for-operators-subplot-8 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-9.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-9.svg new file mode 100644 index 00000000..af33d4b1 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-matrix-plot-for-operators-subplot-9.svg @@ -0,0 +1,81 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +12 + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +W1 matrix-plot-for-operators-subplot-9 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-measurements-by-operator.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-measurements-by-operator.svg new file mode 100644 index 00000000..341abc07 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-measurements-by-operator.svg @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +6 +8 +10 +12 + + + + + + + + +A +B +C +Operator +Measurement +W1 measurements-by-operator + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-measurements-by-part.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-measurements-by-part.svg new file mode 100644 index 00000000..a29ce614 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-measurements-by-part.svg @@ -0,0 +1,173 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +4 +6 +8 +10 +12 +14 + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +Part +Measurement +W1 measurements-by-part + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-operator.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-operator.svg new file mode 100644 index 00000000..93a72b2c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-operator.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.5 +1 +1.5 +2 + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +σ +Operator +2 +Density +W1 operator + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-part-by-operator-interaction.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-part-by-operator-interaction.svg new file mode 100644 index 00000000..7c7593bc --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-part-by-operator-interaction.svg @@ -0,0 +1,125 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +12 + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +Part +Average + + +Operator + + + + + + + + + +A +B +C +W1 part-by-operator-interaction + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-part.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-part.svg new file mode 100644 index 00000000..f0c6458d --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-part.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 +σ +Part +2 +Density +W1 part + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-rchart-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-rchart-wide.svg new file mode 100644 index 00000000..8d7e658a --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-rchart-wide.svg @@ -0,0 +1,120 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +A +B +C + +CL = 1.65 + +LCL = 0 + +UCL = 4.24 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + +1 +5 +10 +5 +10 +5 +10 +Sample +Sample range +W1 rChart wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-error-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-error-wide.svg new file mode 100644 index 00000000..a4c29e23 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-error-wide.svg @@ -0,0 +1,70 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.4 +0.6 +0.8 +1.0 +1.2 +1.4 +1.6 +1.8 + + + + + + + + + + + + + + +0 +2000 +4000 +6000 +8000 +σ +Error +2 +W1 Trace plot error wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-operators-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-operators-wide.svg new file mode 100644 index 00000000..264cf4f0 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-operators-wide.svg @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +100 +200 +300 +400 + + + + + + + + + + + +0 +2000 +4000 +6000 +8000 +σ +Operator +2 +W1 Trace plot operators wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-parts-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-parts-wide.svg new file mode 100644 index 00000000..a15901ae --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-trace-plot-parts-wide.svg @@ -0,0 +1,68 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +10 +20 +30 +40 +50 +60 + + + + + + + + + + + + + +0 +2000 +4000 +6000 +8000 +σ +Part +2 +W1 Trace plot parts wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-traffic-light-chart-wide-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-traffic-light-chart-wide-subplot-1.svg new file mode 100644 index 00000000..a328ff8e --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-traffic-light-chart-wide-subplot-1.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +57.00% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +W1 Traffic light chart wide-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-traffic-light-chart-wide-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-traffic-light-chart-wide-subplot-2.svg new file mode 100644 index 00000000..50db822c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-traffic-light-chart-wide-subplot-2.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +74.75% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +W1 Traffic light chart wide-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w1-xbar-chart-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-xbar-chart-wide.svg new file mode 100644 index 00000000..03c06b6c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w1-xbar-chart-wide.svg @@ -0,0 +1,124 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +A +B +C + +CL = 8.08 + +LCL = 6.39 + +UCL = 9.76 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +5 +6 +7 +8 +9 +10 +11 +12 + + + + + + + + + + + + + + + + +1 +5 +10 +5 +10 +5 +10 +Sample +Sample average +W1 xBar chart wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-error-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-error-wide.svg new file mode 100644 index 00000000..836ce7a2 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-error-wide.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +5 +10 +15 +20 +Lag +Autocorrelation +σ +Error +2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-inter-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-inter-wide.svg new file mode 100644 index 00000000..0dd55b7a --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-inter-wide.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +5 +10 +15 +20 +Lag +Autocorrelation +σ +Part ✻ Operator +2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-operators-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-operators-wide.svg new file mode 100644 index 00000000..f73c1383 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-operators-wide.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +5 +10 +15 +20 +Lag +Autocorrelation +σ +Operator +2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-parts-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-parts-wide.svg new file mode 100644 index 00000000..1aa656aa --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-autocor-plot-parts-wide.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +5 +10 +15 +20 +Lag +Autocorrelation +σ +Part +2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-components-of-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-components-of-variation.svg new file mode 100644 index 00000000..ef629205 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-components-of-variation.svg @@ -0,0 +1,117 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 + + + + + + + + + + +Gauge r&R +Repeat +Reprod +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +W2 components-of-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-operator.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-operator.svg new file mode 100644 index 00000000..e1ed1ccd --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-operator.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.01 +0.02 +0.03 +0.04 + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +W2 operator + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-part-to-part.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-part-to-part.svg new file mode 100644 index 00000000..a24c7c26 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-part-to-part.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.01 +0.02 +0.03 +0.04 +0.05 + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +W2 part-to-part + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-repeatability.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-repeatability.svg new file mode 100644 index 00000000..67ba2c8a --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-repeatability.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.01 +0.02 +0.03 +0.04 +0.05 + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +W2 repeatability + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-reproducibility.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-reproducibility.svg new file mode 100644 index 00000000..b7239796 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-reproducibility.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.005 +0.01 +0.015 +0.02 +0.025 +0.03 +0.035 + + + + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +W2 reproducibility + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-total-gauge-r-r.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-total-gauge-r-r.svg new file mode 100644 index 00000000..1b4a391d --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-total-gauge-r-r.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.01 +0.02 +0.03 +0.04 + + + + + + + + + + + + +0 +20 +40 +60 +80 +100 +% Study Variation +Density +W2 total-gauge-r-r + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-traffic-light-chart-wide-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-traffic-light-chart-wide-subplot-1.svg new file mode 100644 index 00000000..011517c3 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-traffic-light-chart-wide-subplot-1.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +58.99% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +W2 Traffic light chart wide-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w2-traffic-light-chart-wide-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-traffic-light-chart-wide-subplot-2.svg new file mode 100644 index 00000000..be0e850d --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w2-traffic-light-chart-wide-subplot-2.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +77.84% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +W2 Traffic light chart wide-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-components-of-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-components-of-variation.svg new file mode 100644 index 00000000..a179c133 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-components-of-variation.svg @@ -0,0 +1,103 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 + + + + + + + + + +Gauge r&R +Repeat +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +W3 components-of-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type-3-error-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type-3-error-wide.svg new file mode 100644 index 00000000..007c004c --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type-3-error-wide.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 + + + + + + + + + +0.0 +0.5 +1.0 +1.5 +σ +Error +2 +Density +W3 Density plot type 3 error wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type3-parts-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type3-parts-wide.svg new file mode 100644 index 00000000..248259dd --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type3-parts-wide.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.1 +0.2 +0.3 + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 +14 +σ +Part +2 +Density +W3 Density plot type3 parts wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-part-to-part.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-part-to-part.svg new file mode 100644 index 00000000..3036d2d0 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-part-to-part.svg @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.005 +0.01 +0.015 +0.02 + + + + + + + + + + + +0 +50 +100 +150 +200 +% Tolerance +Density +W3 part-to-part + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-repeatability.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-repeatability.svg new file mode 100644 index 00000000..2ddcec71 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-repeatability.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.02 +0.04 +0.06 +0.08 +0.1 + + + + + + + + + + + + + + + +0 +10 +20 +30 +40 +50 +60 +70 +% Tolerance +Density +W3 repeatability + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-total-gauge-r-r.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-total-gauge-r-r.svg new file mode 100644 index 00000000..54f86082 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-total-gauge-r-r.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.02 +0.04 +0.06 +0.08 +0.1 + + + + + + + + + + + + + + + +0 +10 +20 +30 +40 +50 +60 +70 +% Tolerance +Density +W3 total-gauge-r-r + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-total-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-total-variation.svg new file mode 100644 index 00000000..68cc7e35 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-total-variation.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.005 +0.01 +0.015 +0.02 +0.025 + + + + + + + + + + + + + +0 +50 +100 +150 +200 +250 +% Tolerance +Density +W3 total-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-traffic-light-chart-wide-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-traffic-light-chart-wide-subplot-1.svg new file mode 100644 index 00000000..f317d6d6 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-traffic-light-chart-wide-subplot-1.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +47.90% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +W3 Traffic light chart wide-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-traffic-light-chart-wide-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-traffic-light-chart-wide-subplot-2.svg new file mode 100644 index 00000000..bbe1300d --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-traffic-light-chart-wide-subplot-2.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +56.00% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +W3 Traffic light chart wide-subplot-2 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-components-of-variation.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-components-of-variation.svg new file mode 100644 index 00000000..62c4be7e --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-components-of-variation.svg @@ -0,0 +1,110 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 +250 + + + + + + + + + + + +Gauge r&R +Repeat +Reprod +Part-to-part +Percent + + + + + + + + +% Contribution +% Study variation +% Tolerance +W4 components-of-variation + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-error-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-error-wide.svg new file mode 100644 index 00000000..c440d267 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-error-wide.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 + + + + + + + + + +0.0 +0.5 +1.0 +1.5 +σ +Error +2 +Density +W4 Density plot histSd error wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-operators-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-operators-wide.svg new file mode 100644 index 00000000..8f2ec1cb --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-operators-wide.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.5 +1.0 +1.5 + + + + + + + + + + +0 +5 +10 +15 +20 +σ +Operator +2 +Density +W4 Density plot histSd operators wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-parts-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-parts-wide.svg new file mode 100644 index 00000000..9dc25c3f --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-parts-wide.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.1 +0.2 +0.3 + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 +14 +σ +Part +2 +Density +W4 Density plot histSd parts wide + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-operator.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-operator.svg new file mode 100644 index 00000000..688beded --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-operator.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.01 +0.02 +0.03 +0.04 +0.05 + + + + + + + + + + + + +0 +100 +200 +300 +400 +% Contribution +Density +W4 operator + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-repeatability.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-repeatability.svg new file mode 100644 index 00000000..8b5edd7b --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-repeatability.svg @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.01 +0.02 +0.03 +0.04 +0.05 +0.06 +0.07 + + + + + + + + + + + + + + + + +0 +10 +20 +30 +40 +50 +60 +% Contribution +Density +W4 repeatability + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-reproducibility.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-reproducibility.svg new file mode 100644 index 00000000..a13b112f --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-reproducibility.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.01 +0.02 +0.03 +0.04 +0.05 + + + + + + + + + + + + +0 +100 +200 +300 +400 +% Contribution +Density +W4 reproducibility + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-total-gauge-r-r.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-total-gauge-r-r.svg new file mode 100644 index 00000000..7ddefcff --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-total-gauge-r-r.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +0.005 +0.01 +0.015 +0.02 +0.025 +0.03 + + + + + + + + + + + + + + +0 +100 +200 +300 +400 +500 +% Contribution +Density +W4 total-gauge-r-r + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-traffic-light-chart-wide-subplot-1.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-traffic-light-chart-wide-subplot-1.svg new file mode 100644 index 00000000..214cd6a0 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-traffic-light-chart-wide-subplot-1.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +83.06% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the process variation +W4 Traffic light chart wide-subplot-1 + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-traffic-light-chart-wide-subplot-2.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-traffic-light-chart-wide-subplot-2.svg new file mode 100644 index 00000000..549f0f96 --- /dev/null +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-traffic-light-chart-wide-subplot-2.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +74.75% + + + + + + + + + + + + +0% +10% +30% +100% +Percent measurement system variation of the tolerance +W4 Traffic light chart wide-subplot-2 + + diff --git a/tests/testthat/test-msaBayesianGaugeRR.R b/tests/testthat/test-msaBayesianGaugeRR.R new file mode 100644 index 00000000..89df6e14 --- /dev/null +++ b/tests/testthat/test-msaBayesianGaugeRR.R @@ -0,0 +1,1456 @@ +context("[Quality Control] Bayesian Gauge r&R") + +## tests long-format +### automatic model selection & posterior on variances (generalized inverse Gaussian) +options <- analysisOptions("msaBayesianGaugeRR") +options$measurementLongFormat <- "Dm" +options$operatorLongFormat <- "Operators" +options$partLongFormat <- "Parts" +options$tolerance <- TRUE +options$priorPlot <- TRUE +options$posteriorPlot <- TRUE +options$posteriorPlotType <- "var" +options$posteriorHistogram <- TRUE +options$posteriorCi <- TRUE +options$contourPlot <- TRUE +options$contourLSL <- -10 +options$contourUSL <- 0 +options$rChart <- TRUE +options$xBarChart <- TRUE +options$scatterPlot <- TRUE +options$scatterPlotFitLine <- TRUE +options$scatterPlotOriginLine <- TRUE +options$partMeasurementPlot <- TRUE +options$partMeasurementPlotAllValues <- TRUE +options$operatorMeasurementPlot <- TRUE +options$partByOperatorMeasurementPlot <- TRUE +options$trafficLightChart <- TRUE +options$distType <- "gig" +set.seed(1) +results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) + + +test_that("L1 Model Comparison table results match", { + table <- results[["results"]][["BFtable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(9.1287767597893e+66, 0.0077421542931849, "Null model", 1, "", + "Parts + Operators + PartsOperators", + 0.113212575159566, 0.00872259468666002, "Parts + Operators" + )) +}) + +test_that("L1 Contour plot matches", { + plotName <- results[["results"]][["contourPlot"]][["collection"]][["contourPlot_plot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 Contour plot") +}) + +test_that("L1 Producer's (δ) and Consumer's (β) Risk table results match", { + table <- results[["results"]][["contourPlot"]][["collection"]][["contourPlot_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.00738797550717418, 0.0217229988723209, "", 0.0504418242104906, + 0.0466531148350437, 0.108462891253646, "", 0.210628344001828 + )) +}) + +test_that("L1 % Contribution to Total Variation table results match", { + table <- results[["results"]][["contribTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.672854564674615, 3.01603148541284, "Total gauge r&R", 10.6957816353577, + 0.428066317944134, 1.36262810109564, "Repeatability", 2.88196943211859, + 0.128937314959488, 1.65340338431719, "Reproducibility", 8.86803963413681, + 0.128937314959488, 1.65340338431719, "Operator", 8.86803963413681, + 89.3042183646423, 96.9839685145869, "Part-to-part", 99.3271454353254, + "", 100, "Total variation", "")) +}) + +test_that("L1 Part by operator interaction plot matches", { + plotName <- results[["results"]][["gaugeByInteraction"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 part-by-operator-interaction") +}) + +test_that("L1 Measurements by operator plot matches", { + plotName <- results[["results"]][["gaugeByOperator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 measurements-by-operator") +}) + +test_that("L1 Measurements by part plot matches", { + plotName <- results[["results"]][["gaugeByPart"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 measurements-by-part") +}) + +test_that("L1 % Study Variation & % Tolerance table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_percStudyVarTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(8.20277120172739, 22.1408240975003, 16.0560064136487, 31.6484709916296, + "Total gauge r&R", 32.7044057966602, 62.4858618220583, 6.54267771618492, + 19.0232155665105, 11.3621810602882, 22.2068164968796, "Repeatability", + 16.9763642511899, 26.042334748647, 3.59078423443732, 8.35951370532176, + 10.6197907610815, 21.0549057299311, "Reproducibility", 29.7792514328602, + 58.2732584746615, 3.59078423443732, 8.35951370532176, 10.6197907610815, + 21.0549057299311, "Operator", 29.7792514328602, 58.2732584746615, + 94.5009091800832, 131.338182169877, 98.4586706459067, 203.15001505139, + "Part-to-part", 99.6630048891023, 325.127983561911, "", 134.972221466956, + 100, 206.127409873692, "Total variation", "", 327.452182037894 + )) +}) + +test_that("L1 Standard Deviation & Study Variation table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_stdTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.369013734958338, 2.21408240975003, 0.527474516527165, 3.16484709916296, + "Total gauge r&R", 1.04143103036764, 6.24858618220583, 0.317053592775174, + 1.90232155665105, 0.370113608281325, 2.22068164968796, "Repeatability", + 0.434038912477449, 2.6042334748647, 0.139325228422029, 0.835951370532175, + 0.350915095498847, 2.10549057299309, "Reproducibility", 0.971220974577692, + 5.82732584746615, 0.139325228422029, 0.835951370532175, 0.350915095498847, + 2.10549057299309, "Operator", 0.971220974577692, 5.82732584746615, + 2.18896970283128, 13.1338182169877, 3.38583358418984, 20.3150015051389, + "Part-to-part", 5.41879972603185, 32.5127983561911, 2.24953702444927, + 13.4972221466956, 3.4354568312282, 20.6127409873691, "Total variation", + 5.45753636729823, 32.7452182037894)) +}) + +test_that("L1 Matrix plot for operators matches", { + plotName <- results[["results"]][["gaugeScatterOperators"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 matrix-plot-for-operators") +}) + +test_that("L1 Trace plot operators matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Operators"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 Trace plot operators") +}) + +test_that("L1 Trace plot parts matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Parts"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 Trace plot parts") +}) + +test_that("L1 Trace plot error matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_sig2"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 Trace plot error") +}) + +test_that("L1 Diagnostics table results match", { + table <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(13156.2958719656, 14548.1788817734, 0.0643396308484891, 0.026604748502423, + 0.416661068666242, "2Part", 0.999980107827912, + 8826.27376375007, 8779.64520704258, 0.00739624941904107, 0.000226595508114019, + 0.0456256051161729, "2Operator", + 0.999989789442352, 9519.12272634791, 13138.4226911852, 0.000228956655794118, + 0.000320520616274043, 0.000765639483270394, "2Error", + 1.00096014378277)) +}) + +test_that("L1 g-prior plot matches", { + plotName <- results[["results"]][["priorPlot"]][["collection"]][["priorPlot_plot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 g-prior") +}) + +test_that("L1 rChart matches", { + plotName <- results[["results"]][["rChart"]][["collection"]][["rChart_plot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 rChart") +}) + +test_that("L1 Test results for range chart table results match", { + table <- results[["results"]][["rChart"]][["collection"]][["rChart_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list("No test violations occurred.")) +}) + +test_that("L1 Traffic light chart matches", { + plotName <- results[["results"]][["trafficPlot"]][["collection"]][["trafficPlot_trafficPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 Traffic light chart") +}) + +test_that("L1 Components of variation plot matches", { + plotName <- results[["results"]][["varCompPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 components-of-variation") +}) + +test_that("L1 Variance Components table results match", { + table <- results[["results"]][["varCompTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.136171136634584, 1.08457861699851, 0.328512928494555, 0.64962130987885, + "Total gauge r&R", 0.100522980701193, 0.188389777677887, + 0.137871376665235, 0.0224366411670959, "Repeatability", 0.0194115194133937, + 0.943270181509932, 0.190641551829319, 0.648481519656201, "Reproducibility", + 0.0194115194133937, 0.943270181509932, 0.190641551829319, 0.648481519656201, + "Operator", 4.79158836022261, 29.3633907449221, 12.2100438401309, + 7.26694993903746, "Part-to-part", 5.06041682996016, 29.7847032117442, + 12.5385567686254, 7.30119170960903, "Total variation")) +}) + +test_that("L1 Error plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Error"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 error") +}) + +test_that("L1 Operator plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 operator") +}) + +test_that("L1 Part plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 part") +}) + +test_that("L1 Posterior Summary table results match", { + table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + jaspTools::expect_equal_tables(table, + list(4.78249678043341, 29.8522838983694, "2Part", + 12.2063561157816, 0.019717972167065, 0.963666980675533, "2Operator", + 0.190584413578255, 0.100232646227405, 0.187736626967306, "2Error", + 0.137874639867539)) +}) + +test_that("L1 xBar chart matches", { + plotName <- results[["results"]][["xBarChart"]][["collection"]][["xBarChart_plot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L1 xBar chart") +}) + +test_that("L1 Test results for x-bar chart table results match", { + table <- results[["results"]][["xBarChart"]][["collection"]][["xBarChart_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list("Operator A", "Point 1", "", "Point 2", "", "Point 3", "", "Point 4", + "", "Point 5", "", "Point 6", "", "Point 7", "", "Point 8", + "", "Point 9", "", "Point 10", "Operator B", "Point 11", "", + "Point 12", "", "Point 13", "", "Point 14", "", "Point 15", + "", "Point 16", "", "Point 17", "", "Point 18", "", "Point 19", + "", "Point 20", "Operator C", "Point 21", "", "Point 22", "", + "Point 23", "", "Point 24", "", "Point 25", "", "Point 26", + "", "Point 27", "", "Point 28", "", "Point 29", "", "Point 30" + )) +}) + + +### full model, autocorrelation plot & posterior on %study var (metalog fit) +options <- analysisOptions("msaBayesianGaugeRR") +options$measurementLongFormat <- "Dm" +options$operatorLongFormat <- "Operators" +options$partLongFormat <- "Parts" +options$estimationType <- "manual" +options$tolerance <- TRUE +options$posteriorPlot <- TRUE +options$posteriorPlotType <- "percStudyVar" +options$posteriorHistogram <- TRUE +options$posteriorCi <- TRUE +options$trafficLightChart <- TRUE +options$diagnosticsPlotType <- "autocor" +options$distType <- "metalog" +options$modelType <- "fullModel" +set.seed(1) +results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) + + +test_that("L2 Model Comparison table results match", { + table <- results[["results"]][["BFtable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(9.1287767597893e+66, 0.0077421542931849, "Null model", 1, "", + "Parts + Operators + PartsOperators", + 0.113212575159566, 0.00872259468666002, "Parts + Operators" + )) +}) + +test_that("L2 % Contribution to Total Variation table results match", { + table <- results[["results"]][["contribTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.69447557946222, 3.05404347725902, "Total gauge r&R", 9.81157819333386, + 0.365617611408123, 1.18254623665808, "Repeatability", 2.50534144416177, + 0.248512477297506, 1.87149724060094, "Reproducibility", 8.28077895940993, + 0.112863258114114, 1.48254203391395, "Operator", 7.79715004565745, + 90.1884218066661, 96.9459565227407, "Part-to-part", 99.3055244205378, + "", 100, "Total variation", "")) +}) + +test_that("L2 % Study Variation & % Tolerance table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_percStudyVarTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(8.33352010084559, 22.9786386424899, 16.3322195040502, 32.2484497939107, + "Total gauge r&R", 31.3234388066817, 59.6412966340563, 6.04663221290274, + 17.6288943903814, 10.5801416260002, 20.7059537295768, "Repeatability", + 15.8282704124082, 24.373940737509, 4.98510256793306, 12.3575654327892, + 12.0283968363823, 23.8525213529975, "Reproducibility", 28.7763423711902, + 55.6207429515081, 3.35951273364442, 7.8490424913573, 10.0901334559607, + 20.0717059566318, "Operator", 27.9233752657033, 54.2107521223829, + 94.9675848939788, 130.639342259913, 98.4410373260722, 203.511825478069, + "Part-to-part", 99.6521572373075, 333.768084944735, "", 134.396600839345, + 100, 206.549553474733, "Total variation", "", 335.858700611061 + )) +}) + +test_that("L2 Standard Deviation & Study Variation table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_stdTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.382977310708165, 2.29786386424899, 0.537474163231843, 3.22484497939106, + "Total gauge r&R", 0.994021610567605, 5.96412966340563, + 0.293814906506357, 1.76288943903814, 0.34509922882628, 2.07059537295769, + "Repeatability", 0.406232345625149, 2.4373940737509, 0.20595942387982, + 1.23575654327892, 0.397542022549958, 2.38525213529974, "Reproducibility", + 0.927012382525134, 5.56207429515081, 0.130817374855955, 0.78490424913573, + 0.334528432610531, 2.00717059566317, "Operator", 0.903512535373049, + 5.42107521223829, 2.17732237099855, 13.0639342259913, 3.39186375796782, + 20.3511825478067, "Part-to-part", 5.56280141574558, 33.3768084944735, + 2.23994334732242, 13.4396600839345, 3.44249255791222, 20.6549553474733, + "Total variation", 5.59764501018435, 33.5858700611061)) +}) + +test_that("L2 Autocor plot operators matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Operators"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 Autocor plot operators") +}) + +test_that("L2 Autocor plot parts matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Parts"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 Autocor plot parts") +}) + +test_that("L2 Autocor plot inter matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Parts:Operators"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 Autocor plot inter") +}) + +test_that("L2 Autocor plot error matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_sig2"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 Autocor plot error") +}) + +test_that("L2 Diagnostics table results match", { + table <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(12967.850228195, 14329.7160415497, 0.062732257546333, 0.0341846247500968, + 0.539677077803615, "2Part", 1.00002456233026, + 8500.80410601691, 9050.8556088105, 0.0148892656693548, 0.00016236059250508, + 0.0329594078357549, "2Operator", + 1.00012670868512, 2552.53155004218, 4983.42629160057, 0.00043254562416457, + 0.000245120601889498, 0.00221431079824162, "2PartOperator", + 1.00024837506665, 6397.65222878932, 10084.8788553676, 0.000251800876700841, + 0.000254706253452919, 0.000694930652478803, "2Error", + 1.00000831671343)) +}) + +test_that("L2 Traffic light chart matches", { + plotName <- results[["results"]][["trafficPlot"]][["collection"]][["trafficPlot_trafficPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 Traffic light chart") +}) + +test_that("L2 Components of variation plot matches", { + plotName <- results[["results"]][["varCompPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 components-of-variation") +}) + +test_that("L2 Variance Components table results match", { + table <- results[["results"]][["varCompTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.146671620526603, 0.988078962511109, 0.34370391186105, 1.58695054948859, + "Total gauge r&R", 0.0863271993104535, 0.165024718682726, + 0.11991388657612, 0.020108398519423, "Repeatability", 0.0424192843572241, + 0.859351985170204, 0.223790025284931, 1.58641961102281, "Reproducibility", + 0.0171131855642062, 0.816334902198017, 0.184248502487699, 1.58585651722007, + "Operator", 4.74073270725694, 30.944759618133, 12.2577502514977, + 7.07891510019515, "Part-to-part", 5.01734620004458, 31.3336296606438, + 12.6014541633589, 7.26094148376794, "Total variation")) +}) + +test_that("L2 Operator plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 operator") +}) + +test_that("L2 Part-to-part plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part-to-part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 part-to-part") +}) + +test_that("L2 Repeatability plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 repeatability") +}) + +test_that("L2 Reproducibility plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Reproducibility"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 reproducibility") +}) + +test_that("L2 Total gauge r&R plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L2 total-gauge-r-r") +}) + +test_that("L2 Posterior Summary table results match", { + table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + jaspTools::expect_equal_tables(table, + list(8.40483271767977, 33.0057533152063, "Total gauge r&R", 16.4140241975042, + 6.04889943061452, 15.7471976500399, "Repeatability", 10.5766752981399, + 5.07341929971864, 29.5462725588561, "Reproducibility", 12.0468877459586, + 3.38522425736962, 28.4919128501656, "Operator", 10.0912145081404, + 94.6627001896635, 99.6460991284399, "Part-to-part", 98.4312844657675 + )) +}) + +### type 3, density diagnostics plot & posterior on %Tolerance (metalog fit) +options <- analysisOptions("msaBayesianGaugeRR") +options$measurementLongFormat <- "Dm" +options$partLongFormat <- "Parts" +options$type3 <- TRUE +options$tolerance <- TRUE +options$posteriorPlot <- TRUE +options$posteriorPlotType <- "percTol" +options$posteriorHistogram <- TRUE +options$posteriorCi <- TRUE +options$trafficLightChart <- TRUE +options$diagnosticsPlotType <- "density" +options$distType <- "metalog" +set.seed(1) +results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) + + +test_that("L3 Model Comparison table results match", { + table <- results[["results"]][["BFtable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(1.21824945358133e+67, 4.52862083972528e-07, "Null model", 1, "", + "Parts")) +}) + +test_that("L3 % Contribution to Total Variation table results match", { + table <- results[["results"]][["contribTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.486660998980681, 1.57812882489572, "Total gauge r&R", 3.31935853093398, + 0.486660998980681, 1.57812882489572, "Repeatability", 3.31935853093398, + 96.680641469066, 98.4218711751048, "Part-to-part", 99.5133390010193, + "", 100, "Total variation", "")) +}) + +test_that("L3 % Study Variation & % Tolerance table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_percStudyVarTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(6.97610906534103, 20.3690235963062, 12.2240799868402, 23.7480532160329, + "Total gauge r&R", 18.2191068137751, 27.8369834027837, 6.97610906534103, + 20.3690235963062, 12.2240799868402, 23.7480532160329, "Repeatability", + 18.2191068137751, 27.8369834027837, 98.3263146207898, 131.405161770283, + 99.2070911544104, 203.640368012146, "Part-to-part", 99.7563727292204, + 334.591586444325, "", 133.578417870203, 100, 205.107533242308, + "Total variation", "", 335.288690363822)) +}) + +test_that("L3 Standard Deviation & Study Variation table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_stdTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.339483726605103, 2.03690235963062, 0.395800886933879, 2.37480532160328, + "Total gauge r&R", 0.463949723379728, 2.78369834027837, + 0.339483726605103, 2.03690235963062, 0.395800886933879, 2.37480532160328, + "Repeatability", 0.463949723379728, 2.78369834027837, 2.19008602950472, + 13.1405161770283, 3.39400613353577, 20.3640368012146, "Part-to-part", + 5.57652644073874, 33.4591586444325, 2.22630696450339, 13.3578417870203, + 3.41845888737181, 20.5107533242309, "Total variation", 5.58814483939704, + 33.5288690363822)) +}) + +test_that("L3 Density plot type3 parts matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Parts"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L3 Density plot type3 parts") +}) + +test_that("L3 Density plot type 3 error matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_sig2"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L3 Density plot type 3 error") +}) + +test_that("L3 Diagnostics table results match", { + table <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(13013.8840798061, 13434.1168244218, 0.0641205840760188, 0.0456636982145211, + 0.4668331247511, "2Part", 0.999911614893083, + 10264.3177964902, 13098.7327637058, 0.000253246417063196, 0.000424909254537975, + 0.000947491447932325, "2Error", + 0.999947182865367)) +}) + +test_that("L3 Traffic light chart matches", { + plotName <- results[["results"]][["trafficPlot"]][["collection"]][["trafficPlot_trafficPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L3 Traffic light chart") +}) + +test_that("L3 Components of variation plot matches", { + plotName <- results[["results"]][["varCompPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L3 components-of-variation") +}) + +test_that("L3 Variance Components table results match", { + table <- results[["results"]][["varCompTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.115249200662058, 0.215249345973517, 0.157658926333129, 0.0254995397510453, + "Total gauge r&R", 0.115249200662058, 0.215249345973517, + 0.157658926333129, 0.0254995397510453, "Repeatability", 4.79647682219662, + 31.0976471553276, 12.2669633998433, 7.0481079233022, "Part-to-part", + 4.95644270972351, 31.2273628685899, 12.4246223261765, 7.04797820646694, + "Total variation")) +}) + +test_that("L3 Part-to-part plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part-to-part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L3 part-to-part") +}) + +test_that("L3 Repeatability plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L3 repeatability") +}) + +test_that("L3 Total gauge r&R plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L3 total-gauge-r-r") +}) + +test_that("L3 Total variation plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total variation"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L3 total-variation") +}) + +test_that("L3 Posterior Summary table results match", { + table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + jaspTools::expect_equal_tables(table, + list(20.4255240578281, 27.7936833384094, "Total gauge r&R", 23.7462166121699, + 20.4255240578281, 27.7936833384094, "Repeatability", 23.7462166121699, + 132.494221789943, 328.60136274761, "Part-to-part", 203.470639651509, + 134.688309385618, 329.570001781427, "Total variation", 204.959377455086 + )) +}) + + +### historical SD & posterior on %Contribution (metalog) +options <- analysisOptions("msaBayesianGaugeRR") +options$measurementLongFormat <- "Dm" +options$operatorLongFormat <- "Operators" +options$partLongFormat <- "Parts" +options$processVariationReference <- "historicalSd" +options$historicalSdValue <- 1.5 +options$tolerance <- TRUE +options$posteriorPlot <- TRUE +options$posteriorPlotType <- "percContrib" +options$posteriorHistogram <- TRUE +options$posteriorCi <- TRUE +options$trafficLightChart <- TRUE +options$diagnosticsPlotType <- "density" +options$distType <- "metalog" +set.seed(1) +results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) + + +test_that("L4 Model Comparison table results match", { + table <- results[["results"]][["BFtable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(9.1287767597893e+66, 0.0077421542931849, "Null model", 1, "", + "Parts + Operators + PartsOperators", + 0.113212575159566, 0.00872259468666002, "Parts + Operators" + )) +}) + +test_that("L4 % Contribution to Total Variation table results match", { + table <- results[["results"]][["contribTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(6.05205051709262, 14.6005745997579, "Total gauge r&R", 48.2034940888228, + 4.46768803116411, 6.12761674067714, "Repeatability", 8.37287900790609, + 0.862734196150831, 8.47295785908085, "Reproducibility", 41.9231191782192, + 0.862734196150831, 8.47295785908085, "Operator", 41.9231191782192, + "", 85.3994254002103, "Part-to-part", "", "", 100, "Total variation", + "")) +}) + +test_that("L4 % Study Variation & % Tolerance table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_percStudyVarTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(24.6009156638892, 22.1408240975003, 35.1649677684775, 31.6484709916296, + "Total gauge r&R", 69.4287353578425, 62.4858618220583, 21.1369061850116, + 19.0232155665105, 24.6742405520885, 22.2068164968796, "Repeatability", + 28.9359274984966, 26.042334748647, 9.28834856146862, 8.35951370532176, + 23.3943396999233, 21.0549057299311, "Reproducibility", 64.7480649718461, + 58.2732584746615, 9.28834856146862, 8.35951370532176, 23.3943396999233, + 21.0549057299311, "Operator", 64.7480649718461, 58.2732584746615, + "", "", 92.4118095268483, 83.1706285741424, "Part-to-part", + "", "", "", "", 100, 90, "Total variation", "", "")) +}) + +test_that("L4 Standard Deviation & Study Variation table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_stdTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.369013734958338, 2.21408240975003, 0.527474516527165, 3.16484709916296, + "Total gauge r&R", 1.04143103036764, 6.24858618220583, 0.317053592775174, + 1.90232155665105, 0.370113608281325, 2.22068164968796, "Repeatability", + 0.434038912477449, 2.6042334748647, 0.139325228422029, 0.835951370532175, + 0.350915095498847, 2.10549057299309, "Reproducibility", 0.971220974577692, + 5.82732584746615, 0.139325228422029, 0.835951370532175, 0.350915095498847, + 2.10549057299309, "Operator", 0.971220974577692, 5.82732584746615, + "", "", 1.38617714290269, 8.31706285741529, "Part-to-part", + "", "", "", "", 1.5, 9, "Total variation", "", "")) +}) + +test_that("L4 Density plot histSd operators matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Operators"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 Density plot histSd operators") +}) + +test_that("L4 Density plot histSd parts matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Parts"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 Density plot histSd parts") +}) + +test_that("L4 Density plot histSd error matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_sig2"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 Density plot histSd error") +}) + +test_that("L4 Diagnostics table results match", { + table <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(13156.2958719656, 14548.1788817734, 0.0643396308484891, 0.026604748502423, + 0.416661068666242, "2Part", 0.999980107827912, + 8826.27376375007, 8779.64520704258, 0.00739624941904107, 0.000226595508114019, + 0.0456256051161729, "2Operator", + 0.999989789442352, 9519.12272634791, 13138.4226911852, 0.000228956655794118, + 0.000320520616274043, 0.000765639483270394, "2Error", + 1.00096014378277)) +}) + +test_that("L4 Traffic light chart matches", { + plotName <- results[["results"]][["trafficPlot"]][["collection"]][["trafficPlot_trafficPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 Traffic light chart") +}) + +test_that("L4 Components of variation plot matches", { + plotName <- results[["results"]][["varCompPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 components-of-variation") +}) + +test_that("L4 Variance Components table results match", { + table <- results[["results"]][["varCompTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.136171136634584, 1.08457861699851, 0.328512928494555, 0.64962130987885, + "Total gauge r&R", 0.100522980701193, 0.188389777677887, + 0.137871376665235, 0.0224366411670959, "Repeatability", 0.0194115194133937, + 0.943270181509932, 0.190641551829319, 0.648481519656201, "Reproducibility", + 0.0194115194133937, 0.943270181509932, 0.190641551829319, 0.648481519656201, + "Operator", "", "", 1.92148707150488, "", "Part-to-part", "", + "", 2.25, "", "Total variation")) +}) + +test_that("L4 Operator plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 operator") +}) + +test_that("L4 Repeatability plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 repeatability") +}) + +test_that("L4 Reproducibility plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Reproducibility"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 reproducibility") +}) + +test_that("L4 Total gauge r&R plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L4 total-gauge-r-r") +}) + +test_that("L4 Posterior Summary table results match", { + table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + jaspTools::expect_equal_tables(table, + list(6.08426523238411, 49.8077618247364, "Total gauge r&R", 15.0301360534277, + 4.50423780799053, 8.31507421356034, "Repeatability", 6.1266418829029, + 0.887272856100956, 41.8955809104603, "Reproducibility", 9.4272887180478, + 0.887272856100956, 41.8955809104603, "Operator", 9.4272887180478 + )) +}) + + +### report +test_that("L Gauge r&R report plot matches", { + options <- analysisOptions("msaBayesianGaugeRR") + options$measurementLongFormat <- "Dm" + options$operatorLongFormat <- "Operators" + options$partLongFormat <- "Parts" + options$tolerance <- TRUE + options$report <- TRUE + options$reportRChartByOperator <- TRUE + options$reportMeasurementsByOperatorPlot <- TRUE + options$reportAverageChartByOperator <- TRUE + options$reportPartByOperatorPlot <- TRUE + set.seed(1) + results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) + plotName <- results[["results"]][["report"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "L gauge-r-r-report") +}) + + + +## tests wide format +#local_snapshotter(snap_dir = "_snaps/msaBayesianGaugeRR/wide format/") +### automatic model selection & posterior on variances (generalized inverse Gaussian) +options <- analysisOptions("msaBayesianGaugeRR") +options$dataFormat <- "wideFormat" +options$measurementsWideFormat <- list("Measurement1", "Measurement2", "Measurement3") +options$operatorWideFormat <- "Operator" +options$partWideFormat <- "Part" +options$tolerance <- TRUE +options$priorPlot <- TRUE +options$posteriorPlot <- TRUE +options$posteriorPlotType <- "var" +options$posteriorHistogram <- TRUE +options$posteriorCi <- TRUE +options$contourPlot <- TRUE +options$contourLSL <- 5 +options$contourUSL <- 12 +options$rChart <- TRUE +options$xBarChart <- TRUE +options$scatterPlot <- TRUE +options$scatterPlotFitLine <- TRUE +options$scatterPlotOriginLine <- TRUE +options$partMeasurementPlot <- TRUE +options$partMeasurementPlotAllValues <- TRUE +options$operatorMeasurementPlot <- TRUE +options$partByOperatorMeasurementPlot <- TRUE +options$trafficLightChart <- TRUE +options$distType <- "gig" +set.seed(1) +results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) + + +test_that("W1 Model Comparison table results match", { + table <- results[["results"]][["BFtable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(92702680603773728, 0.00765529237919074, "Null model", 1, "", "Part + Operator + PartOperator", + 0.0121495135306725, 0.00886204496168727, "Part + Operator" + )) +}) + +test_that("W1 Contour plot wide matches", { + plotName <- results[["results"]][["contourPlot"]][["collection"]][["contourPlot_plot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 Contour plot wide") +}) + +test_that("W1 Producer's (δ) and Consumer's (β) Risk table results match", { + table <- results[["results"]][["contourPlot"]][["collection"]][["contourPlot_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.0264927749011355, 0.0787475031694541, "", 0.213793581986107, + 0.190669690866134, 0.310594648025299, "", 0.411549984734059 + )) +}) + +test_that("W1 % Contribution to Total Variation table results match", { + table <- results[["results"]][["contribTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(12.3269052367313, 33.9284976466776, "Total gauge r&R", 69.3587838257263, + 7.09756342908547, 19.8025194624623, "Repeatability", 35.5218633925746, + 1.91788890553919, 14.1259781842151, "Reproducibility", 56.2082001015145, + 1.91788890553919, 14.1259781842151, "Operator", 56.2082001015145, + 30.6412161742737, 66.0715023533227, "Part-to-part", 87.6730947632687, + "", 100, "Total variation", "")) +}) + +test_that("W1 Part by operator interaction plot matches", { + plotName <- results[["results"]][["gaugeByInteraction"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 part-by-operator-interaction") +}) + +test_that("W1 Measurements by operator plot matches", { + plotName <- results[["results"]][["gaugeByOperator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 measurements-by-operator") +}) + +test_that("W1 Measurements by part plot matches", { + plotName <- results[["results"]][["gaugeByPart"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 measurements-by-part") +}) + +test_that("W1 % Study Variation & % Tolerance table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_percStudyVarTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(35.1096922476569, 54.0297071548185, 57.0017393460991, 74.7495086161511, + "Total gauge r&R", 83.2819210724576, 140.230313974081, 26.6412521701421, + 47.452522327498, 43.6853564019964, 55.425842187894, "Repeatability", + 59.6002209628415, 64.9073776359718, 13.8487865812482, 18.6433631335287, + 34.2767972476711, 46.5139370842548, "Reproducibility", 74.9721282190718, + 128.70188362376, 13.8487865812482, 18.6433631335287, 34.2767972476711, + 46.5139370842548, "Operator", 74.9721282190718, 128.70188362376, + 55.3545084521765, 67.2003644717557, 80.6965158375164, 106.466816727854, + "Part-to-part", 93.6339119740239, 171.623834317457, "", 93.5117075742855, + 100, 132.14110254032, "Total variation", "", 203.977912189941 + )) +}) + +test_that("W1 Standard Deviation & Study Variation table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_stdTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.900495119246975, 5.40297071548185, 1.24582514360251, 7.47495086161507, + "Total gauge r&R", 2.33717189956802, 14.0230313974081, 0.790875372124967, + 4.7452522327498, 0.923764036464903, 5.5425842187894, "Repeatability", + 1.0817896272662, 6.49073776359718, 0.310722718892144, 1.86433631335287, + 0.775232284737573, 4.65139370842548, "Reproducibility", 2.14503139372934, + 12.870188362376, 0.310722718892144, 1.86433631335287, 0.775232284737573, + 4.65139370842548, "Operator", 2.14503139372934, 12.870188362376, + 1.12000607452926, 6.72003644717558, 1.77444694546422, 10.6466816727853, + "Part-to-part", 2.86039723862429, 17.1623834317457, 1.55852845957142, + 9.35117075742855, 2.20235170900533, 13.214110254032, "Total variation", + 3.39963186983235, 20.3977912189941)) +}) + +test_that("W1 Matrix plot for operators matches", { + plotName <- results[["results"]][["gaugeScatterOperators"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 matrix-plot-for-operators") +}) + +test_that("W1 Trace plot operators wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 Trace plot operators wide") +}) + +test_that("W1 Trace plot parts wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 Trace plot parts wide") +}) + +test_that("W1 Trace plot error wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_sig2"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 Trace plot error wide") +}) + +test_that("W1 Diagnostics table wide results match", { + table <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(11489.1632603585, 13677.1607176617, 0.0188803933569998, 0.0110455472900119, + 0.159912102522656, "2Part", 1.00004644044169, + 8946.79354696483, 9284.24667889662, 0.0525552167179807, 0.00142100662694245, + 0.197346171272066, "2Operator", + 0.999921535112366, 9627.27034873237, 12550.7045825935, 0.00141570326076179, + 0.00158112334408733, 0.00365958909245312, "2Error", + 1.00097355083603)) +}) + +test_that("W1 g-prior plot matches", { + plotName <- results[["results"]][["priorPlot"]][["collection"]][["priorPlot_plot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 g-prior") +}) + +test_that("W1 rChart wide matches", { + plotName <- results[["results"]][["rChart"]][["collection"]][["rChart_plot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 rChart wide") +}) + +test_that("W1 Test results for range chart table results match", { + table <- results[["results"]][["rChart"]][["collection"]][["rChart_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list("C", "Point 30")) +}) + +test_that("W1 Traffic light chart wide matches", { + plotName <- results[["results"]][["trafficPlot"]][["collection"]][["trafficPlot_trafficPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 Traffic light chart wide") +}) + +test_that("W1 Components of variation plot matches", { + plotName <- results[["results"]][["varCompPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 components-of-variation") +}) + +test_that("W1 Variance Components table results match", { + table <- results[["results"]][["varCompTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.810891459819477, 5.46237261253729, 1.78655246954848, 4.25598172544705, + "Total gauge r&R", 0.625483854562397, 1.17026879778004, + 0.858831277132578, 0.139329767865209, "Repeatability", 0.0965486080600336, + 4.6011597614014, 0.927721192415901, 4.24873211986627, "Reproducibility", + 0.0965486080600336, 4.6011597614014, 0.927721192415901, 4.24873211986627, + "Operator", 1.25441360896374, 8.18187264910991, 3.36535744263274, + 2.05016685602997, "Part-to-part", 2.42901096405622, 11.5574968504741, + 5.15190991218123, 4.71475336587418, "Total variation")) +}) + +test_that("W1 Error plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Error"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 error") +}) + +test_that("W1 Operator plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 operator") +}) + +test_that("W1 Part plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 part") +}) + +test_that("W1 Posterior Summary table results match", { + table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + jaspTools::expect_equal_tables(table, + list(1.27284283054443, 8.51804137015566, "2Part", + 3.3737108373, 0.098113661553187, 4.61971702790384, "2Operator", + 0.927748105326958, 0.623677008626749, 1.16560947901581, "2Error", + 0.858916283560981)) +}) + +test_that("W1 xBar chart wide matches", { + plotName <- results[["results"]][["xBarChart"]][["collection"]][["xBarChart_plot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W1 xBar chart wide") +}) + +test_that("W1 Test results for x-bar chart table results match", { + table <- results[["results"]][["xBarChart"]][["collection"]][["xBarChart_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list("A", "Point 1", "", "Point 5", "", "Point 8", "", "Point 10", + "B", "Point 11", "", "Point 15", "", "Point 18", "", "Point 20", + "C", "Point 21", "", "Point 23", "", "Point 25", "", "Point 30" + )) +}) + +### full model, autocorrelation plot & posterior on %study var (metalog fit) +options <- analysisOptions("msaBayesianGaugeRR") +options$dataFormat <- "wideFormat" +options$measurementsWideFormat <- list("Measurement1", "Measurement2", "Measurement3") +options$operatorWideFormat <- "Operator" +options$partWideFormat <- "Part" +options$estimationType <- "manual" +options$tolerance <- TRUE +options$posteriorPlot <- TRUE +options$posteriorPlotType <- "percStudyVar" +options$posteriorHistogram <- TRUE +options$posteriorCi <- TRUE +options$trafficLightChart <- TRUE +options$diagnosticsPlotType <- "autocor" +options$distType <- "metalog" +options$modelType <- "fullModel" +set.seed(1) +results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) + + +test_that("W2 Model Comparison table results match", { + table <- results[["results"]][["BFtable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(92702680603773728, 0.00765529237919074, "Null model", 1, "", "Part + Operator + PartOperator", + 0.0121495135306725, 0.00886204496168727, "Part + Operator" + )) +}) + +test_that("W2 % Contribution to Total Variation table results match", { + table <- results[["results"]][["contribTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(13.3778291589204, 36.1913295547785, "Total gauge r&R", 69.466346367937, + 6.54447642381507, 18.3197432349895, "Repeatability", 32.73935334103, + 4.02429567876643, 17.871586319789, "Reproducibility", 56.444856724105, + 1.82503213233058, 13.6051251659484, "Operator", 53.6866163018582, + 30.533653632063, 63.8086704452217, "Part-to-part", 86.6221708410796, + "", 100, "Total variation", "")) +}) + +test_that("W2 % Study Variation & % Tolerance table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_percStudyVarTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(36.5757146253627, 56.7656934104138, 58.9923979409587, 77.8390144712959, + "Total gauge r&R", 83.3464734120505, 138.841013897683, 25.582174090092, + 45.9144985156591, 42.0347378543699, 53.6837141943982, "Repeatability", + 57.218312728733, 62.9766489691705, 20.0606472250702, 27.8931683934347, + 39.9676499900152, 53.9870114150065, "Reproducibility", 75.1297913909348, + 126.892261568645, 13.5093748143594, 18.1862826792913, 33.6092783763241, + 46.0434055352073, "Operator", 73.2711510905113, 124.613898462338, + 55.2572651173971, 65.549306545672, 79.2720451566425, 105.353853521724, + "Part-to-part", 93.0710324521567, 175.700681171956, "", 94.5404823595808, + 100, 133.080812955375, "Total variation", "", 205.322828943223 + )) +}) + +test_that("W2 Standard Deviation & Study Variation table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_stdTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.946094890173563, 5.67656934104138, 1.29731690785493, 7.78390144712956, + "Total gauge r&R", 2.31401689829472, 13.8841013897683, 0.765241641927652, + 4.59144985156591, 0.89472856990664, 5.36837141943982, "Repeatability", + 1.04961081615284, 6.29766489691705, 0.464886139890577, 2.78931683934346, + 0.899783523583441, 5.39870114150067, "Reproducibility", 2.11487102614409, + 12.6892261568645, 0.303104711321522, 1.81862826792913, 0.767390092253462, + 4.60434055352075, "Operator", 2.07689830770563, 12.4613898462338, + 1.09248844242787, 6.5549306545672, 1.7558975586954, 10.5353853521724, + "Part-to-part", 2.92834468619927, 17.5700681171956, 1.57567470599301, + 9.45404823595808, 2.21801354925625, 13.3080812955376, "Total variation", + 3.42204714905372, 20.5322828943223)) +}) + +test_that("W2 Autocor plot operators wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 Autocor plot operators wide") +}) + +test_that("W2 Autocor plot parts wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 Autocor plot parts wide") +}) + +test_that("W2 Autocor plot inter wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Part:Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 Autocor plot inter wide") +}) + +test_that("W2 Autocor plot error wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_sig2"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 Autocor plot error wide") +}) + +test_that("W2 Diagnostics table wide results match", { + table <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(10713.5473264095, 13407.275608121, 0.0190269587098109, 0.0103036342722492, + 0.134655246165873, "2Part", 1.00019626284334, + 8693.66878281009, 9627.98196118723, 0.117006744102641, 0.00119814090722604, + 0.172676716849297, "2Operator", + 1.00027692390321, 2785.13714277183, 4772.44199873121, 0.00196487944719096, + 0.000824576247414721, 0.00886968674039701, "2PartOperator", + 1.00068074432022, 6957.81110299329, 10358.8045674784, 0.00158875487364865, + 0.00191146086502458, 0.00424397364874796, "2Error", + 1.00005531082368)) +}) + +test_that("W2 Traffic light chart wide matches", { + plotName <- results[["results"]][["trafficPlot"]][["collection"]][["trafficPlot_trafficPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 Traffic light chart wide") +}) + +test_that("W2 Components of variation plot matches", { + plotName <- results[["results"]][["varCompPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 components-of-variation") +}) + +test_that("W2 Variance Components table results match", { + table <- results[["results"]][["varCompTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.895095541218567, 5.35467421909935, 2.03563916421946, 13.36030351333, + "Total gauge r&R", 0.585594770562784, 1.1016828653987, 0.805784153180511, + 0.131825823292889, "Repeatability", 0.216119123075015, 4.47267980982418, + 1.22985501103896, 13.3556841019572, "Reproducibility", 0.0918724662796369, + 4.31350665542013, 1.04095448066503, 13.3531032948241, "Operator", + 1.1935309978082, 8.57520261358881, 3.30518987594095, 2.00879397541868, + "Part-to-part", 2.48275078237167, 11.7104066907196, 5.34082904016041, + 13.5126413089862, "Total variation")) +}) + +test_that("W2 Operator plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 operator") +}) + +test_that("W2 Part-to-part plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part-to-part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 part-to-part") +}) + +test_that("W2 Repeatability plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 repeatability") +}) + +test_that("W2 Reproducibility plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Reproducibility"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 reproducibility") +}) + +test_that("W2 Total gauge r&R plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W2 total-gauge-r-r") +}) + +test_that("W2 Posterior Summary table results match", { + table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + jaspTools::expect_equal_tables(table, + list(36.6908448164942, 84.640380749268, "Total gauge r&R", 59.0499639096235, + 25.5255275390376, 56.9200489576364, "Repeatability", 42.03575729992, + 20.0919962355863, 75.9155319105894, "Reproducibility", 39.996598338415, + 13.7729319889636, 73.7855331557218, "Operator", 33.6414451776228, + 53.9844930078528, 93.0486168370966, "Part-to-part", 79.2144723166527 + )) +}) + +### type 3, density diagnostics plot & posterior on %Tolerance (metalog fit) +options <- analysisOptions("msaBayesianGaugeRR") +options$dataFormat <- "wideFormat" +options$measurementsWideFormat <- list("Measurement1", "Measurement2", "Measurement3") +options$partWideFormat <- "Part" +options$type3 <- TRUE +options$tolerance <- TRUE +options$posteriorPlot <- TRUE +options$posteriorPlotType <- "percTol" +options$posteriorHistogram <- TRUE +options$posteriorCi <- TRUE +options$trafficLightChart <- TRUE +options$diagnosticsPlotType <- "density" +options$distType <- "metalog" +set.seed(1) +results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) + + +test_that("W3 Model Comparison table results match", { + table <- results[["results"]][["BFtable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(98096672972404490240, 3.49979418330506e-06, "Null model", 1, "", + "Part")) +}) + +test_that("W3 % Contribution to Total Variation table results match", { + table <- results[["results"]][["contribTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(8.83081567952286, 23.7598919702468, "Total gauge r&R", 41.8274496817367, + 8.83081567952286, 23.7598919702468, "Repeatability", 41.8274496817367, + 58.1725503182633, 76.2401080297539, "Part-to-part", 91.1691843204771, + "", 100, "Total variation", "")) +}) + +test_that("W3 % Study Variation & % Tolerance table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_percStudyVarTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(29.7166882611562, 48.0241014671239, 47.9003801961148, 55.9991052269221, + "Total gauge r&R", 64.6741445105543, 65.6920462384278, 29.7166882611562, + 48.0241014671239, 47.9003801961148, 55.9991052269221, "Repeatability", + 64.6741445105543, 65.6920462384278, 76.2709317618789, 67.5499445080692, + 87.1711025379854, 106.583932335271, "Part-to-part", 95.4825556392114, + 175.730879489471, "", 87.0869358486883, 100, 121.077346756447, + "Total variation", "", 184.656155967787)) +}) + +test_that("W3 Standard Deviation & Study Variation table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_stdTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.800401691118732, 4.80241014671239, 0.933318420448701, 5.5999105226922, + "Total gauge r&R", 1.09486743730713, 6.56920462384278, 0.800401691118732, + 4.80241014671239, 0.933318420448701, 5.5999105226922, "Repeatability", + 1.09486743730713, 6.56920462384278, 1.12583240846782, 6.75499445080692, + 1.77639887225451, 10.6583932335271, "Part-to-part", 2.92884799149119, + 17.5730879489471, 1.45144893081147, 8.70869358486883, 2.01795577927412, + 12.1077346756448, "Total variation", 3.07760259946311, 18.4656155967787 + )) +}) + +test_that("W3 Density plot type3 parts wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W3 Density plot type3 parts wide") +}) + +test_that("W3 Density plot type 3 error wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_sig2"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W3 Density plot type 3 error wide") +}) + +test_that("W3 Diagnostics table wide results match", { + table <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(11707.3772753072, 12898.8791981331, 0.018538497634247, 0.0117758505186677, + 0.133935146076606, "2Part", 0.999912218555296, + 10252.2089186134, 12928.747430743, 0.00140504193471408, 0.00203664967823852, + 0.00556308506257785, "2Error", + 0.999971878611095)) +}) + +test_that("W3 Traffic light chart wide matches", { + plotName <- results[["results"]][["trafficPlot"]][["collection"]][["trafficPlot_trafficPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W3 Traffic light chart wide") +}) + +test_that("W3 Components of variation plot matches", { + plotName <- results[["results"]][["varCompPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W3 components-of-variation") +}) + +test_that("W3 Variance Components table results match", { + table <- results[["results"]][["varCompTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.640642867591348, 1.19873470534066, 0.876622085936743, 0.141450061477036, + "Total gauge r&R", 0.640642867591348, 1.19873470534066, + 0.876622085936743, 0.141450061477036, "Repeatability", 1.26749861196421, + 8.57815073257154, 3.3707105788214, 1.97733245942888, "Part-to-part", + 2.106703999134, 9.47163777543298, 4.24733266475813, 1.98142724023979, + "Total variation")) +}) + +test_that("W3 Part-to-part plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part-to-part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W3 part-to-part") +}) + +test_that("W3 Repeatability plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W3 repeatability") +}) + +test_that("W3 Total gauge r&R plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W3 total-gauge-r-r") +}) + +test_that("W3 Total variation plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total variation"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W3 total-variation") +}) + +test_that("W3 Posterior Summary table results match", { + table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + jaspTools::expect_equal_tables(table, + list(48.1714882535499, 65.4777848056588, "Total gauge r&R", 55.9859173475586, + 48.1714882535499, 65.4777848056588, "Repeatability", 55.9859173475586, + 68.0697507873148, 173.397787709273, "Part-to-part", 106.53503836118, + 87.6024563014082, 182.690390900527, "Total variation", 121.01621390635 + )) +}) + +### historical SD & posterior on %Contribution (metalog) +options <- analysisOptions("msaBayesianGaugeRR") +options$dataFormat <- "wideFormat" +options$measurementsWideFormat <- list("Measurement1", "Measurement2", "Measurement3") +options$operatorWideFormat <- "Operator" +options$partWideFormat <- "Part" +options$processVariationReference <- "historicalSd" +options$historicalSdValue <- 1.5 +options$tolerance <- TRUE +options$posteriorPlot <- TRUE +options$posteriorPlotType <- "percContrib" +options$posteriorHistogram <- TRUE +options$posteriorCi <- TRUE +options$trafficLightChart <- TRUE +options$diagnosticsPlotType <- "density" +options$distType <- "metalog" +set.seed(1) +results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) + + +test_that("W4 Model Comparison table results match", { + table <- results[["results"]][["BFtable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(92702680603773728, 0.00765529237919074, "Null model", 1, "", "Part + Operator + PartOperator", + 0.0121495135306725, 0.00886204496168727, "Part + Operator" + )) +}) + +test_that("W4 % Contribution to Total Variation table results match", { + table <- results[["results"]][["contribTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(36.0396204364212, 79.4023319799323, "Total gauge r&R", 242.772116112769, + 27.7992824249954, 38.1702789836703, "Repeatability", 52.0119465680019, + 4.29104924711261, 41.2320529962621, "Reproducibility", 204.495989395618, + 4.29104924711261, 41.2320529962621, "Operator", 204.495989395618, + "", 20.5976680200604, "Part-to-part", "", "", 100, "Total variation", + "")) +}) + +test_that("W4 % Study Variation & % Tolerance table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_percStudyVarTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(60.0330079497983, 54.0297071548185, 83.0550095735007, 74.7495086161511, + "Total gauge r&R", 155.811459971201, 140.230313974081, 52.7250248083311, + 47.452522327498, 61.5842690976603, 55.425842187894, "Repeatability", + 72.1193084844131, 64.9073776359718, 20.714847926143, 18.6433631335287, + 51.6821523158386, 46.5139370842548, "Reproducibility", 143.002092915289, + 128.70188362376, 20.714847926143, 18.6433631335287, 51.6821523158386, + 46.5139370842548, "Operator", 143.002092915289, 128.70188362376, + "", "", 45.3846538161075, 40.846188434481, "Part-to-part", "", + "", "", "", 100, 90, "Total variation", "", "")) +}) + +test_that("W4 Standard Deviation & Study Variation table results match", { + table <- results[["results"]][["gaugeEvaluation"]][["collection"]][["gaugeEvaluation_stdTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.900495119246975, 5.40297071548185, 1.24582514360251, 7.47495086161507, + "Total gauge r&R", 2.33717189956802, 14.0230313974081, 0.790875372124967, + 4.7452522327498, 0.923764036464903, 5.5425842187894, "Repeatability", + 1.0817896272662, 6.49073776359718, 0.310722718892144, 1.86433631335287, + 0.775232284737573, 4.65139370842548, "Reproducibility", 2.14503139372934, + 12.870188362376, 0.310722718892144, 1.86433631335287, 0.775232284737573, + 4.65139370842548, "Operator", 2.14503139372934, 12.870188362376, + "", "", 0.680769807241364, 4.08461884344987, "Part-to-part", + "", "", "", "", 1.5, 9, "Total variation", "", "")) +}) + +test_that("W4 Density plot histSd operators wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 Density plot histSd operators wide") +}) + +test_that("W4 Density plot histSd parts wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_g_Part"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 Density plot histSd parts wide") +}) + +test_that("W4 Density plot histSd error wide matches", { + plotName <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_sig2"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 Density plot histSd error wide") +}) + +test_that("W4 Diagnostics table wide results match", { + table <- results[["results"]][["mcmcDiagnostics"]][["collection"]][["mcmcDiagnostics_table"]][["data"]] + jaspTools::expect_equal_tables(table, + list(11489.1632603585, 13677.1607176617, 0.0188803933569998, 0.0110455472900119, + 0.159912102522656, "2Part", 1.00004644044169, + 8946.79354696483, 9284.24667889662, 0.0525552167179807, 0.00142100662694245, + 0.197346171272066, "2Operator", + 0.999921535112366, 9627.27034873237, 12550.7045825935, 0.00141570326076179, + 0.00158112334408733, 0.00365958909245312, "2Error", + 1.00097355083603)) +}) + +test_that("W4 Traffic light chart wide matches", { + plotName <- results[["results"]][["trafficPlot"]][["collection"]][["trafficPlot_trafficPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 Traffic light chart wide") +}) + +test_that("W4 Components of variation plot matches", { + plotName <- results[["results"]][["varCompPlot"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 components-of-variation") +}) + +test_that("W4 Variance Components table results match", { + table <- results[["results"]][["varCompTable"]][["data"]] + jaspTools::expect_equal_tables(table, + list(0.810891459819477, 5.46237261253729, 1.78655246954848, 4.25598172544705, + "Total gauge r&R", 0.625483854562397, 1.17026879778004, + 0.858831277132578, 0.139329767865209, "Repeatability", 0.0965486080600336, + 4.6011597614014, 0.927721192415901, 4.24873211986627, "Reproducibility", + 0.0965486080600336, 4.6011597614014, 0.927721192415901, 4.24873211986627, + "Operator", "", "", 0.463447530451708, "", "Part-to-part", "", + "", 2.25, "", "Total variation")) +}) + +test_that("W4 Operator plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 operator") +}) + +test_that("W4 Repeatability plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 repeatability") +}) + +test_that("W4 Reproducibility plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Reproducibility"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 reproducibility") +}) + +test_that("W4 Total gauge r&R plot matches", { + plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W4 total-gauge-r-r") +}) + +test_that("W4 Posterior Summary table results match", { + table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + jaspTools::expect_equal_tables(table, + list(36.2684396989805, 246.249732595721, "Total gauge r&R", 79.4194770714244, + 28.0791556215122, 51.6892435406356, "Repeatability", 38.1493514877285, + 4.43965092830744, 196.978472951731, "Reproducibility", 42.7178342722391, + 4.43965092830744, 196.978472951731, "Operator", 42.7178342722391 + )) +}) + +### report +test_that("W Gauge r&R report plot matches", { + options <- analysisOptions("msaBayesianGaugeRR") + options$dataFormat <- "wideFormat" + options$measurementsWideFormat <- list("Measurement1", "Measurement2", "Measurement3") + options$operatorWideFormat <- "Operator" + options$partWideFormat <- "Part" + options$tolerance <- TRUE + options$report <- TRUE + options$reportRChartByOperator <- TRUE + options$reportMeasurementsByOperatorPlot <- TRUE + options$reportAverageChartByOperator <- TRUE + options$reportPartByOperatorPlot <- TRUE + set.seed(1) + results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) + plotName <- results[["results"]][["report"]][["data"]] + testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] + jaspTools::expect_equal_plots(testPlot, "W gauge-r-r-report") +}) From 3a3d07cebc52d3327834883f33fd92ad51a0f924 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 1 Jul 2025 17:52:38 +0200 Subject: [PATCH 25/65] Help file & minor fixes 1) adding help file 2) updating dependencies and functionality of r&R table checkbox in the code 3) code clean-up 4) updating unit tests --- R/msaBayesianGaugeRR.R | 35 +++---- inst/help/msaBayesianGaugeRR.md | 118 +++++++++++++++++++++++ tests/testthat/test-msaBayesianGaugeRR.R | 2 + 3 files changed, 132 insertions(+), 23 deletions(-) create mode 100644 inst/help/msaBayesianGaugeRR.md diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index d26c85ec..6448c0d2 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -120,7 +120,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # Model comparison table - if(options[["RRTable"]] && !options$report){ # I should probably add && !report here + if(options[["RRTable"]] && !options$report){ .createBFtable(jaspResults, dataset, options, measurements, parts, operators, ready) } @@ -137,16 +137,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .getPercTol(jaspResults, options) } - errorOccurred <- FALSE - distFit <- tryCatch( - { - .fitDistToSamples(jaspResults, options) - }, - error = function(e) { - errorOccurred <<- TRUE - return(e$message) - } - ) + # fit distribution to samples + .fitDistToSamples(jaspResults, options) } # insert report here @@ -154,14 +146,16 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .createGaugeReport(jaspResults, dataset, measurements, parts, operators, options, ready) } else { - # Variance components table - .createVarCompTable(jaspResults, parts, operators, ready, options) + if(options$RRTable) { + # Variance components table + .createVarCompTable(jaspResults, parts, operators, ready, options) - # % Contribution to total variation table - .createPercContribTable(jaspResults, options, parts, operators, ready) + # % Contribution to total variation table + .createPercContribTable(jaspResults, options, parts, operators, ready) - # Gauge evaluation table - .createGaugeEval(jaspResults, parts, operators, options, ready) + # Gauge evaluation table + .createGaugeEval(jaspResults, parts, operators, options, ready) + } # prior if(ready && options$priorPlot) { @@ -182,11 +176,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # summary table .createPostSummaryTable(jaspResults, options, parts, operators) - - if(errorOccurred) { - jaspResults[["variancePosteriors"]][["postSummary"]]$setError(distFit) - return() - } } if(ready && options$varianceComponentsGraph) { @@ -758,7 +747,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference", - "estimationType", "modelType", "report", "type3")) + "estimationType", "modelType", "report", "type3", "RRTable")) } .mcmcDependencies <- function() { diff --git a/inst/help/msaBayesianGaugeRR.md b/inst/help/msaBayesianGaugeRR.md new file mode 100644 index 00000000..576feecb --- /dev/null +++ b/inst/help/msaBayesianGaugeRR.md @@ -0,0 +1,118 @@ +Bayesian Gauge r&R +========================== +Gauge Repeatability and Reproducibility (Gauge R & R) is an analysis aimed at defining the amount of variation in measurements given a measurement system. +The variation detected in the measurement is sourced in two factors, repeatability (equipment variation) and reproducibility (operator variation). +This analysis offers a Bayesian implementation of Gauge R & R. + +## Input +### Data Format +------- +Data can be in the form of all observations in one column ("Single column") or across rows with a subgroup index ("Across rows"). + +### Assignment Box +- Operators: the operators in the measurement system. +- Parts: the parts of the measurement system. +- Measurements: the observations/data collected from a process. + +### Gauge r&R Method +The method used in the analysis. +- Linear random effects model: The analysis is based on a linear random effects model, also called random effects ANOVA (for more information about the model, see Rouder et al., 2012). + +### Options +#### Analysis options +- Estimation: either automatic based on a cut-off Bayes factor (BF) or a manual choice between main effects only or full model. +- Cut-off BF: cut-off for the BF in favor of the full model that needs to be reached for the full model to be chosen over the model only including main effects in automatic estimation. +- Process variation reference: either a historically known standard deviation (Historical standard deviation) or estimated from the data (Study variation). +- Tolerance: include a value for tolerance. +- r&R table options: + - Study Var. multiplier type: multiplier based on either Std. Deviation or Percent. + - Study Var. multiplier value: value for the multiplier. + +#### Plots +- Prior: g-prior used in the analysis. +- Posterior: posterior distribution on variances, %Contribution, %Study variation or %Tolerance + - Display histogram: plot histogram of Markov Chain Monte Carlo (MCMC) samples. + - Point estimate: display posterior mean, median or mode. + - CI: display central, highest posterior density or custom credible interval. + - Mass: percentage of posterior mass that the credible interval covers. For custom intervals, bounds can be specified. +- Contour plot: 95% contour of a multivariate normal distribution based on sample measurement mean and average posterior part and total variation (Mader et al., 1999). +- Components of variation: bar chart for components of variation with 95% credible intervals. +- Range charts by operator: control chart on the range. +- Average chart by operator: control chart on the mean. +- Scatter plots by operators: scatterplot matrix for operators. +- Measurements by part plot: average measurement for each part. + - Display all measurements: individual measurements are shown. +- Measurements by operator plot: boxplots of measurements by operator. +- Part x operator interaction plot: average measurement for each part with separate lines for operators. +- Traffic light chart: traffic light plots for %Study variation and %Tolerance with 95% credible intervals. + +#### MCMC diagnostics +- Diagnostics table: table with statistics. +- Plots: diagnostic plots. + - Traceplot + - Autocorrelation + - Density + +#### Advanced options +- Priors + - r scale prior: square root of the scale for the inverse chi-square g-prior. +- MCMC options + - Chains: number of MCMC chains to run. + - Iterations per chain: iterations for each chain. + - Burn-in per chain: number of initial samples discarded from each chain. +- Repeatability + - Set seed: specify seed to keep results constant. +- Distribution fit to MCMC samples: distritbution that is fit to the MCMC samples for the posterior plots. + - For variance posteriors, either a generalized inverse Gaussian or a metalog distribution. + - For all other posteriors, the metalog is used. + +#### Report options +- Create a gauge R & R report. + +## Output +------- +- Model Comparison: + - BF10: shows the Bayes factor in favor of the full model compared to the model in each row. + - error %: percent error in BF estimation. +- Variance Components: + - Mean: posterior mean + - Std. Deviation: standard deviation of the posterior distribution. +- % Contribution to Total Variation: posterior summaries for percent contribution of each component to the total variation. +- Standard Deviation & Study Variation: posterior summaries for standard deviations and study variation. +- % Study variation & % Tolerance: posterior summaries for percent of study variation and tolerance. +- MCMC diagnostics: + - ESS (Bulk): effective sample size in the bulk of the distribution. + - ESS (Tail): effective sample size in the tails of the distribution. + - Rhat: convergence diagnostic that compares between- to within-chain variance. Values larger than 1.01 indicate potential problems (Vehtari et al., 2021). + - MCSE: markov chain standard error for the estimator indicated in parentheses. +- Posterior distributions + - Posterior Summary: posterior summaries based on the distribution fit to the MCMC samples. +- Contour plot: posterior summaries for producer's and consumer's risk. + +## References +------- +- Duncan, A.J. (1986), Quality control and industrial statistics, Richard D. Irwin, Inc., and Automotive Industry Action Group (July 2005), Statistical process control (SPC) – Reference manual, AIAG. +- Dodson, B., Lynch, D., Weidenbacher, M., & Klerx, R. (2009). *Statistical process control handbook*. SKF group. +- Mader, D. P., Prins, J., & Lampe, R. E. (1999). THE ECONOMIC EVIPACT OF MEASUREMENT ERROR. *Quality Engineering, 11*(4), 563–574. https://doi.org/10.1080/08982119908919276 +- Montgomery, D. C. (2013). *Introduction to statistical quality control* (7th ed.). John Wiley +& Sons. +- Rouder, J. N., Morey, R. D., Speckman, P. L., & Province, J. M. (2012). Default Bayes factors for ANOVA designs. *Journal of Mathematical Psychology, 56*(5), 356–374. https://doi.org/10.1016/j.jmp.2012.08.001 +- Stan Development Team. 2024. Stan Reference Manual, 2.36. https://mc-stan.org +- Vehtari, A., Gelman, A., Simpson, D., Carpenter, B., & Bürkner, P.-C. (2021). Rank-normalization, folding, and localization: An improved $\widehat{R}$ for assessing convergence of MCMC. *Bayesian Analysis, 16*(2). https://doi.org/10.1214/20-BA1221 + +## R Packages +------- +- jaspGraphs +- jaspBase +- ggplot2 +- tidyr +- BayesFactor +- ellipse +- mvtnorm +- rmetalog +- GeneralizedHyperbolic +- HDInterval +- extraDistr +- posterior +- rstan +- bayesplot \ No newline at end of file diff --git a/tests/testthat/test-msaBayesianGaugeRR.R b/tests/testthat/test-msaBayesianGaugeRR.R index 89df6e14..11260b4c 100644 --- a/tests/testthat/test-msaBayesianGaugeRR.R +++ b/tests/testthat/test-msaBayesianGaugeRR.R @@ -717,6 +717,7 @@ test_that("L Gauge r&R report plot matches", { options$operatorLongFormat <- "Operators" options$partLongFormat <- "Parts" options$tolerance <- TRUE + options$posteriorPlotType <- "var" options$report <- TRUE options$reportRChartByOperator <- TRUE options$reportMeasurementsByOperatorPlot <- TRUE @@ -1443,6 +1444,7 @@ test_that("W Gauge r&R report plot matches", { options$operatorWideFormat <- "Operator" options$partWideFormat <- "Part" options$tolerance <- TRUE + options$posteriorPlotType <- "var" options$report <- TRUE options$reportRChartByOperator <- TRUE options$reportMeasurementsByOperatorPlot <- TRUE From 6b1491c1e7a91bff606a944ea3d5aa2ec6f8d401 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 2 Jul 2025 14:48:07 +0200 Subject: [PATCH 26/65] Clean-up & update unit tests --- R/msaBayesianGaugeRR.R | 1702 +++++++++++----------- tests/testthat/test-msaBayesianGaugeRR.R | 2 +- 2 files changed, 843 insertions(+), 861 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 6448c0d2..3f499a79 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -61,8 +61,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } } - saveRDS(dataset, "/Users/julian/Documents/Jasp files/dataset.rds") - # Checking for infinity and missingValues .hasErrors(dataset, type = c('infinity', 'missingValues'), infinity.target = measurements, @@ -108,12 +106,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(gettextf("The measurements selected seem to be in a 'Single Column' format as every operator's part is measured %d times.", partsLength/partsLevels))}, exitAnalysisIfErrors = FALSE) - - saveRDS(options, "/Users/julian/Documents/Jasp files/options.rds") - saveRDS(measurements, "/Users/julian/Documents/Jasp files/measurements.rds") - saveRDS(operators, "/Users/julian/Documents/Jasp files/operators.rds") - saveRDS(parts, "/Users/julian/Documents/Jasp files/parts.rds") - # Results from model comparison if(ready){ .runBFtest(jaspResults, dataset, measurements, parts, operators, options) @@ -222,10 +214,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } - - - - +#### Tables .createBFtable <- function(jaspResults, dataset, options, measurements, parts, operators, ready) { if(!is.null(jaspResults[["BFtable"]])) { return() @@ -250,74 +239,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.runBFtest <- function(jaspResults, dataset, measurements, parts, operators, options) { - if(is.null(jaspResults[["modelComparison"]])) { - modelComparison <- createJaspState() - modelComparison$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior")) - jaspResults[["modelComparison"]] <- modelComparison - } else { - return() - } - - if(options$setSeed) { - set.seed(options$seed) - } - - if(options$type3){ - formula <- as.formula(paste(measurements, "~", parts)) - bfFit <- BayesFactor::generalTestBF(formula, data = dataset, - whichRandom = c(operators, parts), - rscaleRandom = options$rscalePrior, - progress = FALSE) - bfDf <- as.data.frame(bfFit) - full <- parts - bfFullNull <- bfDf$bf - - } else { - formula <- as.formula(paste(measurements, "~", parts, "*", operators)) - - # run general comparison for all potential models - bfFit <- BayesFactor::generalTestBF(formula, data = dataset, - whichRandom = c(operators, parts), - rscaleRandom = options$rscalePrior, - progress = FALSE) - bfDf <- as.data.frame(bfFit) - - # extract full model and model with only main effects - main <- paste(parts, "+", operators) - full <- paste0(parts, " + ", operators, " + ", parts, ":", operators) - bfDf <- bfDf[c(main, full), ] - - bfFullNull <- bfDf[full, ]$bf - } - - # dropping unnecessary columns - bfDf <- bfDf[, !colnames(bfDf) %in% c("time", "code")] - - # obtain BF comparing full model to other models - bfDf$bf <- bfFullNull / bfDf$bf - - # add null model - bfDf["Null model", ] <- c(bfFullNull, - bfDf[full, ]$error) - - bfDf[full, ]$error <- "" - - # add model names & change colnames - colnames(bfDf) <- c("comparisonBF", "error") - bfDf$modelName <- rownames(bfDf) - if(!options$type3) { - bfDf$modelName <- jaspBase::gsubInteractionSymbol(bfDf$modelName) - } - - bfDf <- bfDf[order(-bfDf$comparisonBF), ] - - jaspResults[["modelComparison"]][["object"]] <- bfDf - - return() -} - .createVarCompTable <- function(jaspResults, parts, operators, ready, options) { if(!is.null(jaspResults[["varCompTable"]])) { return() @@ -376,248 +297,200 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.runMCMC <- function(jaspResults, dataset, measurements, parts, operators, options){ - if(is.null(jaspResults[["MCMCsamples"]])){ - MCMCsamples <- createJaspState() - MCMCsamples$dependOn(.mcmcDependencies()) - jaspResults[["MCMCsamples"]] <- MCMCsamples - } else { +.createPostSummaryTable <- function(jaspResults, options, parts, operators){ + if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]])){ return() } - if(!options$type3){ - # obtain BF in favor of full over main effects model - excludeInter <- .evalInter(jaspResults, parts, operators, options) - if(excludeInter){ - formula <- as.formula(paste(measurements, "~", parts, "+", operators)) - } else { - formula <- as.formula(paste(measurements, "~", parts, "*", operators)) - } - # fit the model with BayesFactor - fit <- BayesFactor::lmBF(formula, whichRandom = c(parts, operators), - data = dataset, rscaleRandom = options$rscalePrior) - } else { - formula <- as.formula(paste(measurements, "~", parts)) - fit <- BayesFactor::lmBF(formula, whichRandom = parts, - data = dataset, rscaleRandom = options$rscalePrior) - } + postSummary <- createJaspTable(title = gettext("Posterior Summary")) + postSummary$position <- 1 + postSummary$dependOn(c(.varCompTableDependencies(), + .postPlotDependencies())) - nchains <- options$mcmcChains - burnin <- options$mcmcBurnin - iter <- options$mcmcIterations + jaspResults[["variancePosteriors"]][["postSummary"]] <- postSummary - # get relevant parameters - paramNames <- .bfParameterNames(parts, operators, excludeInter, options) - paramNames <- c(paramNames, "sig2") + # title for point estimate + pointEst <- switch (options$posteriorPointEstimateType, + "mean" = "Mean", + "mode" = "Mode", + "median" = "Median" + ) - # initiate array - mcmcArray <- array(dim = c(iter - burnin, nchains, length(paramNames))) + # overtitle for CrI + if(options$posteriorCiType == "central" || options$posteriorCiType == "HPD") { + mass <- round(options$posteriorCiMass * 100) + } - if(options$setSeed) { - set.seed(options$seed) + if(options$posteriorCiType == "custom") { + mass <- round((options$posteriorCiUpper - options$posteriorCiLower) * 100) } - for(i in 1:nchains) { - # run chain - mcmcChain <- BayesFactor::posterior(fit, iterations = iter) + overtitle <- paste0(mass, "% ", "Credible Interval") - # select subset - mcmcChain <- as.matrix(mcmcChain) - mcmcChain <- mcmcChain[, paramNames] - # discard burnin - mcmcChain <- mcmcChain[-(1:burnin), ] + postSummary$addColumnInfo(name = "parameter", title = gettext("Source"), type = "string") - # revert standardization - for(j in paramNames[paramNames != "sig2"]) { - mcmcChain[, j] <- mcmcChain[, j] * mcmcChain[, "sig2"] - } + if(options$posteriorPointEstimate) { + postSummary$addColumnInfo(name = "pointEstimate", title = gettext(pointEst), type = "number") + } - mcmcArray[, i, ] <- mcmcChain + if(options$posteriorCi) { + postSummary$addColumnInfo(name = "ciLower", title = gettext("Lower"), type = "number", overtitle = gettext(overtitle)) + postSummary$addColumnInfo(name = "ciUpper", title = gettext("Upper"), type = "number", overtitle = gettext(overtitle)) + postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) } - dimnames(mcmcArray) <- list(NULL, NULL, paramNames) - MCMCsamples[["object"]] <- mcmcArray + postSummary$setData(jaspResults[["postSummaryStats"]][["object"]]) return() } +.createGaugeEval <- function(jaspResults, parts, operators, options, ready) { + if(!is.null(jaspResults[["gaugeEvaluation"]])) { + return() + } -.getVarianceComponents <- function(jaspResults, parts, operators, options) { - excludeInter <- .evalInter(jaspResults, parts, operators, options) + gaugeEvaluation <- createJaspContainer(title = gettext("Gauge Evaluation")) + gaugeEvaluation$position <- 4 + gaugeEvaluation$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue", + "tolerance", "toleranceValue")) + jaspResults[["gaugeEvaluation"]] <- gaugeEvaluation - # get components from MCMC samples - internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + ### Standard deviation & study variation table + stdTable <- createJaspTable(title = gettext("Standard Deviation & Study Variation")) + stdTable$position <- 1 + gaugeEvaluation[["stdTable"]] <- stdTable - # calculate summary stats - postMeans <- colMeans(internalDF) - postSds <- apply(internalDF, 2, sd) - postCrIlower <- apply(internalDF, 2, quantile, probs = 0.025) - postCrIupper <- apply(internalDF, 2, quantile, probs = 0.975) + stdTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + stdTable$addColumnInfo(name = "meansStd", title = gettext("Mean
Std"), type = "number") + stdTable$addColumnInfo(name = "lowerStd", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
Std") + stdTable$addColumnInfo(name = "upperStd", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
Std") + stdTable$addColumnInfo(name = "meansStudyVar", title = gettext("Mean
Study Variation"), type = "number") + stdTable$addColumnInfo(name = "lowerStudyVar", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
Study Variation") + stdTable$addColumnInfo(name = "upperStudyVar", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
Study Variation") - # remove some stats when historicalSd is specified - if(options$processVariationReference == "historicalSd"){ - postSds["part"] <- "" - postSds["total"] <- "" - postCrIlower["part"] <- "" - postCrIlower["total"] <- "" - postCrIupper["part"] <- "" - postCrIupper["total"] <- "" - } - sourceName <- .sourceNames(options) + if(ready) { + stdData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "sd") + colnames(stdData) <- c("sourceName", "meansStd", "lowerStd", "upperStd") # note: this could already be part of the function + studyVarData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")[, -1] # remove source name + colnames(studyVarData) <- c("meansStudyVar", "lowerStudyVar", "upperStudyVar") + stdTable$setData(cbind(stdData, studyVarData)) - return(data.frame(sourceName, - postMeans, - postSds, - postCrIlower, - postCrIupper) - ) -} + stdTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) + # number of distinct categories + nDistinct <- .getDistinctCategories(jaspResults, parts, operators, options) + stdTable$addFootnote(gettext(paste("Number of distinct categories:", nDistinct))) + } + ### Percent study variation & percent tolerance table + if(options$tolerance) { + title <- "% Study Variation & % Tolerance" + } else { + title <- "% Study Variation" + } + percStudyVarTable <- createJaspTable(title = gettext(title)) + percStudyVarTable$position <- 2 + gaugeEvaluation[["percStudyVarTable"]] <- percStudyVarTable -.evalInter <- function(jaspResults, parts, operators, options) { - if(options$estimationType == "automatic") { - bfDf <- jaspResults[["modelComparison"]][["object"]] - main <- paste(parts, "+", operators) + percStudyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + percStudyVarTable$addColumnInfo(name = "meansPercStudy", title = gettext("Mean
% Study Variation"), type = "number") + percStudyVarTable$addColumnInfo(name = "lowerPercStudy", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
% Study Variation") + percStudyVarTable$addColumnInfo(name = "upperPercStudy", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
% Study Variation") - excludeInter <- bfDf[main, ]$comparisonBF <= options$bfFavorFull + if(options$tolerance) { + percStudyVarTable$addColumnInfo(name = "meansPercTol", title = gettext("Mean
% Tolerance"), type = "number") + percStudyVarTable$addColumnInfo(name = "lowerPercTol", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
% Tolerance") + percStudyVarTable$addColumnInfo(name = "upperPercTol", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
% Tolerance") } - if(options$estimationType == "manual"){ - if(options$modelType == "fullModel"){ - excludeInter <- FALSE - } + if(ready) { + percStudyData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percStudyVar") + colnames(percStudyData) <- c("sourceName", "meansPercStudy", "lowerPercStudy", "upperPercStudy") - if(options$modelType == "mainEffectsOnly"){ - excludeInter <- TRUE + if(!options$tolerance) { + percStudyVarTable$setData(percStudyData) + } else { + percTolData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percTol")[, -1] + colnames(percTolData) <- c("meansPercTol", "lowerPercTol", "upperPercTol") + percStudyVarTable$setData(cbind(percStudyData, percTolData)) } + percStudyVarTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) } - return(excludeInter) + return() } -.getComponentsFromSamples <- function(jaspResults, parts, operators, options, excludeInter){ - # note this could be written into a helper function - sigmaPart <- paste0("g_", parts) - sigmaOperator <- paste0("g_", operators) - sigmaInter <- paste0("g_", parts, ":", operators) - - samplesMat <- .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]) - samplesMat <- as.matrix(samplesMat) - saveRDS(samplesMat, "/Users/julian/Documents/Jasp files/samplesMat.rds") - - repeatability <- samplesMat[, "sig2"] - part <- samplesMat[, sigmaPart] - if(!options$type3) { - # obtain relevant components - if(excludeInter){ - reprod <- samplesMat[, sigmaOperator] - } else { - reprod <- samplesMat[, sigmaOperator] + samplesMat[, sigmaInter] - } - gauge <- reprod + repeatability - operator <- samplesMat[, sigmaOperator] +.runBFtest <- function(jaspResults, dataset, measurements, parts, operators, options) { + if(is.null(jaspResults[["modelComparison"]])) { + modelComparison <- createJaspState() + modelComparison$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior")) + jaspResults[["modelComparison"]] <- modelComparison } else { - gauge <- repeatability - } - total <- gauge + part - - # replace total variation with historical variance and adjust - # part variation accordingly - if(options$processVariationReference == "historicalSd"){ - totalOld <- mean(total) - total <- rep(options$historicalSdValue^2, length(repeatability)) - diffTotals <- total - totalOld - part <- mean(part) + diffTotals + return() } - if(!options$type3) { - internalDF <- data.frame(gauge, - repeatability, - reprod, - operator, - part, - total - ) - } else { - internalDF <- data.frame(gauge, - repeatability, - part, - total) + if(options$setSeed) { + set.seed(options$seed) } - return(internalDF) -} - -.getDistinctCategories <- function(jaspResults, parts, operators, options) { - excludeInter <- .evalInter(jaspResults, parts, operators, options) - internalDf <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) - - # subset with relevant variables - internalDf <- internalDf[, colnames(internalDf) %in% c("gauge", "part")] - sdDf <- sqrt(internalDf) - - # number distinct categories - nCat <- (sdDf$part / sdDf$gauge) * 1.41 - mean <- mean(nCat) - lower <- quantile(nCat, probs = 0.025) - upper <- quantile(nCat, probs = 0.975) - - # for footnote and report - res <- paste0(round(mean, 2), " (", round(lower, 2), ", ", round(upper, 2), ")") - - return(res) -} -.createPostSummaryTable <- function(jaspResults, options, parts, operators){ - if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]])){ - return() - } + if(options$type3){ + formula <- as.formula(paste(measurements, "~", parts)) + bfFit <- BayesFactor::generalTestBF(formula, data = dataset, + whichRandom = c(operators, parts), + rscaleRandom = options$rscalePrior, + progress = FALSE) + bfDf <- as.data.frame(bfFit) + full <- parts + bfFullNull <- bfDf$bf - postSummary <- createJaspTable(title = gettext("Posterior Summary")) - postSummary$position <- 1 - postSummary$dependOn(c(.varCompTableDependencies(), - .postPlotDependencies())) + } else { + formula <- as.formula(paste(measurements, "~", parts, "*", operators)) - jaspResults[["variancePosteriors"]][["postSummary"]] <- postSummary + # run general comparison for all potential models + bfFit <- BayesFactor::generalTestBF(formula, data = dataset, + whichRandom = c(operators, parts), + rscaleRandom = options$rscalePrior, + progress = FALSE) + bfDf <- as.data.frame(bfFit) - # title for point estimate - pointEst <- switch (options$posteriorPointEstimateType, - "mean" = "Mean", - "mode" = "Mode", - "median" = "Median" - ) + # extract full model and model with only main effects + main <- paste(parts, "+", operators) + full <- paste0(parts, " + ", operators, " + ", parts, ":", operators) + bfDf <- bfDf[c(main, full), ] - # overtitle for CrI - if(options$posteriorCiType == "central" || options$posteriorCiType == "HPD") { - mass <- round(options$posteriorCiMass * 100) + bfFullNull <- bfDf[full, ]$bf } - if(options$posteriorCiType == "custom") { - mass <- round((options$posteriorCiUpper - options$posteriorCiLower) * 100) - } + # dropping unnecessary columns + bfDf <- bfDf[, !colnames(bfDf) %in% c("time", "code")] - overtitle <- paste0(mass, "% ", "Credible Interval") + # obtain BF comparing full model to other models + bfDf$bf <- bfFullNull / bfDf$bf + # add null model + bfDf["Null model", ] <- c(bfFullNull, + bfDf[full, ]$error) - postSummary$addColumnInfo(name = "parameter", title = gettext("Source"), type = "string") + bfDf[full, ]$error <- "" - if(options$posteriorPointEstimate) { - postSummary$addColumnInfo(name = "pointEstimate", title = gettext(pointEst), type = "number") + # add model names & change colnames + colnames(bfDf) <- c("comparisonBF", "error") + bfDf$modelName <- rownames(bfDf) + if(!options$type3) { + bfDf$modelName <- jaspBase::gsubInteractionSymbol(bfDf$modelName) } - if(options$posteriorCi) { - postSummary$addColumnInfo(name = "ciLower", title = gettext("Lower"), type = "number", overtitle = gettext(overtitle)) - postSummary$addColumnInfo(name = "ciUpper", title = gettext("Upper"), type = "number", overtitle = gettext(overtitle)) - postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) - } + bfDf <- bfDf[order(-bfDf$comparisonBF), ] - postSummary$setData(jaspResults[["postSummaryStats"]][["object"]]) + jaspResults[["modelComparison"]][["object"]] <- bfDf return() } - +#### Plots .createContourPlot <- function(jaspResults, parts, operators, measurements, dataset, options) { if(!is.null(jaspResults[["contourPlot"]])) { return() @@ -702,103 +575,551 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -#### helper functions -.bfParameterNames <- function(parts, operators, excludeInter, options) { - sigmaPart <- paste0("g_", parts) - sigmaOperator <- paste0("g_", operators) - sigmaInter <- paste0("g_", parts, ":", operators) - - if(!options$type3) { - if(excludeInter) { - res <- c(sigmaPart, sigmaOperator) - } else { - res <- c(sigmaPart, sigmaOperator, sigmaInter) - } - } else { - res <- sigmaPart +.plotPrior <- function(jaspResults, options) { + if(!is.null(jaspResults[["priorPlot"]])) { + return() } - return(res) -} + priorPlot <- createJaspContainer(title = gettext("Prior Distribution")) + priorPlot$position <- 5 + priorPlot$dependOn(c("rscalePrior", "report")) + jaspResults[["priorPlot"]] <- priorPlot -.sourceNames <- function(options) { - if(options$type3) { - res <- c("Total gauge r&R", - "Repeatability", - "Part-to-part", - "Total variation") - } else { - res <- c("Total gauge r&R", - "Repeatability", - "Reproducibility", - "Operator", - "Part-to-part", - "Total variation") - } + gPrior <- createJaspPlot(title = gettext("g-prior"), width = 600, height = 320) - return(res) -} + # axis limit + xUpper <- extraDistr::qinvchisq(0.75, nu = 1, tau = options$rscalePrior^2) + xBreaks <- jaspGraphs::getPrettyAxisBreaks(c(0, xUpper)) -.bfTableDependencies <- function() { - return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable", "bfFavorFull", "report", "type3")) -} + p <- ggplot2::ggplot() + + ggplot2::stat_function(fun = extraDistr::dinvchisq, + args = list(nu = 1, tau = options$rscalePrior^2), + linewidth = 1) -.varCompTableDependencies <- function() { - return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", - "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference", - "estimationType", "modelType", "report", "type3", "RRTable")) -} + # axes + p <- p + ggplot2::scale_y_continuous("Density") + + ggplot2::scale_x_continuous("g", breaks = xBreaks, limits = c(0, xUpper)) -.mcmcDependencies <- function() { - return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", - "mcmcChains", "mcmcBurnin", "mcmcIterations", - "estimationType", "modelType", "report", "type3")) -} + # JASP theme + p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe() + gPrior$plotObject <- p -.postPlotDependencies <- function() { - return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", - "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", - "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram", "report", "type3", - "processVariationReference", "historicalSdValue")) # note: the processVariationReference could be added to the function with an if-statement + priorPlot[["plot"]] <- gPrior + + return() } -.convertOutputNames <- function(name, parts, operators, includeSigma = TRUE) { - sigmaPart <- paste0("g_", parts) - sigmaOperator <- paste0("g_", operators) - sigmaInter <- paste0("g_", parts, ":", operators) - if(includeSigma) { - replPart <- "\u03C32Part" - replOperator <- "\u03C32Operator" - replInter <- "\u03C32Part\u2009\u273B\u2009Operator" - replError <- "\u03C32Error" - } else { - replPart <- "Part" - replOperator <- "Operator" - replInter <- "Part\u2009\u273B\u2009Operator" - replError <- "Error" - } +### posterior plots +.plotVariancePosteriors <- function(jaspResults, options, parts, operators){ - name <- sub(sigmaInter, replInter, name) - name <- sub(sigmaPart, replPart, name) - name <- sub(sigmaOperator, replOperator, name) - name <- sub("sig2", replError, name) + if(!is.null(jaspResults[["variancePosteriors"]])){ + return() + } - return(name) -} + variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) + variancePosteriors$position <- 6 + variancePosteriors$dependOn(c(.varCompTableDependencies(), + .postPlotDependencies())) + jaspResults[["variancePosteriors"]] <- variancePosteriors -.getEllipses <- function(contourDf, mu, options, numberEllipses = 20, meanEllipse = FALSE) { + fits <- jaspResults[["distFit"]][["object"]] + samplesMat <- switch(options$posteriorPlotType, + "var" = .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]), + "percContrib" = jaspResults[["percContribSamples"]][["object"]], + "percStudyVar" = jaspResults[["percStudySamples"]][["object"]], + "percTol" = jaspResults[["percTolSamples"]][["object"]]) - if(options$setSeed) { - set.seed(options$seed) + if(options$posteriorPlotType == "var") { + titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) + } else { + titles <- names(fits) } - if(meanEllipse) { - sigmaP <- mean(contourDf$part) - sigmaTotal <- mean(contourDf$total) + postSummary <- jaspResults[["postSummaryStats"]][["object"]] - covMat <- matrix(c(sigmaTotal, sigmaP, - sigmaP, sigmaP), + for(i in seq_along(titles)) { + tempPlot <- createJaspPlot(title = gettext(titles[i]), width = 600, height = 320) + + p <- ggplot2::ggplot() + + # add histogram outlines + if(options$posteriorHistogram) { + p <- p + ggplot2::geom_step(data = data.frame(x = samplesMat[, i]), + ggplot2::aes(x = x, y = ggplot2::after_stat(density)), + stat = "bin", direction = "mid", linewidth = 1) + pBuild <- ggplot2::ggplot_build(p) + maxHistDens <- max(pBuild$data[[1]][, "density"]) + } + + # select function for axis limits based on distribution + axisFun <- .axisLimFuns()[[options$distType]] + + lims <- axisFun(fits[[i]], postSummary, options, iter = i, + histDens = ifelse(options$posteriorHistogram, maxHistDens, 0)) + + # credible interval + if(options$posteriorCi) { + ciUpper <- postSummary[i, "ciUpper"] + ciLower <- postSummary[i, "ciLower"] + + p <- p + + if(options$distType == "metalog") { + ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), + geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") + # note: it might make sense to just pass some approximation of the density to the plotting function in case of the metalog + # so it only has to evaluate the density function once + } else { # note: this would be nicer with a list of functions again, but the functions take different arguments + ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), + geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") + } + } + + p <- p + + if(options$distType == "metalog") { + ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), + linewidth = 1) + } else { # note: see above + ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), + linewidth = 1) + } + + # point estimate + if(options$posteriorPointEstimate) { + xPoint <- postSummary[i, "pointEstimate"] + yPoint <- ifelse(options$distType == "metalog", + rmetalog::dmetalog(m = fits[[i]], q = xPoint, term = fits[[i]]$params$term_limit), + GeneralizedHyperbolic::dgig(x = xPoint, param = fits[[i]]$param)) + pointDf <- data.frame(xPoint, yPoint) + + p <- p + ggplot2::geom_point(data = pointDf, mapping = ggplot2::aes(x = xPoint, y = yPoint), + shape = 21, size = 4, fill = "grey", stroke = 1) + } + + # axes + xLab <- switch(options$posteriorPlotType, + "var" = titles[i], + "percContrib" = "% Contribution", + "percStudyVar" = "% Study Variation", + "percTol" = "% Tolerance") + if(options$posteriorPlotType == "var"){ + xLab <- bquote(sigma[.(xLab)]^2) + } + + p <- p + + ggplot2::scale_x_continuous(name = xLab, + breaks = lims$x$breaks, + limits = lims$x$limits, labels = lims$x$breaks) + + ggplot2::scale_y_continuous(name = "Density", breaks = lims$y$breaks, + limits = lims$y$limits, labels = lims$y$breaks) + + # theme + p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe(sides = "bl") + + tempPlot$plotObject <- p + variancePosteriors[[titles[i]]] <- tempPlot + } + return() +} + +.createRChart <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { + if(!is.null(jaspResults[["rChart"]])) { + return() + } + + jaspResults[["rChart"]] <- createJaspContainer(gettext("Range chart by operator")) + jaspResults[["rChart"]]$position <- 7 + jaspResults[["rChart"]]$dependOn(c("rChart", "measurementLongFormat", + "measurementsWideFormat", "report")) + jaspResults[["rChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) + if (ready) { + # converting data to wide format for the .controlChart function (note: this can be done more nicely) + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + rChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "R", + stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], + stagesSeparateCalculation = FALSE) + + jaspResults[["rChart"]][["plot"]]$plotObject <- rChart$plotObject + jaspResults[["rChart"]][["table"]] <- rChart$table + } + + return() +} + +.createXbarChart <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { + if(!is.null(jaspResults[["xBarChart"]])) { + return() + } + + jaspResults[["xBarChart"]] <- createJaspContainer(gettext("Average chart by operator")) + jaspResults[["xBarChart"]]$position <- 8 + jaspResults[["xBarChart"]]$dependOn(c("xBarChart", "measurementLongFormat", + "measurementsWideFormat", "report")) + jaspResults[["xBarChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) + if (ready) { + # converting data to wide format for the .controlChart function (note: this can be done more nicely) + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + xBarChart <- .controlChart(dataset = dataset[c(measurements, operators)], + plotType = "xBar", xBarSdType = "r", stages = operators, + xAxisLabels = dataset[[parts]][order(dataset[[operators]])], + stagesSeparateCalculation = FALSE) + + jaspResults[["xBarChart"]][["plot"]]$plotObject <- xBarChart$plotObject + jaspResults[["xBarChart"]][["table"]] <- xBarChart$table + } + + return() +} + + +.createScatterPlotOperators <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { + if(!is.null(jaspResults[["gaugeScatterOperators"]]) || !ready) { + return() + } + + # note: I could convert the data in the main analysis function and then just pass it to the functions + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + + jaspResults[["gaugeScatterOperators"]] <- .gaugeScatterPlotOperators(jaspResults = jaspResults, dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready) + jaspResults[["gaugeScatterOperators"]]$position <- 9 + jaspResults[["gaugeScatterOperators"]]$dependOn(c("scatterPlot", "scatterPlotFitLine", "scatterPlotOriginLine")) + + + return() +} + +.createMeasureByPartPlot <- function(jaspResults, dataset, measurements, operators, parts, options) { + if (!is.null(jaspResults[["gaugeByPart"]])) { + return() + } + # note: I could convert the data in the main analysis function and then just pass it to the functions + datasetWide <- .convertToWide(dataset, measurements, parts, operators) + measurementsWide <- c("V1", "V2", "V3") + + jaspResults[["gaugeByPart"]] <- .gaugeByPartGraph(dataset = datasetWide, measurements = measurementsWide, parts = parts, operators = operators, options = options) + jaspResults[["gaugeByPart"]]$position <- 10 + jaspResults[["gaugeByPart"]]$dependOn("partMeasurementPlotAllValues") + + return() +} + +.createMeasureByOperatorPlot <- function(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) { + if(!is.null(jaspResults[["gaugeByOperator"]])) { + return() + } + # note: I could convert the data in the main analysis function and then just pass it to the functions + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + + jaspResults[["gaugeByOperator"]] <- .gaugeByOperatorGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) + jaspResults[["gaugeByOperator"]]$position <- 11 + jaspResults[["gaugeByOperator"]]$dependOn("operatorMeasurementPlot") # note: should this also depend on type3? + + return() +} + +.createPartByOperatorInterPlot <- function(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) { + if(!is.null(jaspResults[["gaugeByInteraction"]])) { + return() + } + # note: I could convert the data in the main analysis function and then just pass it to the functions + dataset <- .convertToWide(dataset, measurements, parts, operators) + measurements <- c("V1", "V2", "V3") + + jaspResults[["gaugeByInteraction"]] <- .gaugeByInteractionGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) + jaspResults[["gaugeByInteraction"]]$position <- 12 + jaspResults[["gaugeByInteraction"]]$dependOn("partByOperatorMeasurementPlot") # note: should this also depend on type3? + + return() +} + +.createVarCompPlot <- function(jaspResults, options, plotOnly = FALSE) { + if(!plotOnly) { + if(!is.null(jaspResults[["varCompPlot"]])) { + return() + } + varCompPlot <- createJaspPlot(title = gettext("Components of variation"), width = 850, height = 500) + varCompPlot$position <- 6 + varCompPlot$dependOn(c(.varCompTableDependencies(), "varianceComponentsGraph", + "tolerance", "toleranceValue", + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["varCompPlot"]] <- varCompPlot + } + # obtain summaries + percContrib <- .percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options) + percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) + + # remove unnecessary rows + percContrib <- percContrib[!percContrib$sourceName %in% c("Operator", "Total variation"), ] + percStudyVar <- percStudyVar[!percStudyVar$sourceName %in% c("Operator", "Total variation"), ] + + # values for credible intervals + errorbarDf <- rbind(percContrib[, c("lower", "upper")], percStudyVar[, c("lower", "upper")]) + + # adding NAs for the reproducibility row because the plotting function expects the row to be present + if(options$type3) { + percContrib <- rbind(percContrib[1:2, ], NA, percContrib[3, ]) + percStudyVar <- rbind(percStudyVar[1:2, ], NA, percStudyVar[3, ]) + } + + if(options$tolerance) { + percTol <- .percentSampleSummaries(jaspResults[["percTolSamples"]][["object"]], options) + + # remove unnecessary rows + percTol <- percTol[!percTol$sourceName %in% c("Operator", "Total variation"), ] + + errorbarDf <- rbind(errorbarDf, percTol[, c("lower", "upper")]) + + if(options$type3) { + percTol <- rbind(percTol[1:2, ], NA, percTol[3, ]) + } + + p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, percTol$means, + errorbarDf = errorbarDf, Type3 = options$type3) + } else { + p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, NA, + errorbarDf = errorbarDf, Type3 = options$type3) + } + + if(plotOnly) { + return(p) + } else { + varCompPlot$plotObject <- p + } + + return() +} + +.createTrafficLightPlot <- function(jaspResults, options, plotOnly = FALSE) { + if(!plotOnly) { + if(!is.null(jaspResults[["trafficPlot"]])) { + return() + } + + trafficPlot <- createJaspContainer(title = gettext("Traffic light chart")) + trafficPlot$position <- 12 + trafficPlot$dependOn(c(.varCompTableDependencies(), "trafficLightChart", + "tolerance", "toleranceValue", + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["trafficPlot"]] <- trafficPlot + } + # % Study var + percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) + percStudyVar <- percStudyVar[percStudyVar$sourceName == "Total gauge r&R", ] + percStudyVarMean <- percStudyVar$means + percStudyVarCrI <- data.frame(lower = as.numeric(percStudyVar["lower"]), + upper = as.numeric(percStudyVar["upper"])) + + if(!options$tolerance) { + p <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = FALSE, + ToleranceVar = 0, + options = options, ready = TRUE, StudyVarCi = percStudyVarCrI) + } else { + # % Tolerance + trafficPlotTol <- createJaspPlot(width = 1000) + trafficPlotTol$position <- 2 + percTol <- .percentSampleSummaries(jaspResults[["percTolSamples"]][["object"]], options) + percTol <- percTol[percTol$sourceName == "Total gauge r&R", ] + percTolMean <- percTol$means + percTolCrI <- data.frame(lower = as.numeric(percTol["lower"]), + upper = as.numeric(percTol["upper"])) + + p <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = TRUE, + ToleranceVar = percTolMean, + options = options, ready = TRUE, + StudyVarCi = percStudyVarCrI, + TolCi = percTolCrI, + ggPlot = plotOnly) + } + + if(plotOnly) { + return(p) + } else { + trafficPlot[["trafficPlot"]] <- p + } + return() +} + +#### Models & statistical computations +.runMCMC <- function(jaspResults, dataset, measurements, parts, operators, options){ + if(is.null(jaspResults[["MCMCsamples"]])){ + MCMCsamples <- createJaspState() + MCMCsamples$dependOn(.mcmcDependencies()) + jaspResults[["MCMCsamples"]] <- MCMCsamples + } else { + return() + } + + if(!options$type3){ + # obtain BF in favor of full over main effects model + excludeInter <- .evalInter(jaspResults, parts, operators, options) + if(excludeInter){ + formula <- as.formula(paste(measurements, "~", parts, "+", operators)) + } else { + formula <- as.formula(paste(measurements, "~", parts, "*", operators)) + } + # fit the model with BayesFactor + fit <- BayesFactor::lmBF(formula, whichRandom = c(parts, operators), + data = dataset, rscaleRandom = options$rscalePrior) + } else { + formula <- as.formula(paste(measurements, "~", parts)) + fit <- BayesFactor::lmBF(formula, whichRandom = parts, + data = dataset, rscaleRandom = options$rscalePrior) + } + + nchains <- options$mcmcChains + burnin <- options$mcmcBurnin + iter <- options$mcmcIterations + + # get relevant parameters + paramNames <- .bfParameterNames(parts, operators, excludeInter, options) + paramNames <- c(paramNames, "sig2") + + # initiate array + mcmcArray <- array(dim = c(iter - burnin, nchains, length(paramNames))) + + if(options$setSeed) { + set.seed(options$seed) + } + + for(i in 1:nchains) { + # run chain + mcmcChain <- BayesFactor::posterior(fit, iterations = iter) + + # select subset + mcmcChain <- as.matrix(mcmcChain) + mcmcChain <- mcmcChain[, paramNames] + + # discard burnin + mcmcChain <- mcmcChain[-(1:burnin), ] + + # revert standardization + for(j in paramNames[paramNames != "sig2"]) { + mcmcChain[, j] <- mcmcChain[, j] * mcmcChain[, "sig2"] + } + + mcmcArray[, i, ] <- mcmcChain + } + + dimnames(mcmcArray) <- list(NULL, NULL, paramNames) + MCMCsamples[["object"]] <- mcmcArray + + return() +} + +.getVarianceComponents <- function(jaspResults, parts, operators, options) { + excludeInter <- .evalInter(jaspResults, parts, operators, options) + + # get components from MCMC samples + internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + + # calculate summary stats + postMeans <- colMeans(internalDF) + postSds <- apply(internalDF, 2, sd) + postCrIlower <- apply(internalDF, 2, quantile, probs = 0.025) + postCrIupper <- apply(internalDF, 2, quantile, probs = 0.975) + + # remove some stats when historicalSd is specified + if(options$processVariationReference == "historicalSd"){ + postSds["part"] <- "" + postSds["total"] <- "" + postCrIlower["part"] <- "" + postCrIlower["total"] <- "" + postCrIupper["part"] <- "" + postCrIupper["total"] <- "" + } + sourceName <- .sourceNames(options) + + return(data.frame(sourceName, + postMeans, + postSds, + postCrIlower, + postCrIupper) + ) +} + +.getComponentsFromSamples <- function(jaspResults, parts, operators, options, excludeInter){ + # note this could be written into a helper function + sigmaPart <- paste0("g_", parts) + sigmaOperator <- paste0("g_", operators) + sigmaInter <- paste0("g_", parts, ":", operators) + + samplesMat <- .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]) + samplesMat <- as.matrix(samplesMat) + + repeatability <- samplesMat[, "sig2"] + part <- samplesMat[, sigmaPart] + if(!options$type3) { + # obtain relevant components + if(excludeInter){ + reprod <- samplesMat[, sigmaOperator] + } else { + reprod <- samplesMat[, sigmaOperator] + samplesMat[, sigmaInter] + } + gauge <- reprod + repeatability + operator <- samplesMat[, sigmaOperator] + } else { + gauge <- repeatability + } + total <- gauge + part + + # replace total variation with historical variance and adjust + # part variation accordingly + if(options$processVariationReference == "historicalSd"){ + totalOld <- mean(total) + total <- rep(options$historicalSdValue^2, length(repeatability)) + diffTotals <- total - totalOld + part <- mean(part) + diffTotals + } + + if(!options$type3) { + internalDF <- data.frame(gauge, + repeatability, + reprod, + operator, + part, + total + ) + } else { + internalDF <- data.frame(gauge, + repeatability, + part, + total) + } + return(internalDF) +} + +.getDistinctCategories <- function(jaspResults, parts, operators, options) { + excludeInter <- .evalInter(jaspResults, parts, operators, options) + internalDf <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + + # subset with relevant variables + internalDf <- internalDf[, colnames(internalDf) %in% c("gauge", "part")] + sdDf <- sqrt(internalDf) + + # number distinct categories + nCat <- (sdDf$part / sdDf$gauge) * 1.41 + mean <- mean(nCat) + lower <- quantile(nCat, probs = 0.025) + upper <- quantile(nCat, probs = 0.975) + + # for footnote and report + res <- paste0(round(mean, 2), " (", round(lower, 2), ", ", round(upper, 2), ")") + + return(res) +} + +.getEllipses <- function(contourDf, mu, options, numberEllipses = 20, meanEllipse = FALSE) { + + if(options$setSeed) { + set.seed(options$seed) + } + if(meanEllipse) { + sigmaP <- mean(contourDf$part) + sigmaTotal <- mean(contourDf$total) + + covMat <- matrix(c(sigmaTotal, sigmaP, + sigmaP, sigmaP), nrow = 2, ncol = 2) res <- as.data.frame(ellipse::ellipse(covMat, centre = c(mu, mu), level = 0.95)) } else { @@ -902,174 +1223,204 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.percentSampleSummaries <- function(samples, options) { - sourceName <- .sourceNames(options) - means <- colMeans(samples) - lower <- apply(samples, 2, quantile, probs = 0.025) - upper <- apply(samples, 2, quantile, probs = 0.975) +.getPercStudy <- function(jaspResults, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { + if(is.null(jaspResults[["percStudySamples"]])) { + percStudySamples <- createJaspState() + percStudySamples$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["percStudySamples"]] <- percStudySamples + } else { + return() + } - df <- data.frame(sourceName, - means, - lower, - upper) + percStudy <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) + for(i in 1:ncol(studyVar)){ + percStudy[, i] <- studyVar[[i]] / studyVar$total * 100 + } - # remove upper and lower CrI for total variation - df[df$sourceName == "Total variation", c("lower", "upper")] <- "" # note: this coerces the whole columns to be of type chr + percStudySamples[["object"]] <- percStudy - # remove upper and lower CrI for part variation if historicalSd is specified - if(options$processVariationReference == "historicalSd") { - df[df$sourceName == "Part-to-part", c("lower", "upper")] <- "" - } - return(df) + return() } -.createGaugeEval <- function(jaspResults, parts, operators, options, ready) { - if(!is.null(jaspResults[["gaugeEvaluation"]])) { +.getPercTol <- function(jaspResults, options, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { + if(is.null(jaspResults[["percTolSamples"]])) { + percTolSamples <- createJaspState() + percTolSamples$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue", "tolerance", "toleranceValue")) + jaspResults[["percTolSamples"]] <- percTolSamples + } else { return() } - gaugeEvaluation <- createJaspContainer(title = gettext("Gauge Evaluation")) - gaugeEvaluation$position <- 4 - gaugeEvaluation$dependOn(c(.varCompTableDependencies(), - "studyVarianceMultiplierType", "studyVarianceMultiplierValue", - "tolerance", "toleranceValue")) - jaspResults[["gaugeEvaluation"]] <- gaugeEvaluation + percTol <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) + for(i in 1:ncol(studyVar)){ + percTol[, i] <- studyVar[[i]] / options$toleranceValue * 100 + } - ### Standard deviation & study variation table - stdTable <- createJaspTable(title = gettext("Standard Deviation & Study Variation")) - stdTable$position <- 1 - gaugeEvaluation[["stdTable"]] <- stdTable + percTolSamples[["object"]] <- percTol - stdTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - stdTable$addColumnInfo(name = "meansStd", title = gettext("Mean
Std"), type = "number") - stdTable$addColumnInfo(name = "lowerStd", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
Std") - stdTable$addColumnInfo(name = "upperStd", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
Std") - stdTable$addColumnInfo(name = "meansStudyVar", title = gettext("Mean
Study Variation"), type = "number") - stdTable$addColumnInfo(name = "lowerStudyVar", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
Study Variation") - stdTable$addColumnInfo(name = "upperStudyVar", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
Study Variation") + return() +} - if(ready) { - stdData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "sd") - colnames(stdData) <- c("sourceName", "meansStd", "lowerStd", "upperStd") # note: this could already be part of the function - studyVarData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")[, -1] # remove source name - colnames(studyVarData) <- c("meansStudyVar", "lowerStudyVar", "upperStudyVar") - stdTable$setData(cbind(stdData, studyVarData)) +.getStudyVariation <- function(jaspResults, parts, operators, options) { + if(is.null(jaspResults[["studyVariation"]])) { + studyVariation <- createJaspState() + studyVariation$dependOn(c(.varCompTableDependencies(), + "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) + jaspResults[["studyVariation"]] <- studyVariation + } else { + return() + } - stdTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) + excludeInter <- .evalInter(jaspResults, parts, operators, options) - # number of distinct categories - nDistinct <- .getDistinctCategories(jaspResults, parts, operators, options) - stdTable$addFootnote(gettext(paste("Number of distinct categories:", nDistinct))) - } + # get components from MCMC samples + internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) - ### Percent study variation & percent tolerance table - if(options$tolerance) { - title <- "% Study Variation & % Tolerance" + sdDf <- sqrt(internalDF) + + # get factor for multiplication + if(options$studyVarianceMultiplierType == "sd") { + factorSd <- options$studyVarianceMultiplierValue } else { - title <- "% Study Variation" + val <- options$studyVarianceMultiplierValue / 100 + q <- (1 - val) / 2 + factorSd <- abs(2 * qnorm(q)) } - percStudyVarTable <- createJaspTable(title = gettext(title)) - percStudyVarTable$position <- 2 - gaugeEvaluation[["percStudyVarTable"]] <- percStudyVarTable + studyVar <- sdDf * factorSd - percStudyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - percStudyVarTable$addColumnInfo(name = "meansPercStudy", title = gettext("Mean
% Study Variation"), type = "number") - percStudyVarTable$addColumnInfo(name = "lowerPercStudy", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
% Study Variation") - percStudyVarTable$addColumnInfo(name = "upperPercStudy", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
% Study Variation") + studyVariation[["object"]] <- list(studyVar, factorSd) - if(options$tolerance) { - percStudyVarTable$addColumnInfo(name = "meansPercTol", title = gettext("Mean
% Tolerance"), type = "number") - percStudyVarTable$addColumnInfo(name = "lowerPercTol", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
% Tolerance") - percStudyVarTable$addColumnInfo(name = "upperPercTol", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
% Tolerance") - } + return() +} - if(ready) { - percStudyData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percStudyVar") - colnames(percStudyData) <- c("sourceName", "meansPercStudy", "lowerPercStudy", "upperPercStudy") +#### helper functions +.bfParameterNames <- function(parts, operators, excludeInter, options) { + sigmaPart <- paste0("g_", parts) + sigmaOperator <- paste0("g_", operators) + sigmaInter <- paste0("g_", parts, ":", operators) - if(!options$tolerance) { - percStudyVarTable$setData(percStudyData) + if(!options$type3) { + if(excludeInter) { + res <- c(sigmaPart, sigmaOperator) } else { - percTolData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percTol")[, -1] - colnames(percTolData) <- c("meansPercTol", "lowerPercTol", "upperPercTol") - percStudyVarTable$setData(cbind(percStudyData, percTolData)) + res <- c(sigmaPart, sigmaOperator, sigmaInter) } - percStudyVarTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) + } else { + res <- sigmaPart } - - return() + return(res) } -.getPercStudy <- function(jaspResults, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { - if(is.null(jaspResults[["percStudySamples"]])) { - percStudySamples <- createJaspState() - percStudySamples$dependOn(c(.varCompTableDependencies(), - "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) - jaspResults[["percStudySamples"]] <- percStudySamples - } else { - return() +.evalInter <- function(jaspResults, parts, operators, options) { + if(options$estimationType == "automatic") { + bfDf <- jaspResults[["modelComparison"]][["object"]] + main <- paste(parts, "+", operators) + + excludeInter <- bfDf[main, ]$comparisonBF <= options$bfFavorFull } - percStudy <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) - for(i in 1:ncol(studyVar)){ - percStudy[, i] <- studyVar[[i]] / studyVar$total * 100 + if(options$estimationType == "manual"){ + if(options$modelType == "fullModel"){ + excludeInter <- FALSE + } + + if(options$modelType == "mainEffectsOnly"){ + excludeInter <- TRUE + } + } + + return(excludeInter) +} + +.sourceNames <- function(options) { + if(options$type3) { + res <- c("Total gauge r&R", + "Repeatability", + "Part-to-part", + "Total variation") + } else { + res <- c("Total gauge r&R", + "Repeatability", + "Reproducibility", + "Operator", + "Part-to-part", + "Total variation") } - percStudySamples[["object"]] <- percStudy - - return() + return(res) } -.getPercTol <- function(jaspResults, options, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { - if(is.null(jaspResults[["percTolSamples"]])) { - percTolSamples <- createJaspState() - percTolSamples$dependOn(c(.varCompTableDependencies(), - "studyVarianceMultiplierType", "studyVarianceMultiplierValue", "tolerance", "toleranceValue")) - jaspResults[["percTolSamples"]] <- percTolSamples - } else { - return() - } +.bfTableDependencies <- function() { + return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "RRTable", "bfFavorFull", "report", "type3")) +} - percTol <- matrix(ncol = ncol(studyVar), nrow = nrow(studyVar)) - for(i in 1:ncol(studyVar)){ - percTol[, i] <- studyVar[[i]] / options$toleranceValue * 100 - } +.varCompTableDependencies <- function() { + return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", + "mcmcChains", "mcmcBurnin", "mcmcIterations", "historicalSdValue", "processVariationReference", + "estimationType", "modelType", "report", "type3", "RRTable")) +} - percTolSamples[["object"]] <- percTol +.mcmcDependencies <- function() { + return(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "bfFavorFull", + "mcmcChains", "mcmcBurnin", "mcmcIterations", + "estimationType", "modelType", "report", "type3")) +} - return() +.postPlotDependencies <- function() { + return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", + "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", + "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram", "report", "type3", + "processVariationReference", "historicalSdValue")) # note: the processVariationReference could be added to the function with an if-statement } -.getStudyVariation <- function(jaspResults, parts, operators, options) { - if(is.null(jaspResults[["studyVariation"]])) { - studyVariation <- createJaspState() - studyVariation$dependOn(c(.varCompTableDependencies(), - "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) - jaspResults[["studyVariation"]] <- studyVariation +.convertOutputNames <- function(name, parts, operators, includeSigma = TRUE) { + sigmaPart <- paste0("g_", parts) + sigmaOperator <- paste0("g_", operators) + sigmaInter <- paste0("g_", parts, ":", operators) + if(includeSigma) { + replPart <- "\u03C32Part" + replOperator <- "\u03C32Operator" + replInter <- "\u03C32Part\u2009\u273B\u2009Operator" + replError <- "\u03C32Error" } else { - return() + replPart <- "Part" + replOperator <- "Operator" + replInter <- "Part\u2009\u273B\u2009Operator" + replError <- "Error" } - excludeInter <- .evalInter(jaspResults, parts, operators, options) + name <- sub(sigmaInter, replInter, name) + name <- sub(sigmaPart, replPart, name) + name <- sub(sigmaOperator, replOperator, name) + name <- sub("sig2", replError, name) - # get components from MCMC samples - internalDF <- .getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) + return(name) +} - sdDf <- sqrt(internalDF) +.percentSampleSummaries <- function(samples, options) { + sourceName <- .sourceNames(options) + means <- colMeans(samples) + lower <- apply(samples, 2, quantile, probs = 0.025) + upper <- apply(samples, 2, quantile, probs = 0.975) - # get factor for multiplication - if(options$studyVarianceMultiplierType == "sd") { - factorSd <- options$studyVarianceMultiplierValue - } else { - val <- options$studyVarianceMultiplierValue / 100 - q <- (1 - val) / 2 - factorSd <- abs(2 * qnorm(q)) - } - studyVar <- sdDf * factorSd + df <- data.frame(sourceName, + means, + lower, + upper) - studyVariation[["object"]] <- list(studyVar, factorSd) + # remove upper and lower CrI for total variation + df[df$sourceName == "Total variation", c("lower", "upper")] <- "" # note: this coerces the whole columns to be of type chr - return() + # remove upper and lower CrI for part variation if historicalSd is specified + if(options$processVariationReference == "historicalSd") { + df[df$sourceName == "Part-to-part", c("lower", "upper")] <- "" + } + return(df) } .fillTablesGaugeEval <- function(jaspResults, parts, operators, options, whichTable = "sd", gaugeReport = FALSE) { @@ -1152,31 +1503,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } -.createRChart <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { - if(!is.null(jaspResults[["rChart"]])) { - return() - } - - jaspResults[["rChart"]] <- createJaspContainer(gettext("Range chart by operator")) - jaspResults[["rChart"]]$position <- 7 - jaspResults[["rChart"]]$dependOn(c("rChart", "measurementLongFormat", - "measurementsWideFormat", "report")) - jaspResults[["rChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) - if (ready) { - # converting data to wide format for the .controlChart function (note: this can be done more nicely) - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") - rChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "R", - stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], - stagesSeparateCalculation = FALSE) - - jaspResults[["rChart"]][["plot"]]$plotObject <- rChart$plotObject - jaspResults[["rChart"]][["table"]] <- rChart$table - } - - return() -} - .convertToWide <- function(dataset, measurements, parts, operators) { dataset <- dataset[order(dataset[[operators]]),] dataset <- dataset[order(dataset[[parts]]),] @@ -1190,7 +1516,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(dataset) } -###### Distribution fitting +.convertToLong <- function(dataset, measurements) { + dataset <- tidyr::pivot_longer(dataset, cols = tidyr::all_of(measurements), + values_to = "Measurements", names_to = NULL) + return(dataset) +} + +#### Distribution fitting ### fit functions .fitDistToSamples <- function(jaspResults, options) { @@ -1268,7 +1600,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } -### posterior summary +#### posterior summary .fillPostSummaryTable <- function(jaspResults, options, parts, operators) { if(is.null(jaspResults[["postSummaryStats"]]) && (options$posteriorCi || options$posteriorPointEstimate)){ postSummaryStats <- createJaspState() @@ -1343,7 +1675,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } - ### functions point estimates .pointEstimateFunctions <- function() { l <- list( @@ -1419,133 +1750,21 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .customInterMetaLog <- function(fit, lower, upper) { int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$params$term_limit) -} - -## Generalized inverse Gaussian -.centralInterGIG <- function(fit, mass) { - lower <- (1 - mass) / 2 - upper <- 1 - lower - int <- quantile(fit$randData, probs = c(lower, upper)) -} - -.hdiGIG <- function(fit, mass) { - int <- HDInterval::hdi(fit$randData, credMass = mass) -} - -.customInterGIG <- function(fit, lower, upper) { - int <- quantile(fit$randData, probs = c(lower, upper)) -} - - -### posterior plots -.plotVariancePosteriors <- function(jaspResults, options, parts, operators){ - - if(!is.null(jaspResults[["variancePosteriors"]])){ - return() - } - - variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) - variancePosteriors$position <- 6 - variancePosteriors$dependOn(c(.varCompTableDependencies(), - .postPlotDependencies())) - jaspResults[["variancePosteriors"]] <- variancePosteriors - - fits <- jaspResults[["distFit"]][["object"]] - samplesMat <- switch(options$posteriorPlotType, - "var" = .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]), - "percContrib" = jaspResults[["percContribSamples"]][["object"]], - "percStudyVar" = jaspResults[["percStudySamples"]][["object"]], - "percTol" = jaspResults[["percTolSamples"]][["object"]]) - - if(options$posteriorPlotType == "var") { - titles <- .convertOutputNames(names(fits), parts, operators, includeSigma = FALSE) - } else { - titles <- names(fits) - } - postSummary <- jaspResults[["postSummaryStats"]][["object"]] - - for(i in seq_along(titles)) { - tempPlot <- createJaspPlot(title = gettext(titles[i]), width = 600, height = 320) - - p <- ggplot2::ggplot() - - # add histogram outlines - if(options$posteriorHistogram) { - p <- p + ggplot2::geom_step(data = data.frame(x = samplesMat[, i]), - ggplot2::aes(x = x, y = ggplot2::after_stat(density)), - stat = "bin", direction = "mid", linewidth = 1) - pBuild <- ggplot2::ggplot_build(p) - maxHistDens <- max(pBuild$data[[1]][, "density"]) - } - - # select function for axis limits based on distribution - axisFun <- .axisLimFuns()[[options$distType]] - - lims <- axisFun(fits[[i]], postSummary, options, iter = i, - histDens = ifelse(options$posteriorHistogram, maxHistDens, 0)) - - # credible interval - if(options$posteriorCi) { - ciUpper <- postSummary[i, "ciUpper"] - ciLower <- postSummary[i, "ciLower"] - - p <- p + - if(options$distType == "metalog") { - ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), - geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") - # note: it might make sense to just pass some approximation of the density to the plotting function in case of the metalog - # so it only has to evaluate the density function once - } else { # note: this would be nicer with a list of functions again, but the functions take different arguments - ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), - geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") - } - } - - p <- p + - if(options$distType == "metalog") { - ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), - linewidth = 1) - } else { # note: see above - ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), - linewidth = 1) - } - - # point estimate - if(options$posteriorPointEstimate) { - xPoint <- postSummary[i, "pointEstimate"] - yPoint <- ifelse(options$distType == "metalog", - rmetalog::dmetalog(m = fits[[i]], q = xPoint, term = fits[[i]]$params$term_limit), - GeneralizedHyperbolic::dgig(x = xPoint, param = fits[[i]]$param)) - pointDf <- data.frame(xPoint, yPoint) - - p <- p + ggplot2::geom_point(data = pointDf, mapping = ggplot2::aes(x = xPoint, y = yPoint), - shape = 21, size = 4, fill = "grey", stroke = 1) - } - - # axes - xLab <- switch(options$posteriorPlotType, - "var" = titles[i], - "percContrib" = "% Contribution", - "percStudyVar" = "% Study Variation", - "percTol" = "% Tolerance") - if(options$posteriorPlotType == "var"){ - xLab <- bquote(sigma[.(xLab)]^2) - } - - p <- p + - ggplot2::scale_x_continuous(name = xLab, - breaks = lims$x$breaks, - limits = lims$x$limits, labels = lims$x$breaks) + - ggplot2::scale_y_continuous(name = "Density", breaks = lims$y$breaks, - limits = lims$y$limits, labels = lims$y$breaks) +} - # theme - p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe(sides = "bl") +## Generalized inverse Gaussian +.centralInterGIG <- function(fit, mass) { + lower <- (1 - mass) / 2 + upper <- 1 - lower + int <- quantile(fit$randData, probs = c(lower, upper)) +} - tempPlot$plotObject <- p - variancePosteriors[[titles[i]]] <- tempPlot - } - return() +.hdiGIG <- function(fit, mass) { + int <- HDInterval::hdi(fit$randData, credMass = mass) +} + +.customInterGIG <- function(fit, lower, upper) { + int <- quantile(fit$randData, probs = c(lower, upper)) } ## axis limits @@ -1632,243 +1851,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(l) } -.createXbarChart <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { - if(!is.null(jaspResults[["xBarChart"]])) { - return() - } - - jaspResults[["xBarChart"]] <- createJaspContainer(gettext("Average chart by operator")) - jaspResults[["xBarChart"]]$position <- 8 - jaspResults[["xBarChart"]]$dependOn(c("xBarChart", "measurementLongFormat", - "measurementsWideFormat", "report")) - jaspResults[["xBarChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) - if (ready) { - # converting data to wide format for the .controlChart function (note: this can be done more nicely) - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") - xBarChart <- .controlChart(dataset = dataset[c(measurements, operators)], - plotType = "xBar", xBarSdType = "r", stages = operators, - xAxisLabels = dataset[[parts]][order(dataset[[operators]])], - stagesSeparateCalculation = FALSE) - - jaspResults[["xBarChart"]][["plot"]]$plotObject <- xBarChart$plotObject - jaspResults[["xBarChart"]][["table"]] <- xBarChart$table - } - - return() -} - - -.createScatterPlotOperators <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { - if(!is.null(jaspResults[["gaugeScatterOperators"]]) || !ready) { - return() - } - - # note: I could convert the data in the main analysis function and then just pass it to the functions - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") - - jaspResults[["gaugeScatterOperators"]] <- .gaugeScatterPlotOperators(jaspResults = jaspResults, dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready) - jaspResults[["gaugeScatterOperators"]]$position <- 9 - jaspResults[["gaugeScatterOperators"]]$dependOn(c("scatterPlot", "scatterPlotFitLine", "scatterPlotOriginLine")) - - - return() -} - -.createMeasureByPartPlot <- function(jaspResults, dataset, measurements, operators, parts, options) { - if (!is.null(jaspResults[["gaugeByPart"]])) { - return() - } - # note: I could convert the data in the main analysis function and then just pass it to the functions - datasetWide <- .convertToWide(dataset, measurements, parts, operators) - measurementsWide <- c("V1", "V2", "V3") - - jaspResults[["gaugeByPart"]] <- .gaugeByPartGraph(dataset = datasetWide, measurements = measurementsWide, parts = parts, operators = operators, options = options) - jaspResults[["gaugeByPart"]]$position <- 10 - jaspResults[["gaugeByPart"]]$dependOn("partMeasurementPlotAllValues") - - return() -} - -.createMeasureByOperatorPlot <- function(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) { - if(!is.null(jaspResults[["gaugeByOperator"]])) { - return() - } - # note: I could convert the data in the main analysis function and then just pass it to the functions - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") - - jaspResults[["gaugeByOperator"]] <- .gaugeByOperatorGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) - jaspResults[["gaugeByOperator"]]$position <- 11 - jaspResults[["gaugeByOperator"]]$dependOn("operatorMeasurementPlot") # note: should this also depend on type3? - - return() -} - -.createPartByOperatorInterPlot <- function(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) { - if(!is.null(jaspResults[["gaugeByInteraction"]])) { - return() - } - # note: I could convert the data in the main analysis function and then just pass it to the functions - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") - - jaspResults[["gaugeByInteraction"]] <- .gaugeByInteractionGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) - jaspResults[["gaugeByInteraction"]]$position <- 12 - jaspResults[["gaugeByInteraction"]]$dependOn("partByOperatorMeasurementPlot") # note: should this also depend on type3? - - return() - -} - -.plotPrior <- function(jaspResults, options) { - if(!is.null(jaspResults[["priorPlot"]])) { - return() - } - priorPlot <- createJaspContainer(title = gettext("Prior Distribution")) - priorPlot$position <- 5 - priorPlot$dependOn(c("rscalePrior", "report")) - jaspResults[["priorPlot"]] <- priorPlot - - gPrior <- createJaspPlot(title = gettext("g-prior"), width = 600, height = 320) - - # axis limit - xUpper <- extraDistr::qinvchisq(0.75, nu = 1, tau = options$rscalePrior^2) - xBreaks <- jaspGraphs::getPrettyAxisBreaks(c(0, xUpper)) - - p <- ggplot2::ggplot() + - ggplot2::stat_function(fun = extraDistr::dinvchisq, - args = list(nu = 1, tau = options$rscalePrior^2), - linewidth = 1) - - # axes - p <- p + ggplot2::scale_y_continuous("Density") + - ggplot2::scale_x_continuous("g", breaks = xBreaks, limits = c(0, xUpper)) - - # JASP theme - p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe() - gPrior$plotObject <- p - - priorPlot[["plot"]] <- gPrior - - return() -} - -.convertToLong <- function(dataset, measurements) { - dataset <- tidyr::pivot_longer(dataset, cols = tidyr::all_of(measurements), - values_to = "Measurements", names_to = NULL) - return(dataset) -} - -.createVarCompPlot <- function(jaspResults, options, plotOnly = FALSE) { - if(!plotOnly) { - if(!is.null(jaspResults[["varCompPlot"]])) { - return() - } - varCompPlot <- createJaspPlot(title = gettext("Components of variation"), width = 850, height = 500) - varCompPlot$position <- 6 - varCompPlot$dependOn(c(.varCompTableDependencies(), "varianceComponentsGraph", - "tolerance", "toleranceValue", - "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) - jaspResults[["varCompPlot"]] <- varCompPlot - } - # obtain summaries - percContrib <- .percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options) - percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) - - # remove unnecessary rows - percContrib <- percContrib[!percContrib$sourceName %in% c("Operator", "Total variation"), ] - percStudyVar <- percStudyVar[!percStudyVar$sourceName %in% c("Operator", "Total variation"), ] - - # values for credible intervals - errorbarDf <- rbind(percContrib[, c("lower", "upper")], percStudyVar[, c("lower", "upper")]) - - # adding NAs for the reproducibility row because the plotting function expects the row to be present - if(options$type3) { - percContrib <- rbind(percContrib[1:2, ], NA, percContrib[3, ]) - percStudyVar <- rbind(percStudyVar[1:2, ], NA, percStudyVar[3, ]) - } - - if(options$tolerance) { - percTol <- .percentSampleSummaries(jaspResults[["percTolSamples"]][["object"]], options) - - # remove unnecessary rows - percTol <- percTol[!percTol$sourceName %in% c("Operator", "Total variation"), ] - - errorbarDf <- rbind(errorbarDf, percTol[, c("lower", "upper")]) - - if(options$type3) { - percTol <- rbind(percTol[1:2, ], NA, percTol[3, ]) - } - - p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, percTol$means, - errorbarDf = errorbarDf, Type3 = options$type3) - } else { - p <- .gaugeVarCompGraph(percContrib$means, percStudyVar$means, NA, - errorbarDf = errorbarDf, Type3 = options$type3) - } - - if(plotOnly) { - return(p) - } else { - varCompPlot$plotObject <- p - } - - return() -} - -.createTrafficLightPlot <- function(jaspResults, options, plotOnly = FALSE) { - if(!plotOnly) { - if(!is.null(jaspResults[["trafficPlot"]])) { - return() - } - - trafficPlot <- createJaspContainer(title = gettext("Traffic light chart")) - trafficPlot$position <- 12 - trafficPlot$dependOn(c(.varCompTableDependencies(), "trafficLightChart", - "tolerance", "toleranceValue", - "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) - jaspResults[["trafficPlot"]] <- trafficPlot - } - # % Study var - percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) - percStudyVar <- percStudyVar[percStudyVar$sourceName == "Total gauge r&R", ] - percStudyVarMean <- percStudyVar$means - percStudyVarCrI <- data.frame(lower = as.numeric(percStudyVar["lower"]), - upper = as.numeric(percStudyVar["upper"])) - - if(!options$tolerance) { - p <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = FALSE, - ToleranceVar = 0, - options = options, ready = TRUE, StudyVarCi = percStudyVarCrI) - } else { - # % Tolerance - trafficPlotTol <- createJaspPlot(width = 1000) - trafficPlotTol$position <- 2 - percTol <- .percentSampleSummaries(jaspResults[["percTolSamples"]][["object"]], options) - percTol <- percTol[percTol$sourceName == "Total gauge r&R", ] - percTolMean <- percTol$means - percTolCrI <- data.frame(lower = as.numeric(percTol["lower"]), - upper = as.numeric(percTol["upper"])) - - p <- .trafficplot(StudyVar = percStudyVarMean, ToleranceUsed = TRUE, - ToleranceVar = percTolMean, - options = options, ready = TRUE, - StudyVarCi = percStudyVarCrI, - TolCi = percTolCrI, - ggPlot = plotOnly) - } - - if(plotOnly) { - return(p) - } else { - trafficPlot[["trafficPlot"]] <- p - } - return() -} - - ### MCMC diagnostics ## main function diff --git a/tests/testthat/test-msaBayesianGaugeRR.R b/tests/testthat/test-msaBayesianGaugeRR.R index 11260b4c..09238709 100644 --- a/tests/testthat/test-msaBayesianGaugeRR.R +++ b/tests/testthat/test-msaBayesianGaugeRR.R @@ -1,5 +1,5 @@ context("[Quality Control] Bayesian Gauge r&R") - +.numDecimals <- 2 ## tests long-format ### automatic model selection & posterior on variances (generalized inverse Gaussian) options <- analysisOptions("msaBayesianGaugeRR") From 3025111e16bef983b4cd94d49e9cf2590b82e28e Mon Sep 17 00:00:00 2001 From: jvli4n Date: Fri, 4 Jul 2025 13:33:39 +0200 Subject: [PATCH 27/65] Error handling --- R/msaBayesianGaugeRR.R | 320 ++++++++++++++++++++++---------- inst/qml/msaBayesianGaugeRR.qml | 4 +- 2 files changed, 228 insertions(+), 96 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 3f499a79..f570314e 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -67,12 +67,25 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { missingValues.target = c(measurements, parts, operators), exitAnalysisIfErrors = TRUE) + dataWide <- data.frame() # Converting wide to long format if(wideFormat && ready) { + dataWide <- dataset # wide data for plotting functions dataset <- .convertToLong(dataset, measurements) measurements <- "Measurements" # name assigned to the column inside the function } + if(!wideFormat && ready) { + dataWide <- .convertToWide(dataset, measurements, parts, operators) + } + measurementsWide <- colnames(dataWide)[!colnames(dataWide) %in% c(parts, operators)] # names of measurement columns + + # check for equal amount of replicates + if(any(is.na(dataWide))) { + errorMsg <- "Number of replicates differ per operator/part. Make sure that each operator measures each part equally often." + .quitAnalysis(gettext(errorMsg)) + } + if(ready && !options[["type3"]]){ crossed <- .checkIfCrossed(dataset, operators, parts, measurements) if(!crossed){ @@ -108,7 +121,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # Results from model comparison if(ready){ - .runBFtest(jaspResults, dataset, measurements, parts, operators, options) + bfTest <- .runBFtest(jaspResults, dataset, measurements, parts, operators, options) } # Model comparison table @@ -135,7 +148,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # insert report here if(ready && options$report) { - .createGaugeReport(jaspResults, dataset, measurements, parts, operators, options, ready) + .createGaugeReport(jaspResults, dataset = dataWide, measurements = measurementsWide, parts, operators, options, ready) } else { if(options$RRTable) { @@ -181,30 +194,30 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # range chart if(options$rChart) { - .createRChart(jaspResults, dataset, measurements, operators, parts, options, ready) + .createRChart(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready) } # average chart if(options$xBarChart) { - .createXbarChart(jaspResults, dataset, measurements, operators, parts, options, ready) + .createXbarChart(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready) } # scatter plot if(options$scatterPlot){ - .createScatterPlotOperators(jaspResults, dataset, measurements, operators, parts, options, ready) + .createScatterPlotOperators(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready) } # measurement by part plot if(ready && options$partMeasurementPlot) { - .createMeasureByPartPlot(jaspResults, dataset, measurements, operators, parts, options) + .createMeasureByPartPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options) } if(ready && options$operatorMeasurementPlot) { - .createMeasureByOperatorPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) + .createMeasureByOperatorPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready, Type3) } if(ready && options$partByOperatorMeasurementPlot) { - .createPartByOperatorInterPlot(jaspResults, dataset, measurements, operators, parts, options, ready, Type3) + .createPartByOperatorInterPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready, Type3) } if(ready && options$trafficLightChart) { @@ -230,10 +243,23 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { BFtable$addColumnInfo(name = "comparisonBF", title = gettext("BF10"), type = "number") BFtable$addColumnInfo(name = "error", title = gettext("error %"), type = "number") - # set data + # check for errors & set data if(ready) { - BFtable$setData(jaspResults[["modelComparison"]][["object"]]) - BFtable$addFootnote(gettext("BF10 compares the full model to the indicated model in each row.")) + if(isTryError(jaspResults[["modelComparison"]][["object"]])) { + errorMsg <- jaspResults[["modelComparison"]][["object"]] + + if(options$estimationType == "automatic") { + errorMsg <- paste(errorMsg, "Select manual estimation to try running the rest of the analysis.") + .quitAnalysis(gettext(paste("Model comparison Bayes factors could not be computed:", + .rmNewLine(errorMsg)))) + } + + BFtable$setError(gettext(paste("Model comparison Bayes factors could not be computed:", + .rmNewLine(errorMsg)))) + } else { + BFtable$setData(jaspResults[["modelComparison"]][["object"]]) + BFtable$addFootnote(gettext("BF10 compares the full model to the indicated model in each row.")) + } } return() @@ -258,13 +284,25 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # set data if(ready) { - varCompTable$setData(.getVarianceComponents(jaspResults, parts, operators, options)) + fillDat <- .getVarianceComponents(jaspResults, parts, operators, options) + + if(.hasExtremeValues(fillDat)$large) { + varCompTable$addFootnote(gettext("Estimates are very large potentially making results unreliable. Consider transfroming the data."), + symbol = gettext("Warning:")) + } + + if(.hasExtremeValues(fillDat)$small) { + varCompTable$addFootnote(gettext("Estimates are very small potentially making results unreliable. Consider transfroming the data."), + symbol = gettext("Warning:")) + } + + varCompTable$setData(fillDat) varCompTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) if(!options$type3 && .evalInter(jaspResults, parts, operators, options)) { - varCompTable$addFootnote("The components are based on the model only including the main effects.") + varCompTable$addFootnote(gettext("The components are based on the model only including the main effects.")) } else { - varCompTable$addFootnote("The components are based on the full model.") + varCompTable$addFootnote(gettext("The components are based on the full model.")) } } else { @@ -298,7 +336,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } .createPostSummaryTable <- function(jaspResults, options, parts, operators){ - if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]])){ + if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]]) || + isTryError(jaspResults[["distFit"]][["object"]])){ return() } @@ -426,7 +465,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(is.null(jaspResults[["modelComparison"]])) { modelComparison <- createJaspState() modelComparison$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior")) + "measurementLongFormat", "seed", "setSeed", "rscalePrior")) jaspResults[["modelComparison"]] <- modelComparison } else { return() @@ -438,10 +477,16 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(options$type3){ formula <- as.formula(paste(measurements, "~", parts)) - bfFit <- BayesFactor::generalTestBF(formula, data = dataset, - whichRandom = c(operators, parts), - rscaleRandom = options$rscalePrior, - progress = FALSE) + bfFit <- try(BayesFactor::generalTestBF(formula, data = dataset, + whichRandom = c(operators, parts), + rscaleRandom = options$rscalePrior, + progress = FALSE)) + + if(isTryError(bfFit)) { + jaspResults[["modelComparison"]][["object"]] <- bfFit + return() + } + bfDf <- as.data.frame(bfFit) full <- parts bfFullNull <- bfDf$bf @@ -450,10 +495,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { formula <- as.formula(paste(measurements, "~", parts, "*", operators)) # run general comparison for all potential models - bfFit <- BayesFactor::generalTestBF(formula, data = dataset, - whichRandom = c(operators, parts), - rscaleRandom = options$rscalePrior, - progress = FALSE) + bfFit <- try(BayesFactor::generalTestBF(formula, data = dataset, + whichRandom = c(operators, parts), + rscaleRandom = options$rscalePrior, + progress = FALSE)) + if(isTryError(bfFit)) { + jaspResults[["modelComparison"]][["object"]] <- bfFit + return() + } bfDf <- as.data.frame(bfFit) # extract full model and model with only main effects @@ -509,7 +558,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { samplesMat <- .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]) excludeInter <- .evalInter(jaspResults, parts, operators, options) - compDf <-.getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) # note: should the historcial sd influence this if entered by the user? + compDf <-.getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) # obtain necessary data contourDf <- compDf[, c("total", "part")] @@ -517,7 +566,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # data frame for plotting meanEllipse = TRUE - plotDf <- .getEllipses(contourDf, mu, meanEllipse = meanEllipse, options = options) #note: add number of ellipses here; this could also be done with one ellipse based on the post. mean of the variances + plotDf <- .getEllipses(contourDf, mu, meanEllipse = meanEllipse, options = options) + + if(isTryError(plotDf)) { + errorMsg <- paste("Failed to calculate contour:", .rmNewLine(plotDf)) + tempPlot$setError(gettext(errorMsg)) + contourPlot[["plot"]] <- tempPlot + return() + } if(meanEllipse) { p <- ggplot2::ggplot(plotDf, ggplot2::aes(x = x, y = y)) @@ -568,8 +624,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { risksTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") risksTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") - risksTable$setData(.getRisks(contourDf, mu, options)) + fillDat <- .getRisks(contourDf, mu, options) + if(isTryError(fillDat)) { + errorMsg <- paste("Risks could not be computed:", fillDat, "Try adjusting the specification limits.") + risksTable$setError(gettext(errorMsg)) + } else { + risksTable$setData(fillDat) + } contourPlot[["table"]] <- risksTable return() @@ -622,6 +684,16 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["variancePosteriors"]] <- variancePosteriors fits <- jaspResults[["distFit"]][["object"]] + + if(isTryError(fits)) { + errorMsg <- paste("The", .getDistNames(options$distType), + "distribution could not be fit to the samples. Try selecting another distribution.") + tempPlot <- createJaspPlot() + tempPlot$setError(gettext(errorMsg)) + jaspResults[["variancePosteriors"]][["errorPlot"]] <- tempPlot + return() + } + samplesMat <- switch(options$posteriorPlotType, "var" = .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]), "percContrib" = jaspResults[["percContribSamples"]][["object"]], @@ -730,9 +802,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { "measurementsWideFormat", "report")) jaspResults[["rChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) if (ready) { - # converting data to wide format for the .controlChart function (note: this can be done more nicely) - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") rChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "R", stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], stagesSeparateCalculation = FALSE) @@ -755,9 +824,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { "measurementsWideFormat", "report")) jaspResults[["xBarChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) if (ready) { - # converting data to wide format for the .controlChart function (note: this can be done more nicely) - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") xBarChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "xBar", xBarSdType = "r", stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], @@ -776,15 +842,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } - # note: I could convert the data in the main analysis function and then just pass it to the functions - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") - jaspResults[["gaugeScatterOperators"]] <- .gaugeScatterPlotOperators(jaspResults = jaspResults, dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready) jaspResults[["gaugeScatterOperators"]]$position <- 9 jaspResults[["gaugeScatterOperators"]]$dependOn(c("scatterPlot", "scatterPlotFitLine", "scatterPlotOriginLine")) - return() } @@ -792,11 +853,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if (!is.null(jaspResults[["gaugeByPart"]])) { return() } - # note: I could convert the data in the main analysis function and then just pass it to the functions - datasetWide <- .convertToWide(dataset, measurements, parts, operators) - measurementsWide <- c("V1", "V2", "V3") - jaspResults[["gaugeByPart"]] <- .gaugeByPartGraph(dataset = datasetWide, measurements = measurementsWide, parts = parts, operators = operators, options = options) + jaspResults[["gaugeByPart"]] <- .gaugeByPartGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options) jaspResults[["gaugeByPart"]]$position <- 10 jaspResults[["gaugeByPart"]]$dependOn("partMeasurementPlotAllValues") @@ -807,13 +865,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(!is.null(jaspResults[["gaugeByOperator"]])) { return() } - # note: I could convert the data in the main analysis function and then just pass it to the functions - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") jaspResults[["gaugeByOperator"]] <- .gaugeByOperatorGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) jaspResults[["gaugeByOperator"]]$position <- 11 - jaspResults[["gaugeByOperator"]]$dependOn("operatorMeasurementPlot") # note: should this also depend on type3? + jaspResults[["gaugeByOperator"]]$dependOn("operatorMeasurementPlot") return() } @@ -822,13 +877,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(!is.null(jaspResults[["gaugeByInteraction"]])) { return() } - # note: I could convert the data in the main analysis function and then just pass it to the functions - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") jaspResults[["gaugeByInteraction"]] <- .gaugeByInteractionGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) jaspResults[["gaugeByInteraction"]]$position <- 12 - jaspResults[["gaugeByInteraction"]]$dependOn("partByOperatorMeasurementPlot") # note: should this also depend on type3? + jaspResults[["gaugeByInteraction"]]$dependOn("partByOperatorMeasurementPlot") return() } @@ -959,12 +1011,16 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { formula <- as.formula(paste(measurements, "~", parts, "*", operators)) } # fit the model with BayesFactor - fit <- BayesFactor::lmBF(formula, whichRandom = c(parts, operators), - data = dataset, rscaleRandom = options$rscalePrior) + fit <- try(BayesFactor::lmBF(formula, whichRandom = c(parts, operators), + data = dataset, rscaleRandom = options$rscalePrior)) } else { formula <- as.formula(paste(measurements, "~", parts)) - fit <- BayesFactor::lmBF(formula, whichRandom = parts, - data = dataset, rscaleRandom = options$rscalePrior) + fit <- try(BayesFactor::lmBF(formula, whichRandom = parts, + data = dataset, rscaleRandom = options$rscalePrior)) + } + + if(isTryError(fit)) { + .quitAnalysis(gettext(paste("The BayesFactor model could not be fit:", .rmNewLine(fit)))) } nchains <- options$mcmcChains @@ -1035,7 +1091,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { postSds, postCrIlower, postCrIupper) - ) + ) } .getComponentsFromSamples <- function(jaspResults, parts, operators, options, excludeInter){ @@ -1121,8 +1177,12 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { covMat <- matrix(c(sigmaTotal, sigmaP, sigmaP, sigmaP), nrow = 2, ncol = 2) - res <- as.data.frame(ellipse::ellipse(covMat, centre = c(mu, mu), level = 0.95)) - } else { + res <- as.data.frame(try(ellipse::ellipse(covMat, centre = c(mu, mu), level = 0.95))) + + if(isTryError(res)) { + return(res) + } + } else { # note: this part is currently not used ind <- sample(1:nrow(contourDf), numberEllipses) ellipseList <- lapply(ind, function(i) { sigmaP <- contourDf[i, ]$part # part @@ -1133,7 +1193,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { nrow = 2, ncol = 2) # ellipse - ellipseDf <- as.data.frame(ellipse::ellipse(covMat, centre = c(mu, mu), level = 0.95)) + ellipseDf <- as.data.frame(try(ellipse::ellipse(covMat, centre = c(mu, mu), level = 0.95))) ellipseDf$iter <- i return(ellipseDf) @@ -1160,24 +1220,46 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # producer's risk (delta) # probability that y falls outside although x is inside - numerator <- mvtnorm::pmvnorm(lower = c(-Inf, LSL), upper = c(LSL, USL), mean = c(mu, mu), - sigma = covMat) + - mvtnorm::pmvnorm(lower = c(USL, LSL), upper = c(Inf, USL), mean = c(mu, mu), sigma = covMat) + numerator <- try(mvtnorm::pmvnorm(lower = c(-Inf, LSL), upper = c(LSL, USL), mean = c(mu, mu), + sigma = covMat) + + mvtnorm::pmvnorm(lower = c(USL, LSL), upper = c(Inf, USL), mean = c(mu, mu), sigma = covMat)) + + # the error likely occurs somewhere else + if(isTryError(numerator) || is.nan(numerator)) { + class(numerator) <- "try-error" + return(numerator) + } denom <- pnorm(USL, mean = mu, sd = sqrt(sigmaP)) - pnorm(LSL, mean = mu, sd = sqrt(sigmaP)) + if(isTryError(denom) || is.nan(denom)) { + class(denom) <- "try-error" + return(denom) + } + producers[i] <- numerator / denom # consumers risk # probability that y is inside although x falls outside - numerator <- mvtnorm::pmvnorm(lower = c(LSL, -Inf), upper = c(USL, LSL), mean = c(mu, mu), - sigma = covMat) + - mvtnorm::pmvnorm(lower = c(LSL, USL), upper = c(USL, Inf), mean = c(mu, mu), sigma = covMat) + numerator <- try(mvtnorm::pmvnorm(lower = c(LSL, -Inf), upper = c(USL, LSL), mean = c(mu, mu), + sigma = covMat) + + mvtnorm::pmvnorm(lower = c(LSL, USL), upper = c(USL, Inf), mean = c(mu, mu), sigma = covMat)) + + if(isTryError(numerator) || is.nan(numerator)) { + class(numerator) <- "try-error" + return(numerator) + } denom <- 1 - denom consumers[i] <- numerator / denom } + # this is the issue here + if(any(is.na(consumers)) || any(is.na(producers))) { + consumers <- "NA's introduced during calculation." + class(consumers) <- "try-error" + return(consumers) + } df <- data.frame(delta = producers, beta = consumers) @@ -1296,6 +1378,33 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } #### helper functions +.hasExtremeValues <- function(df) { + nums <- unlist(df, use.names = FALSE) + nums <- suppressWarnings(as.numeric(nums)) + nums <- nums[!is.na(nums)] + + res <- list(large = FALSE, small = FALSE) + if(sum(nums > 1e50) != 0) { + res$large <- TRUE + } + + if(sum(nums < 1e-50) != 0) { + res$small <- TRUE + } + + return(res) +} + +.rmNewLine <- function(msg) { + gsub("\\n ", "", msg) +} + +.getDistNames <- function(distType) { + switch(distType, + "gig" = "generalized inverse Gaussian", + "metalog" = "Metalog") +} + .bfParameterNames <- function(parts, operators, excludeInter, options) { sigmaPart <- paste0("g_", parts) sigmaOperator <- paste0("g_", operators) @@ -1375,7 +1484,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram", "report", "type3", - "processVariationReference", "historicalSdValue")) # note: the processVariationReference could be added to the function with an if-statement + "processVariationReference", "historicalSdValue")) } .convertOutputNames <- function(name, parts, operators, includeSigma = TRUE) { @@ -1447,7 +1556,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # output dependent on table if(whichTable == "sd") { # summaries - # note: here i could use the .percentSampleSummaries function + # note: here I could use the .percentSampleSummaries function means <- colMeans(sdDf) lower <- apply(sdDf, 2, quantile, probs = 0.025) upper <- apply(sdDf, 2, quantile, probs = 0.975) @@ -1504,16 +1613,19 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } .convertToWide <- function(dataset, measurements, parts, operators) { - dataset <- dataset[order(dataset[[operators]]),] - dataset <- dataset[order(dataset[[parts]]),] - nrep <- table(dataset[operators])[[1]]/length(unique(dataset[[parts]])) - index <- rep(paste("V", 1:nrep, sep = ""), nrow(dataset)/nrep) - dataset <- cbind(dataset, data.frame(index = index)) - dataset <- tidyr::spread(dataset, index, measurements) - measurements <- unique(index) - dataset <- dataset[,c(operators, parts, measurements)] + dataset <- dplyr::ungroup( + dplyr::mutate( + dplyr::group_by(dataset, dplyr::across(dplyr::all_of(c(parts, operators)))), + trial = dplyr::row_number() + ) + ) - return(dataset) + dataWide <- tidyr::pivot_wider(dataset, id_cols = c(parts, operators), values_from = measurements, + names_from = trial, names_prefix = "V") + dataWide <- as.data.frame(dataWide) + dataWide <- dataWide[order(dataWide[, parts]), ] + + return(dataWide) } .convertToLong <- function(dataset, measurements) { @@ -1560,17 +1672,19 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(options$setSeed) { set.seed(options$seed) } - fit <- switch(distType, - "metalog" = - if(options$posteriorPlotType == "var" || options$posteriorPlotType == "percTol" || - options$processVariationReference == "historicalSd") { - .fitMetaLog(samplesMat, bounds = 0, boundedness = "sl", - term_lower_bound = 5, term_limit = 5) # 5 terms - } else { - .fitMetaLog(samplesMat, bounds = c(0, 100), boundedness = "b", - term_lower_bound = 5, term_limit = 5) # 5 terms - }, - "gig" = .fitGIG(samplesMat)) + fit <- try( + switch(distType, + "metalog" = + if(options$posteriorPlotType == "var" || options$posteriorPlotType == "percTol" || + options$processVariationReference == "historicalSd") { + .fitMetaLog(samplesMat, bounds = 0, boundedness = "sl", + term_lower_bound = 5, term_limit = 5) # 5 terms + } else { + .fitMetaLog(samplesMat, bounds = c(0, 100), boundedness = "b", + term_lower_bound = 5, term_limit = 5) # 5 terms + }, + "gig" = .fitGIG(samplesMat)) + ) distFit[["object"]] <- fit @@ -1613,6 +1727,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { fits <- jaspResults[["distFit"]][["object"]] + if(isTryError(fits)) { + jaspResults[["postSummaryStats"]][["object"]] <- fits + return() + } + if(options$posteriorPlotType == "var") { parameter <- .convertOutputNames(names(fits), parts, operators) } else { @@ -1861,8 +1980,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { mcmcDiagnostics <- createJaspContainer(title = gettext("MCMC diagnostics")) mcmcDiagnostics$position <- 5 mcmcDiagnostics$dependOn(c(.mcmcDependencies(), - "diagnosticsPlots", "diagnosticsPlotType", - "diagnosticsTable")) + "diagnosticsPlots", "diagnosticsPlotType", + "diagnosticsTable")) jaspResults[["mcmcDiagnostics"]] <- mcmcDiagnostics # general input needed for the sub-functions @@ -1885,8 +2004,25 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { diagnosticsTable$addColumnInfo(name = "mcseQuantileLower", title = gettext("0.025"), type = "number", overtitle = gettext("MCSE (Quantiles)")) diagnosticsTable$addColumnInfo(name = "mcseQuantileUpper", title = gettext("0.975"), type = "number", overtitle = gettext("MCSE (Quantiles)")) - diagnosticsTable$setData(.fillDiagnosticsTable(chains = posterior::as_draws_array(chains), - paramNames = .convertOutputNames(paramNames, parts, operators, includeSigma = TRUE))) + fillDat <- .fillDiagnosticsTable(chains = posterior::as_draws_array(chains), + paramNames = .convertOutputNames(paramNames, parts, operators, includeSigma = TRUE)) + + if(.hasExtremeValues(fillDat)$large) { + diagnosticsTable$addFootnote(gettext("Estimates are very large potentially making results unreliable. Consider transfroming the data."), + symbol = gettext("Warning:")) + } + + if(.hasExtremeValues(fillDat)$small) { + diagnosticsTable$addFootnote(gettext("Estimates are very small potentially making results unreliable. Consider transfroming the data."), + symbol = gettext("Warning:")) + } + + if(any(is.na(fillDat))) { + diagnosticsTable$addFootnote(gettext("Some diagnostics could not be calculated. Results might be unreliable."), + symbol = gettext("Warning:")) + } + + diagnosticsTable$setData(fillDat) } if(options$diagnosticsPlots) { @@ -2067,10 +2203,6 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } .getReportPlots <- function(jaspResults, dataset, measurements, parts, operators, options) { - # note: I could convert the data in the main analysis function and then just pass it to the functions - dataset <- .convertToWide(dataset, measurements, parts, operators) - measurements <- c("V1", "V2", "V3") - plots <- list() plotIndexCounter <- 1 diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index af63b6af..c4da64de 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -361,7 +361,7 @@ Form id: posteriorCiLower fieldWidth: 50 defaultValue: 0.25 - min: 0 + min: 0.000001 max: posteriorCiUpper.value inclusive: JASP.None } @@ -376,7 +376,7 @@ Form fieldWidth: 50 defaultValue: 0.75 min: posteriorCiLower.value - max: 1 + max: 0.999999 inclusive: JASP.None } } From 206596f5cd0c3769fbfaa118026182b4effdc5be Mon Sep 17 00:00:00 2001 From: jvli4n Date: Fri, 4 Jul 2025 13:37:47 +0200 Subject: [PATCH 28/65] Changes help file --- inst/help/msaBayesianGaugeRR.md | 1 + 1 file changed, 1 insertion(+) diff --git a/inst/help/msaBayesianGaugeRR.md b/inst/help/msaBayesianGaugeRR.md index 576feecb..dece2d34 100644 --- a/inst/help/msaBayesianGaugeRR.md +++ b/inst/help/msaBayesianGaugeRR.md @@ -106,6 +106,7 @@ The method used in the analysis. - jaspBase - ggplot2 - tidyr +- dplyr - BayesFactor - ellipse - mvtnorm From 891657c95245f35dc9710f95a1372cefec00e804 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 15:34:18 +0200 Subject: [PATCH 29/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index c4da64de..09e64af5 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -41,7 +41,7 @@ Form VariablesForm { id: variablesFormLongFormat - visible: dataFormat.currentValue == "longFormat" + visible: dataFormat.currentValue === "longFormat" AvailableVariablesList { From 01465eb83fd7c8053d438d391106520e63f464c5 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 15:34:33 +0200 Subject: [PATCH 30/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 09e64af5..34bad945 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -79,7 +79,7 @@ Form VariablesForm { id: variablesFormWideFormat - visible: dataFormat.currentValue == "wideFormat" + visible: dataFormat.currentValue === "wideFormat" AvailableVariablesList { From ce4ffbe3f75a8d624478b8d80492bd52b8f8d61f Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 16:04:18 +0200 Subject: [PATCH 31/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 34bad945..51938f04 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -152,7 +152,7 @@ Form defaultValue: 1 min: 0.001 decimals: 3 - visible: !type3.checked && estimationType.currentValue == "automatic" + visible: !type3.checked && estimationType.currentValue === "automatic" } RadioButtonGroup From 5af0c4e03f37faf16ea973c519528e2819fd9d11 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 16:04:42 +0200 Subject: [PATCH 32/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 51938f04..b8b974ce 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -166,7 +166,7 @@ Form label: qsTr("Full model") id: fullModel checked: true - visible: estimationType.currentValue == "manual" + visible: estimationType.currentValue === "manual" } RadioButton From b7b0e47adc3b45d7556f54ea9d2705d8653a2954 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 16:05:02 +0200 Subject: [PATCH 33/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index b8b974ce..aa90c79e 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -175,7 +175,7 @@ Form label: qsTr("Main effects only") id: mainEffectsOnly checked: false - visible: estimationType.currentValue == "manual" + visible: estimationType.currentValue === "manual" } } From 8d60d7ebb179932bdcba8fa8849f1eddfbdd272d Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 16:05:21 +0200 Subject: [PATCH 34/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index aa90c79e..ca256943 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -201,7 +201,7 @@ Form defaultValue: 3 min: 0.000000001 decimals: 9 - enabled: variationReference.currentValue == "historicalSd" + enabled: variationReference.currentValue === "historicalSd" } CheckBox From c6a0801be248050caaa1f63ca9e18c052abf831f Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 16:05:59 +0200 Subject: [PATCH 35/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 6 ------ 1 file changed, 6 deletions(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index ca256943..931ca465 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -252,12 +252,6 @@ Form } } - /* CheckBox - { - name: "effectsTable" - label: qsTr("Effects table") - checked: false - } */ } Section From e0931f8619c5c1ae3c22883b9f46980c835d127d Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 16:14:29 +0200 Subject: [PATCH 36/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 931ca465..b5df1bcf 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -335,7 +335,7 @@ Form CIField { - visible: posteriorCiType.currentText == "central" | posteriorCiType.currentText == "HPD" + visible: posteriorCiType.currentText === "central" || posteriorCiType.currentText === "HPD" enabled: posteriorCi.checked name: "posteriorCiMass" label: qsTr("Mass") From 4d36a80a1d0e66994087d20877485791a68e1229 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 16:14:58 +0200 Subject: [PATCH 37/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index b5df1bcf..46f75b88 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -362,7 +362,7 @@ Form DoubleField { - visible: posteriorCiType.currentText == "custom" + visible: posteriorCiType.currentText === "custom" enabled: posteriorCi.checked name: "posteriorCiUpper" label: qsTr("Upper") From f954c2514d277962b41495d3d47f77e0c7230d69 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 16:16:26 +0200 Subject: [PATCH 38/65] Update inst/qml/msaBayesianGaugeRR.qml Co-authored-by: Don van den Bergh --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 46f75b88..e3011c86 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -587,7 +587,7 @@ Form { name: "distType" label: qsTr("Distribution") - values: posteriorPlotType.currentValue == "var" ? [ + values: posteriorPlotType.currentValue === "var" ? [ { label: qsTr("Generalized inverse Gaussian"), value: "gig" }, { label: qsTr("Metalog"), value: "metalog" } ] : [ From 516e5ead3cecfd3b1d682c58c2c496f87d4411a5 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Mon, 21 Jul 2025 17:12:45 +0200 Subject: [PATCH 39/65] Changing DropDowns for translation --- inst/qml/msaBayesianGaugeRR.qml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index e3011c86..d77c1235 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -308,7 +308,12 @@ Form { name: "posteriorPointEstimateType" label: "" - values: ["mean", "median", "mode"] + values: + [ + { label: qsTr("mean"), value: "mean" }, + { label: qsTr("median"), value: "median" }, + { label: qsTr("mode"), value: "mode" } + ] } } @@ -324,7 +329,12 @@ Form { name: "posteriorCiType" label: "" - values: ["central", "HPD", "custom"] + values: + [ + { label: qsTr("central"), value: "central" }, + { label: qsTr("HPD"), value: "HPD" }, + { label: qsTr("custom"), value: "custom" } + ] id: posteriorCiType } } From 0198c979f1cc4ae0ac668dbefd2f40bb043667d6 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Mon, 21 Jul 2025 17:47:56 +0200 Subject: [PATCH 40/65] MCMC options - Changing to IntegerFields - Changing default number of chains to 4 - Changing min iterations to 100 - Making sure that the number of iterations always have to be at least double the burnin or 100 --- inst/qml/msaBayesianGaugeRR.qml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index d77c1235..2b23caa8 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -555,29 +555,27 @@ Form { title: qsTr("MCMC options") - DoubleField + IntegerField { name: "mcmcChains" label: qsTr("Chains") - defaultValue: 2 + defaultValue: 4 min: 1 max: 10 - decimals: 0 } - DoubleField + IntegerField { name: "mcmcIterations" label: qsTr("Iterations per chain") id: mcmcIterations defaultValue: 10000 - min: 1 + min: Math.max(mcmcBurnin.value * 2, 100) max: 100000 - decimals: 0 fieldWidth: 60 } - DoubleField + IntegerField { name: "mcmcBurnin" label: qsTr("Burn-in per chain") From 0f721057d101e3dacc23ea0a254018562aaec8b5 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Mon, 21 Jul 2025 17:49:15 +0200 Subject: [PATCH 41/65] MCMC options --- inst/qml/msaBayesianGaugeRR.qml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 2b23caa8..f7e476ba 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -580,9 +580,9 @@ Form name: "mcmcBurnin" label: qsTr("Burn-in per chain") defaultValue: 2000 + id: mcmcBurnin min: 1 max: mcmcIterations.value / 2 - decimals: 0 fieldWidth: 60 } } From 3db434bfbb65127594d6c83a022f6aaa75aa1de6 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Mon, 21 Jul 2025 19:18:24 +0200 Subject: [PATCH 42/65] Changing object names to camelCase --- R/msaBayesianGaugeRR.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index f570314e..23f73be4 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -48,13 +48,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } } - numeric.vars <- measurements - numeric.vars <- numeric.vars[numeric.vars != ""] - factor.vars <- c(parts, operators) - factor.vars <- factor.vars[factor.vars != ""] + numericVars <- measurements + numericVars <- numericVars[numericVars != ""] + factorVars <- c(parts, operators) + factorVars <- factorVars[factorVars != ""] if (is.null(dataset)) { - dataset <- .readDataSetToEnd(columns.as.numeric = numeric.vars, columns.as.factor = factor.vars) + dataset <- .readDataSetToEnd(columns.as.numeric = numericVars, columns.as.factor = factorVars) if (options$type3){ dataset$operators <- rep(1, nrow(dataset)) operators <- "operators" From 64d60f029200fbf22dfc46e6be35b2fe7aed9748 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 19:20:21 +0200 Subject: [PATCH 43/65] Update R/msaBayesianGaugeRR.R Co-authored-by: Don van den Bergh --- R/msaBayesianGaugeRR.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 23f73be4..4a2ba155 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -81,7 +81,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { measurementsWide <- colnames(dataWide)[!colnames(dataWide) %in% c(parts, operators)] # names of measurement columns # check for equal amount of replicates - if(any(is.na(dataWide))) { + if(anyNA(dataWide)) { errorMsg <- "Number of replicates differ per operator/part. Make sure that each operator measures each part equally often." .quitAnalysis(gettext(errorMsg)) } From 6854b68e1c5ab1c33e44f5ec5d46e0e81bf4e53d Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 19:21:59 +0200 Subject: [PATCH 44/65] Update R/msaBayesianGaugeRR.R Co-authored-by: Don van den Bergh --- R/msaBayesianGaugeRR.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 4a2ba155..c7c559da 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -82,7 +82,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # check for equal amount of replicates if(anyNA(dataWide)) { - errorMsg <- "Number of replicates differ per operator/part. Make sure that each operator measures each part equally often." + errorMsg <- gettext("Number of replicates differ per operator/part. Make sure that each operator measures each part equally often.") .quitAnalysis(gettext(errorMsg)) } From 37d6fd22c92ab3d33375d3cb7e78867558699fd8 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 19:23:02 +0200 Subject: [PATCH 45/65] Update R/msaBayesianGaugeRR.R Co-authored-by: Don van den Bergh --- R/msaBayesianGaugeRR.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index c7c559da..a9347706 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -323,8 +323,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { contribTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") contribTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - contribTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") - contribTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + overTitle <- gettext("95% Credible Interval") + contribTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = overTitle) + contribTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = overTitle) if(ready) { contribTable$setData(.percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options)) From bdf992726312db05f5d5941366ca383bf3199a15 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Mon, 21 Jul 2025 19:31:22 +0200 Subject: [PATCH 46/65] Footnote translation --- R/msaBayesianGaugeRR.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index a9347706..991cb851 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -421,7 +421,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # number of distinct categories nDistinct <- .getDistinctCategories(jaspResults, parts, operators, options) - stdTable$addFootnote(gettext(paste("Number of distinct categories:", nDistinct))) + stdTable$addFootnote(gettextf("Number of distinct categories: %s", nDistinct)) } ### Percent study variation & percent tolerance table From ac166e233ddc0c9207542be79110912dd5e9aace Mon Sep 17 00:00:00 2001 From: jvli4n Date: Mon, 21 Jul 2025 19:40:22 +0200 Subject: [PATCH 47/65] Title translation --- R/msaBayesianGaugeRR.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 991cb851..c099c8aa 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -426,11 +426,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ### Percent study variation & percent tolerance table if(options$tolerance) { - title <- "% Study Variation & % Tolerance" + title <- gettext("% Study Variation & % Tolerance") } else { - title <- "% Study Variation" + title <- gettext("% Study Variation") } - percStudyVarTable <- createJaspTable(title = gettext(title)) + percStudyVarTable <- createJaspTable(title = title) percStudyVarTable$position <- 2 gaugeEvaluation[["percStudyVarTable"]] <- percStudyVarTable From 7563c59451753de5d4f34471fba545f38be95653 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Mon, 21 Jul 2025 19:41:48 +0200 Subject: [PATCH 48/65] Update R/msaBayesianGaugeRR.R Co-authored-by: Don van den Bergh --- R/msaBayesianGaugeRR.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index c099c8aa..98ab472e 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -566,7 +566,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { mu <- mean(dataset[[measurements]]) # data frame for plotting - meanEllipse = TRUE + meanEllipse <- TRUE plotDf <- .getEllipses(contourDf, mu, meanEllipse = meanEllipse, options = options) if(isTryError(plotDf)) { From b813aaf82b88b552cd88465a067e693ab7214900 Mon Sep 17 00:00:00 2001 From: Julian Wuth <145038140+jvli4n@users.noreply.github.com> Date: Tue, 22 Jul 2025 09:25:29 +0200 Subject: [PATCH 49/65] Axis label translation Co-authored-by: Don van den Bergh --- R/msaBayesianGaugeRR.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 98ab472e..4ca020a3 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -601,9 +601,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { yLims <- c(yBreaks[1], yBreaks[length(yBreaks)]) p <- p + - ggplot2::scale_x_continuous(name = "True Value", breaks = xBreaks, + ggplot2::scale_x_continuous(name = gettext("True Value"), breaks = xBreaks, limits = xLims, labels = xBreaks) + - ggplot2::scale_y_continuous(name = "Measurement", breaks = yBreaks, + ggplot2::scale_y_continuous(name = gettext("Measurement"), breaks = yBreaks, limits = yLims, labels = yBreaks) + ggplot2::coord_equal() From a51024bbf1425ee79ea8e2e77f4deec65995e0ed Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 22 Jul 2025 10:25:52 +0200 Subject: [PATCH 50/65] Error message and overtitle translations --- R/msaBayesianGaugeRR.R | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 4ca020a3..c8cbf2d3 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -83,7 +83,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # check for equal amount of replicates if(anyNA(dataWide)) { errorMsg <- gettext("Number of replicates differ per operator/part. Make sure that each operator measures each part equally often.") - .quitAnalysis(gettext(errorMsg)) + .quitAnalysis(errorMsg) } if(ready && !options[["type3"]]){ @@ -404,11 +404,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { stdTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") stdTable$addColumnInfo(name = "meansStd", title = gettext("Mean
Std"), type = "number") - stdTable$addColumnInfo(name = "lowerStd", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
Std") - stdTable$addColumnInfo(name = "upperStd", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
Std") + stdTable$addColumnInfo(name = "lowerStd", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval
Std")) + stdTable$addColumnInfo(name = "upperStd", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval
Std")) stdTable$addColumnInfo(name = "meansStudyVar", title = gettext("Mean
Study Variation"), type = "number") - stdTable$addColumnInfo(name = "lowerStudyVar", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
Study Variation") - stdTable$addColumnInfo(name = "upperStudyVar", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
Study Variation") + stdTable$addColumnInfo(name = "lowerStudyVar", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval
Study Variation")) + stdTable$addColumnInfo(name = "upperStudyVar", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval
Study Variation")) if(ready) { stdData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "sd") @@ -436,13 +436,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { percStudyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") percStudyVarTable$addColumnInfo(name = "meansPercStudy", title = gettext("Mean
% Study Variation"), type = "number") - percStudyVarTable$addColumnInfo(name = "lowerPercStudy", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
% Study Variation") - percStudyVarTable$addColumnInfo(name = "upperPercStudy", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
% Study Variation") + percStudyVarTable$addColumnInfo(name = "lowerPercStudy", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval
% Study Variation")) + percStudyVarTable$addColumnInfo(name = "upperPercStudy", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval
% Study Variation")) if(options$tolerance) { percStudyVarTable$addColumnInfo(name = "meansPercTol", title = gettext("Mean
% Tolerance"), type = "number") - percStudyVarTable$addColumnInfo(name = "lowerPercTol", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval
% Tolerance") - percStudyVarTable$addColumnInfo(name = "upperPercTol", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval
% Tolerance") + percStudyVarTable$addColumnInfo(name = "lowerPercTol", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval
% Tolerance")) + percStudyVarTable$addColumnInfo(name = "upperPercTol", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval
% Tolerance")) } if(ready) { @@ -570,8 +570,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { plotDf <- .getEllipses(contourDf, mu, meanEllipse = meanEllipse, options = options) if(isTryError(plotDf)) { - errorMsg <- paste("Failed to calculate contour:", .rmNewLine(plotDf)) - tempPlot$setError(gettext(errorMsg)) + errorMsg <- gettextf("Failed to calculate contour: %s", .rmNewLine(plotDf)) + tempPlot$setError(errorMsg) contourPlot[["plot"]] <- tempPlot return() } @@ -622,14 +622,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { risksTable$addColumnInfo(name = "risks", title = gettext("Risk"), type = "string") risksTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - risksTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = "95% Credible Interval") - risksTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = "95% Credible Interval") + risksTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval")) + risksTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval")) fillDat <- .getRisks(contourDf, mu, options) if(isTryError(fillDat)) { - errorMsg <- paste("Risks could not be computed:", fillDat, "Try adjusting the specification limits.") - risksTable$setError(gettext(errorMsg)) + errorMsg <- gettextf("Risks could not be computed: %s
Try adjusting the specification limits.", fillDat) + risksTable$setError(errorMsg) } else { risksTable$setData(fillDat) } @@ -687,10 +687,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { fits <- jaspResults[["distFit"]][["object"]] if(isTryError(fits)) { - errorMsg <- paste("The", .getDistNames(options$distType), - "distribution could not be fit to the samples. Try selecting another distribution.") + errorMsg <- gettextf("The %s distribution could not be fit to the samples. + Try selecting another distribution.", .getDistNames(options$distType)) tempPlot <- createJaspPlot() - tempPlot$setError(gettext(errorMsg)) + tempPlot$setError(errorMsg) jaspResults[["variancePosteriors"]][["errorPlot"]] <- tempPlot return() } @@ -1021,7 +1021,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } if(isTryError(fit)) { - .quitAnalysis(gettext(paste("The BayesFactor model could not be fit:", .rmNewLine(fit)))) + .quitAnalysis(gettextf("The BayesFactor model could not be fit: %s", .rmNewLine(fit))) } nchains <- options$mcmcChains From 069d71ee319075a049f61e08138faab53b8edd7b Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 22 Jul 2025 10:49:10 +0200 Subject: [PATCH 51/65] Adding inclusive statements to input fields --- inst/qml/msaBayesianGaugeRR.qml | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index f7e476ba..cd829fe0 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -15,6 +15,7 @@ import QtQuick import QtQuick.Layouts import JASP.Controls +import JASP Form { @@ -150,7 +151,8 @@ Form label: qsTr("Cut-off BF in favor of full model") id: bfFavorFull defaultValue: 1 - min: 0.001 + min: 0 + inclusive: JASP.None decimals: 3 visible: !type3.checked && estimationType.currentValue === "automatic" } @@ -199,7 +201,8 @@ Form name: "historicalSdValue" label: qsTr("Historical standard deviation:") defaultValue: 3 - min: 0.000000001 + min: 0 + inclusive: JASP.None decimals: 9 enabled: variationReference.currentValue === "historicalSd" } @@ -216,7 +219,8 @@ Form name: "toleranceValue" id: toleranceValue defaultValue: 10 - min: 0.000000001 + min: 0 + inclusive: JASP.None decimals: 9 } } @@ -246,8 +250,9 @@ Form label: qsTr("Study var. multiplier value") fieldWidth: 60 defaultValue: 6 - min: 0.001 - max: 99.999 + min: 0 + max: 100 + inclusive: JASP.None decimals: 3 } } @@ -353,7 +358,7 @@ Form defaultValue: 95 min: 1 max: 100 - inclusive: JASP.Min + inclusive: JASP.MinOnly } DoubleField @@ -365,7 +370,7 @@ Form id: posteriorCiLower fieldWidth: 50 defaultValue: 0.25 - min: 0.000001 + min: 0 max: posteriorCiUpper.value inclusive: JASP.None } @@ -380,7 +385,7 @@ Form fieldWidth: 50 defaultValue: 0.75 min: posteriorCiLower.value - max: 0.999999 + max: 1 inclusive: JASP.None } } @@ -397,8 +402,8 @@ Form label: qsTr("Lower specification limit") id: contourLSL fieldWidth: 60 + negativeValues: true defaultValue: -1 - min: -1000000 max: contourUSL.value inclusive: JASP.None } @@ -410,8 +415,8 @@ Form id: contourUSL fieldWidth: 60 defaultValue: 1 + negativeValues: true min: contourLSL.value - max: 1000000 inclusive: JASP.None } } @@ -540,8 +545,9 @@ Form name: "rscalePrior" label: qsTr("r scale prior") defaultValue: 1 - min: 0.001 + min: 0 max: 10 + inclusive: JASP.MaxOnly decimals: 3 } } From b83b03df2c186b908421a35deca725dfb65f855b Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 22 Jul 2025 18:39:20 +0200 Subject: [PATCH 52/65] Main function clean up & translations - moving data reading, error checking etc. to sub-functions - translations - Edit to .rmNewLine function: Now also removes new line at the end of the string. - Manually specifying 2 chains in the unit tests as the default was changed to 4 --- R/msaBayesianGaugeRR.R | 272 ++++++++++++++--------- tests/testthat/test-msaBayesianGaugeRR.R | 10 + 2 files changed, 176 insertions(+), 106 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index c8cbf2d3..c6a91e3b 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -17,107 +17,28 @@ #' @export msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { - # Reading the data in the correct format - wideFormat <- options[["dataFormat"]] == "wideFormat" - if (wideFormat) { - measurements <- unlist(options[["measurementsWideFormat"]]) - parts <- unlist(options[["partWideFormat"]]) - operators <- unlist(options[["operatorWideFormat"]]) - } else { - measurements <- unlist(options[["measurementLongFormat"]]) - parts <- unlist(options[["partLongFormat"]]) - operators <- unlist(options[["operatorLongFormat"]]) - } + # Compute additional options + options <- .msabComputeDerivedOptions(options) - #ready statement - if (wideFormat && !options[["type3"]]) { - ready <- (length(measurements) > 1 && !identical(operators, "") && !identical(parts, "")) - } else if (wideFormat && options[["type3"]]) { - ready <- (length(measurements) > 1 && !identical(parts, "")) - } else if (!wideFormat && !options[["type3"]]) { - ready <- (measurements != "" && !identical(operators, "") && !identical(parts, "")) - } else if (!wideFormat && options[["type3"]]) { - ready <- (!identical(measurements, "") && !identical(parts, "")) - } + # Check if ready + ready <- .msabIsReady(options) - if(options$estimationType == "manual"){ - if(options$modelType == "fullModel" || options$modelType == "mainEffectsOnly") { - ready <- ready - } else { - ready <- FALSE - } - } + # dataset in wide & long format + datasets <- .msabReadDataset(dataset, options, ready) + dataset <- datasets[["dataLong"]] + dataWide <- datasets[["dataWide"]] - numericVars <- measurements - numericVars <- numericVars[numericVars != ""] - factorVars <- c(parts, operators) - factorVars <- factorVars[factorVars != ""] + # adjust variable names in options + options <- .msabAdjustVarNames(options, dataWide, ready) - if (is.null(dataset)) { - dataset <- .readDataSetToEnd(columns.as.numeric = numericVars, columns.as.factor = factorVars) - if (options$type3){ - dataset$operators <- rep(1, nrow(dataset)) - operators <- "operators" - } - } - - # Checking for infinity and missingValues - .hasErrors(dataset, type = c('infinity', 'missingValues'), - infinity.target = measurements, - missingValues.target = c(measurements, parts, operators), - exitAnalysisIfErrors = TRUE) - - dataWide <- data.frame() - # Converting wide to long format - if(wideFormat && ready) { - dataWide <- dataset # wide data for plotting functions - dataset <- .convertToLong(dataset, measurements) - measurements <- "Measurements" # name assigned to the column inside the function - } + # Error checks + .msabCheckErrors(jaspResults, options, ready, dataset, dataWide) - if(!wideFormat && ready) { - dataWide <- .convertToWide(dataset, measurements, parts, operators) - } - measurementsWide <- colnames(dataWide)[!colnames(dataWide) %in% c(parts, operators)] # names of measurement columns - - # check for equal amount of replicates - if(anyNA(dataWide)) { - errorMsg <- gettext("Number of replicates differ per operator/part. Make sure that each operator measures each part equally often.") - .quitAnalysis(errorMsg) - } - - if(ready && !options[["type3"]]){ - crossed <- .checkIfCrossed(dataset, operators, parts, measurements) - if(!crossed){ - plot <- createJaspPlot(title = gettext("Gauge r&R"), width = 700, height = 400) - jaspResults[["plot"]] <- plot - plot$setError(gettext("Design is not balanced: not every operator measured every part. Use non-replicable gauge r&R.")) - return() - } - } - - # Checking type 3 - Type3 <- c(length(unique(dataset[[operators]])) == 1 || options$type3) - - # Errors # - # Checking whether type3 is used correctly - .hasErrors(dataset, - target = measurements, - custom = function() { - if (Type3 && !options$type3) - return("This dataset seems to have only a single unique operator. Please use the Type 3 study by checking the box below.")}, - exitAnalysisIfErrors = TRUE) - # Checking whether the format wide is used correctly - if (ready) - .hasErrors(dataset, - target = measurements, - custom = function() { - dataToBeChecked <- dataset[dataset[[operators]] == dataset[[operators]][1],] - partsLevels <- length(levels(dataToBeChecked[[parts]])) - partsLength <- length(dataToBeChecked[[parts]]) - if (wideFormat && partsLevels != partsLength && !Type3) - return(gettextf("The measurements selected seem to be in a 'Single Column' format as every operator's part is measured %d times.", partsLength/partsLevels))}, - exitAnalysisIfErrors = FALSE) + # note: this can be done better + measurements <- options[["measurements"]] + parts <- options[["parts"]] + operators <- options[["operators"]] + measurementsWide <- options[["measurementsWide"]] # Results from model comparison if(ready){ @@ -213,11 +134,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } if(ready && options$operatorMeasurementPlot) { - .createMeasureByOperatorPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready, Type3) + .createMeasureByOperatorPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready, Type3 = options$type3) } if(ready && options$partByOperatorMeasurementPlot) { - .createPartByOperatorInterPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready, Type3) + .createPartByOperatorInterPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready, Type3 = options$type3) } if(ready && options$trafficLightChart) { @@ -249,13 +170,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { errorMsg <- jaspResults[["modelComparison"]][["object"]] if(options$estimationType == "automatic") { - errorMsg <- paste(errorMsg, "Select manual estimation to try running the rest of the analysis.") - .quitAnalysis(gettext(paste("Model comparison Bayes factors could not be computed:", - .rmNewLine(errorMsg)))) + errorMsg <- gettextf("Model comparison Bayes factors could not be computed: %s
Select manual estimation to try running the rest of the analysis.", + .rmNewLine(errorMsg)) + .quitAnalysis(errorMsg) } + errorMsg <- gettextf("Model comparison Bayes factors could not be computed: %s", + .rmNewLine(errorMsg)) + BFtable$setError(errorMsg) - BFtable$setError(gettext(paste("Model comparison Bayes factors could not be computed:", - .rmNewLine(errorMsg)))) } else { BFtable$setData(jaspResults[["modelComparison"]][["object"]]) BFtable$addFootnote(gettext("BF10 compares the full model to the indicated model in each row.")) @@ -365,8 +287,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { mass <- round((options$posteriorCiUpper - options$posteriorCiLower) * 100) } - overtitle <- paste0(mass, "% ", "Credible Interval") - + overtitle <- gettextf("%s%% Credible Interval", mass) postSummary$addColumnInfo(name = "parameter", title = gettext("Source"), type = "string") @@ -1397,7 +1318,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } .rmNewLine <- function(msg) { - gsub("\\n ", "", msg) + msg <- gsub("\\n ", "", msg) + msg <- gsub("\\n", "", msg) + + return(msg) } .getDistNames <- function(distType) { @@ -2340,3 +2264,139 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } + +### Data reading & error checks +.msabComputeDerivedOptions <- function(options) { + wideFormat <- options[["dataFormat"]] == "wideFormat" + if (wideFormat) { + options$measurements <- unlist(options[["measurementsWideFormat"]]) + options$parts <- unlist(options[["partWideFormat"]]) + options$operators <- unlist(options[["operatorWideFormat"]]) + } else { + options$measurements <- unlist(options[["measurementLongFormat"]]) + options$parts <- unlist(options[["partLongFormat"]]) + options$operators <- unlist(options[["operatorLongFormat"]]) + } + + if(options$type3) { + options$operators <- "operators" + } + + options$wideFormat <- wideFormat + + return(options) +} + +.msabIsReady <- function(options) { + wideFormat <- options$wideFormat + if (wideFormat && !options[["type3"]]) { + ready <- (length(options$measurements) > 1 && !identical(options$operators, "") && !identical(options$parts, "")) + } else if (wideFormat && options[["type3"]]) { + ready <- (length(options$measurements) > 1 && !identical(options$parts, "")) + } else if (!wideFormat && !options[["type3"]]) { + ready <- (options$measurements != "" && !identical(options$operators, "") && !identical(options$parts, "")) + } else if (!wideFormat && options[["type3"]]) { + ready <- (!identical(options$measurements, "") && !identical(options$parts, "")) + } + + if(options$estimationType == "manual"){ + if(options$modelType == "fullModel" || options$modelType == "mainEffectsOnly") { + ready <- ready + } else { + ready <- FALSE + } + } + + return(ready) +} + +.msabReadDataset <- function(dataset, options, ready) { + wideFormat <- options$wideFormat + numericVars <- options$measurements + numericVars <- numericVars[numericVars != ""] + factorVars <- c(options$parts, options$operators) + factorVars <- factorVars[factorVars != "" & factorVars != "operators"] + + if (is.null(dataset)) { + dataset <- .readDataSetToEnd(columns.as.numeric = numericVars, columns.as.factor = factorVars) + if (options$type3){ + dataset$operators <- rep(1, nrow(dataset)) + } + } + + datasets <- list() + # Converting wide to long format + if(wideFormat && ready) { + datasets[["dataWide"]] <- dataset # wide data for plotting functions + datasets[["dataLong"]] <- .convertToLong(dataset, options$measurements) + } + + if(!wideFormat && ready) { + datasets[["dataLong"]] <- dataset + datasets[["dataWide"]] <- .convertToWide(dataset, options$measurements, options$parts, options$operators) + } + + return(datasets) +} + +.msabAdjustVarNames <- function(options, dataWide, ready) { + if(options$wideFormat && ready) { + options$measurements <- "Measurements" # name assigned to the column inside the conversion function + } + + if(!is.null(dataWide)) { + # names of measurement columns in wide format + options$measurementsWide <- colnames(dataWide)[!colnames(dataWide) %in% c(options$parts, options$operators)] + } + + return(options) +} + +.msabCheckErrors <- function(jaspResults, options, ready, dataset, dataWide) { + measurements <- options[["measurements"]] + parts <- options[["parts"]] + operators <- options[["operators"]] + + # check for equal amount of replicates + if(anyNA(dataWide)) { + errorMsg <- gettext("Number of replicates differ per operator/part. Make sure that each operator measures each part equally often.") + .quitAnalysis(errorMsg) + } + + # Checking for infinity and missingValues + .hasErrors(dataset, type = c('infinity', 'missingValues'), + infinity.target = measurements, + missingValues.target = c(measurements, parts, operators), + exitAnalysisIfErrors = TRUE) + + if(ready && !options[["type3"]]){ + crossed <- .checkIfCrossed(dataset, operators, parts, measurements) + if(!crossed){ + plot <- createJaspPlot(title = gettext("Gauge r&R"), width = 700, height = 400) + jaspResults[["plot"]] <- plot + plot$setError(gettext("Design is not balanced: not every operator measured every part. Use non-replicable gauge r&R.")) + return() + } + } + + # Checking whether type3 is used correctly + Type3 <- c(length(unique(dataset[[operators]])) == 1 || options$type3) + .hasErrors(dataset, + target = measurements, + custom = function() { + if (Type3 && !options$type3) + return("This dataset seems to have only a single unique operator. Please use the Type 3 study by checking the box below.")}, + exitAnalysisIfErrors = TRUE) + + # Checking whether the format wide is used correctly + if (ready) + .hasErrors(dataWide, + target = measurements, + custom = function() { + dataToBeChecked <- dataWide[dataWide[[operators]] == dataWide[[operators]][1],] + partsLevels <- length(levels(dataToBeChecked[[parts]])) + partsLength <- length(dataToBeChecked[[parts]]) + if (options$wideFormat && partsLevels != partsLength && !Type3) + return(gettextf("The measurements selected seem to be in a 'Single Column' format as every operator's part is measured %d times.", partsLength/partsLevels))}, + exitAnalysisIfErrors = FALSE) +} diff --git a/tests/testthat/test-msaBayesianGaugeRR.R b/tests/testthat/test-msaBayesianGaugeRR.R index 09238709..cd2878d5 100644 --- a/tests/testthat/test-msaBayesianGaugeRR.R +++ b/tests/testthat/test-msaBayesianGaugeRR.R @@ -26,6 +26,7 @@ options$operatorMeasurementPlot <- TRUE options$partByOperatorMeasurementPlot <- TRUE options$trafficLightChart <- TRUE options$distType <- "gig" +options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) @@ -256,6 +257,7 @@ options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "autocor" options$distType <- "metalog" options$modelType <- "fullModel" +options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) @@ -429,6 +431,7 @@ options$posteriorCi <- TRUE options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "density" options$distType <- "metalog" +options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) @@ -569,6 +572,7 @@ options$posteriorCi <- TRUE options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "density" options$distType <- "metalog" +options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) @@ -723,6 +727,7 @@ test_that("L Gauge r&R report plot matches", { options$reportMeasurementsByOperatorPlot <- TRUE options$reportAverageChartByOperator <- TRUE options$reportPartByOperatorPlot <- TRUE + options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) plotName <- results[["results"]][["report"]][["data"]] @@ -760,6 +765,7 @@ options$operatorMeasurementPlot <- TRUE options$partByOperatorMeasurementPlot <- TRUE options$trafficLightChart <- TRUE options$distType <- "gig" +options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) @@ -984,6 +990,7 @@ options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "autocor" options$distType <- "metalog" options$modelType <- "fullModel" +options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) @@ -1157,6 +1164,7 @@ options$posteriorCi <- TRUE options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "density" options$distType <- "metalog" +options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) @@ -1297,6 +1305,7 @@ options$posteriorCi <- TRUE options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "density" options$distType <- "metalog" +options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) @@ -1450,6 +1459,7 @@ test_that("W Gauge r&R report plot matches", { options$reportMeasurementsByOperatorPlot <- TRUE options$reportAverageChartByOperator <- TRUE options$reportPartByOperatorPlot <- TRUE + options$mcmcChains <- 2 set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) plotName <- results[["results"]][["report"]][["data"]] From 6b897281f1d1a85cedc8a032482532ab1de99447 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 22 Jul 2025 20:29:34 +0200 Subject: [PATCH 53/65] Moving ready checks into functions (1) --- R/msaBayesianGaugeRR.R | 66 ++++++++++++++++++++++++++++-------------- 1 file changed, 45 insertions(+), 21 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index c6a91e3b..f84486d0 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -68,7 +68,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # insert report here - if(ready && options$report) { + if(options$report) { .createGaugeReport(jaspResults, dataset = dataWide, measurements = measurementsWide, parts, operators, options, ready) } else { @@ -84,24 +84,24 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # prior - if(ready && options$priorPlot) { - .plotPrior(jaspResults, options) + if(options$priorPlot) { + .plotPrior(jaspResults, options, ready) } # MCMC diagnostics - if(ready) { - if(options$diagnosticsTable || options$diagnosticsPlots) { - .mcmcDiagnostics(jaspResults, parts, operators, options) - } + if(options$diagnosticsTable || options$diagnosticsPlots) { + .mcmcDiagnostics(jaspResults, parts, operators, options, ready) } # posteriors - if(ready && options$posteriorPlot){ - .fillPostSummaryTable(jaspResults, options, parts, operators) - .plotVariancePosteriors(jaspResults, options, parts, operators) + if(options$posteriorPlot){ + if(ready) { + .fillPostSummaryTable(jaspResults, options, parts, operators) + } + .plotVariancePosteriors(jaspResults, options, parts, operators, ready) # summary table - .createPostSummaryTable(jaspResults, options, parts, operators) + .createPostSummaryTable(jaspResults, options, parts, operators, ready) } if(ready && options$varianceComponentsGraph) { @@ -258,7 +258,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.createPostSummaryTable <- function(jaspResults, options, parts, operators){ +.createPostSummaryTable <- function(jaspResults, options, parts, operators, ready){ if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]]) || isTryError(jaspResults[["distFit"]][["object"]])){ return() @@ -272,6 +272,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["variancePosteriors"]][["postSummary"]] <- postSummary # title for point estimate + # note: probably best to change that for translation pointEst <- switch (options$posteriorPointEstimateType, "mean" = "Mean", "mode" = "Mode", @@ -301,6 +302,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) } + if(!ready) { + return() + } + postSummary$setData(jaspResults[["postSummaryStats"]][["object"]]) return() @@ -559,7 +564,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.plotPrior <- function(jaspResults, options) { +.plotPrior <- function(jaspResults, options, ready) { if(!is.null(jaspResults[["priorPlot"]])) { return() } @@ -570,6 +575,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { gPrior <- createJaspPlot(title = gettext("g-prior"), width = 600, height = 320) + if(!ready) { + priorPlot[["plot"]] <- gPrior + return() + } + # axis limit xUpper <- extraDistr::qinvchisq(0.75, nu = 1, tau = options$rscalePrior^2) xBreaks <- jaspGraphs::getPrettyAxisBreaks(c(0, xUpper)) @@ -593,7 +603,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } ### posterior plots -.plotVariancePosteriors <- function(jaspResults, options, parts, operators){ +.plotVariancePosteriors <- function(jaspResults, options, parts, operators, ready){ if(!is.null(jaspResults[["variancePosteriors"]])){ return() @@ -605,6 +615,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .postPlotDependencies())) jaspResults[["variancePosteriors"]] <- variancePosteriors + if(!ready) { + jaspResults[["variancePosteriors"]][["plot"]] <- createJaspPlot(width = 600, height = 320) + return() + } + fits <- jaspResults[["distFit"]][["object"]] if(isTryError(fits)) { @@ -1898,7 +1913,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ### MCMC diagnostics ## main function -.mcmcDiagnostics <- function(jaspResults, parts, operators, options) { +.mcmcDiagnostics <- function(jaspResults, parts, operators, options, ready) { if(!is.null(jaspResults[["mcmcDiagnostics"]])) { return() } @@ -1909,12 +1924,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { "diagnosticsTable")) jaspResults[["mcmcDiagnostics"]] <- mcmcDiagnostics - # general input needed for the sub-functions - chains <- jaspResults[["MCMCsamples"]][["object"]] - excludeInter <- .evalInter(jaspResults, parts, operators, options) - - paramNames <- .bfParameterNames(parts, operators, excludeInter, options) - paramNames <- c(paramNames, "sig2") + # initialize plot if data is not ready + if(options$diagnosticsPlots && !ready) { + jaspResults[["mcmcDiagnostics"]][["plot"]] <- createJaspPlot(width = 600, height = 320) + } if(options$diagnosticsTable) { diagnosticsTable <- createJaspTable() @@ -1929,6 +1942,17 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { diagnosticsTable$addColumnInfo(name = "mcseQuantileLower", title = gettext("0.025"), type = "number", overtitle = gettext("MCSE (Quantiles)")) diagnosticsTable$addColumnInfo(name = "mcseQuantileUpper", title = gettext("0.975"), type = "number", overtitle = gettext("MCSE (Quantiles)")) + if(!ready) { + return() + } + + # general input needed for the sub-functions + chains <- jaspResults[["MCMCsamples"]][["object"]] + excludeInter <- .evalInter(jaspResults, parts, operators, options) + + paramNames <- .bfParameterNames(parts, operators, excludeInter, options) + paramNames <- c(paramNames, "sig2") + fillDat <- .fillDiagnosticsTable(chains = posterior::as_draws_array(chains), paramNames = .convertOutputNames(paramNames, parts, operators, includeSigma = TRUE)) From 4023969e391d1c48722a1dafeebacf6ab837bff6 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 23 Jul 2025 11:41:27 +0200 Subject: [PATCH 54/65] Moving ready checks into functions (2) --- R/msaBayesianGaugeRR.R | 141 +++++++++++++++++++++++++++++------------ 1 file changed, 99 insertions(+), 42 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index f84486d0..15435bd6 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -85,7 +85,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # prior if(options$priorPlot) { - .plotPrior(jaspResults, options, ready) + .plotPrior(jaspResults, options) } # MCMC diagnostics @@ -104,13 +104,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .createPostSummaryTable(jaspResults, options, parts, operators, ready) } - if(ready && options$varianceComponentsGraph) { - .createVarCompPlot(jaspResults, options) + if(options$varianceComponentsGraph) { + .createVarCompPlot(jaspResults, options, ready) } # contour plot - if(ready && options$contourPlot) { - .createContourPlot(jaspResults, parts, operators, measurements, dataset, options) + if(options$contourPlot) { + .createContourPlot(jaspResults, parts, operators, measurements, dataset, options, ready) } # range chart @@ -129,20 +129,20 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # measurement by part plot - if(ready && options$partMeasurementPlot) { - .createMeasureByPartPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options) + if(options$partMeasurementPlot) { + .createMeasureByPartPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready) } - if(ready && options$operatorMeasurementPlot) { + if(options$operatorMeasurementPlot) { .createMeasureByOperatorPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready, Type3 = options$type3) } - if(ready && options$partByOperatorMeasurementPlot) { + if(options$partByOperatorMeasurementPlot) { .createPartByOperatorInterPlot(jaspResults, dataset = dataWide, measurements = measurementsWide, operators, parts, options, ready, Type3 = options$type3) } - if(ready && options$trafficLightChart) { - .createTrafficLightPlot(jaspResults, options) + if(options$trafficLightChart) { + .createTrafficLightPlot(jaspResults, options, ready) } } } @@ -467,7 +467,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } #### Plots -.createContourPlot <- function(jaspResults, parts, operators, measurements, dataset, options) { +.createContourPlot <- function(jaspResults, parts, operators, measurements, dataset, options, ready) { if(!is.null(jaspResults[["contourPlot"]])) { return() } @@ -483,6 +483,21 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { tempPlot <- createJaspPlot(width = 600, height = 600) tempPlot$position <- 2 + # table with the posterior means and CrIs for the risks + risksTable <- createJaspTable(title = gettext("Producer's (\u03b4) and Consumer's (\u03b2) Risk")) + risksTable$position <- 1 + + risksTable$addColumnInfo(name = "risks", title = gettext("Risk"), type = "string") + risksTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") + risksTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval")) + risksTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval")) + + if(!ready) { + contourPlot[["plot"]] <- tempPlot + contourPlot[["table"]] <- risksTable + return() + } + samplesMat <- .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]) excludeInter <- .evalInter(jaspResults, parts, operators, options) compDf <-.getComponentsFromSamples(jaspResults, parts, operators, options, excludeInter) @@ -542,15 +557,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { contourPlot[["plot"]] <- tempPlot - # table with the posterior means and CrIs for the risks - risksTable <- createJaspTable(title = gettext("Producer's (\u03b4) and Consumer's (\u03b2) Risk")) - risksTable$position <- 1 - - risksTable$addColumnInfo(name = "risks", title = gettext("Risk"), type = "string") - risksTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - risksTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval")) - risksTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval")) - + # fill risk table fillDat <- .getRisks(contourDf, mu, options) if(isTryError(fillDat)) { @@ -564,22 +571,17 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.plotPrior <- function(jaspResults, options, ready) { +.plotPrior <- function(jaspResults, options) { if(!is.null(jaspResults[["priorPlot"]])) { return() } priorPlot <- createJaspContainer(title = gettext("Prior Distribution")) priorPlot$position <- 5 - priorPlot$dependOn(c("rscalePrior", "report")) + priorPlot$dependOn(c("rscalePrior", "report", "priorPlot")) jaspResults[["priorPlot"]] <- priorPlot gPrior <- createJaspPlot(title = gettext("g-prior"), width = 600, height = 320) - if(!ready) { - priorPlot[["plot"]] <- gPrior - return() - } - # axis limit xUpper <- extraDistr::qinvchisq(0.75, nu = 1, tau = options$rscalePrior^2) xBreaks <- jaspGraphs::getPrettyAxisBreaks(c(0, xUpper)) @@ -736,8 +738,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["rChart"]] <- createJaspContainer(gettext("Range chart by operator")) jaspResults[["rChart"]]$position <- 7 jaspResults[["rChart"]]$dependOn(c("rChart", "measurementLongFormat", - "measurementsWideFormat", "report")) + "measurementsWideFormat", "report", + "operatorWideFormat", "operatorLongFormat", + "partWideFormat", "partLongFormat")) jaspResults[["rChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) + if (ready) { rChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "R", stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], @@ -758,8 +763,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["xBarChart"]] <- createJaspContainer(gettext("Average chart by operator")) jaspResults[["xBarChart"]]$position <- 8 jaspResults[["xBarChart"]]$dependOn(c("xBarChart", "measurementLongFormat", - "measurementsWideFormat", "report")) + "measurementsWideFormat", "report", + "operatorWideFormat", "operatorLongFormat", + "partWideFormat", "partLongFormat")) jaspResults[["xBarChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) + if (ready) { xBarChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "xBar", xBarSdType = "r", stages = operators, @@ -775,25 +783,46 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { .createScatterPlotOperators <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { - if(!is.null(jaspResults[["gaugeScatterOperators"]]) || !ready) { + if(!is.null(jaspResults[["gaugeScatterOperators"]])) { return() } - jaspResults[["gaugeScatterOperators"]] <- .gaugeScatterPlotOperators(jaspResults = jaspResults, dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready) + jaspResults[["gaugeScatterOperators"]] <- createJaspPlot(title = gettext("Matrix plot for operators"), + width = 700, height = 700) jaspResults[["gaugeScatterOperators"]]$position <- 9 - jaspResults[["gaugeScatterOperators"]]$dependOn(c("scatterPlot", "scatterPlotFitLine", "scatterPlotOriginLine")) + jaspResults[["gaugeScatterOperators"]]$dependOn(c("scatterPlot", "scatterPlotFitLine", "scatterPlotOriginLine", + "operatorWideFormat", "operatorLongFormat", + "partWideFormat", "partLongFormat", + "measurementsWideFormat", "measurementLongFormat", "report")) + + if(!ready) { + return() + } + + jaspResults[["gaugeScatterOperators"]]$plotObject <- .gaugeScatterPlotOperators(jaspResults, dataset, measurements, + parts, operators, options, ready)$plotObject return() } -.createMeasureByPartPlot <- function(jaspResults, dataset, measurements, operators, parts, options) { +.createMeasureByPartPlot <- function(jaspResults, dataset, measurements, operators, parts, options, ready) { if (!is.null(jaspResults[["gaugeByPart"]])) { return() } - jaspResults[["gaugeByPart"]] <- .gaugeByPartGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options) + jaspResults[["gaugeByPart"]] <- createJaspPlot(title = gettext("Measurements by part"), + width = 700, height = 300) jaspResults[["gaugeByPart"]]$position <- 10 - jaspResults[["gaugeByPart"]]$dependOn("partMeasurementPlotAllValues") + jaspResults[["gaugeByPart"]]$dependOn(c("partMeasurementPlot", "partMeasurementPlotAllValues", "operatorWideFormat", + "operatorLongFormat", "partWideFormat", "partLongFormat", + "measurementsWideFormat", "measurementLongFormat", "report")) + + if(!ready) { + return() + } + + jaspResults[["gaugeByPart"]]$plotObject <- .gaugeByPartGraphPlotObject(dataset, measurements, parts, operators, + displayAll = options$partMeasurementPlotAllValues) return() } @@ -803,9 +832,18 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } - jaspResults[["gaugeByOperator"]] <- .gaugeByOperatorGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) + jaspResults[["gaugeByOperator"]] <- createJaspPlot(title = gettext("Measurements by operator"), + width = 600, height = 600) jaspResults[["gaugeByOperator"]]$position <- 11 - jaspResults[["gaugeByOperator"]]$dependOn("operatorMeasurementPlot") + jaspResults[["gaugeByOperator"]]$dependOn(c("operatorMeasurementPlot", "operatorWideFormat", "operatorLongFormat", + "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "report")) + + if(!ready) { + return() + } + + jaspResults[["gaugeByOperator"]]$plotObject <- .gaugeByOperatorGraphPlotObject(dataset, measurements, parts, operators, options, Type3) return() } @@ -815,14 +853,23 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } - jaspResults[["gaugeByInteraction"]] <- .gaugeByInteractionGraph(dataset = dataset, measurements = measurements, parts = parts, operators = operators, options = options, ready = ready, Type3 = Type3) + jaspResults[["gaugeByInteraction"]] <- createJaspPlot(title = gettext("Part by operator interaction"), + width = 700, height = 400) jaspResults[["gaugeByInteraction"]]$position <- 12 - jaspResults[["gaugeByInteraction"]]$dependOn("partByOperatorMeasurementPlot") + jaspResults[["gaugeByInteraction"]]$dependOn(c("partByOperatorMeasurementPlot", "operatorWideFormat", "operatorLongFormat", + "partWideFormat", "partLongFormat", "measurementsWideFormat", + "measurementLongFormat", "report")) + + if(!ready) { + return() + } + + jaspResults[["gaugeByInteraction"]]$plotObject <- .gaugeByInteractionGraphPlotFunction(dataset, measurements, parts, operators, options, Type3 = Type3, ggPlot = TRUE) return() } -.createVarCompPlot <- function(jaspResults, options, plotOnly = FALSE) { +.createVarCompPlot <- function(jaspResults, options, ready, plotOnly = FALSE) { if(!plotOnly) { if(!is.null(jaspResults[["varCompPlot"]])) { return() @@ -833,6 +880,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { "tolerance", "toleranceValue", "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) jaspResults[["varCompPlot"]] <- varCompPlot + + if(!ready) { + return() + } } # obtain summaries percContrib <- .percentSampleSummaries(jaspResults[["percContribSamples"]][["object"]], options) @@ -879,7 +930,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.createTrafficLightPlot <- function(jaspResults, options, plotOnly = FALSE) { +.createTrafficLightPlot <- function(jaspResults, options, ready, plotOnly = FALSE) { if(!plotOnly) { if(!is.null(jaspResults[["trafficPlot"]])) { return() @@ -891,7 +942,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { "tolerance", "toleranceValue", "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) jaspResults[["trafficPlot"]] <- trafficPlot + + if(!ready) { + jaspResults[["trafficPlot"]][["plot"]] <- createJaspPlot(width = 1000) + return() + } } + # % Study var percStudyVar <- .percentSampleSummaries(jaspResults[["percStudySamples"]][["object"]], options) percStudyVar <- percStudyVar[percStudyVar$sourceName == "Total gauge r&R", ] From e51ca4c2776fe3dc45915f8f07389c6ecfa51826 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 23 Jul 2025 15:48:59 +0200 Subject: [PATCH 55/65] Moving ready checks into functions (3) --- R/msaBayesianGaugeRR.R | 64 +++++++++++++++++++----------------------- 1 file changed, 29 insertions(+), 35 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 15435bd6..9836dae3 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -41,32 +41,28 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { measurementsWide <- options[["measurementsWide"]] # Results from model comparison - if(ready){ - bfTest <- .runBFtest(jaspResults, dataset, measurements, parts, operators, options) - } + bfTest <- .runBFtest(jaspResults, dataset, measurements, parts, operators, options, ready) # Model comparison table if(options[["RRTable"]] && !options$report){ .createBFtable(jaspResults, dataset, options, measurements, parts, operators, ready) } - if(ready) { - # MCMC - .runMCMC(jaspResults, dataset, measurements, parts, operators, options) - - # compute percentages - .getStudyVariation(jaspResults, parts, operators, options) - .getPercContrib(jaspResults, parts, operators, options) - .getPercStudy(jaspResults) + # MCMC + .runMCMC(jaspResults, dataset, measurements, parts, operators, options, ready) - if(options$tolerance) { - .getPercTol(jaspResults, options) - } + # compute percentages + .getStudyVariation(jaspResults, parts, operators, options, ready) + .getPercContrib(jaspResults, parts, operators, options, ready) + .getPercStudy(jaspResults, ready) - # fit distribution to samples - .fitDistToSamples(jaspResults, options) + if(options$tolerance) { + .getPercTol(jaspResults, options, ready) } + # fit distribution to samples + .fitDistToSamples(jaspResults, options, ready) + # insert report here if(options$report) { .createGaugeReport(jaspResults, dataset = dataWide, measurements = measurementsWide, parts, operators, options, ready) @@ -95,9 +91,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # posteriors if(options$posteriorPlot){ - if(ready) { - .fillPostSummaryTable(jaspResults, options, parts, operators) - } + .fillPostSummaryTable(jaspResults, options, parts, operators, ready) .plotVariancePosteriors(jaspResults, options, parts, operators, ready) # summary table @@ -388,8 +382,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.runBFtest <- function(jaspResults, dataset, measurements, parts, operators, options) { - if(is.null(jaspResults[["modelComparison"]])) { +.runBFtest <- function(jaspResults, dataset, measurements, parts, operators, options, ready) { + if(is.null(jaspResults[["modelComparison"]]) && ready) { modelComparison <- createJaspState() modelComparison$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", "measurementLongFormat", "seed", "setSeed", "rscalePrior")) @@ -987,8 +981,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } #### Models & statistical computations -.runMCMC <- function(jaspResults, dataset, measurements, parts, operators, options){ - if(is.null(jaspResults[["MCMCsamples"]])){ +.runMCMC <- function(jaspResults, dataset, measurements, parts, operators, options, ready){ + if(is.null(jaspResults[["MCMCsamples"]]) && ready){ MCMCsamples <- createJaspState() MCMCsamples$dependOn(.mcmcDependencies()) jaspResults[["MCMCsamples"]] <- MCMCsamples @@ -1274,8 +1268,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } -.getPercContrib <- function(jaspResults, parts, operators, options) { - if(is.null(jaspResults[["percContribSamples"]])) { +.getPercContrib <- function(jaspResults, parts, operators, options, ready) { + if(is.null(jaspResults[["percContribSamples"]]) && ready) { percContribSamples <- createJaspState() percContribSamples$dependOn(.varCompTableDependencies()) jaspResults[["percContribSamples"]] <- percContribSamples @@ -1299,8 +1293,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.getPercStudy <- function(jaspResults, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { - if(is.null(jaspResults[["percStudySamples"]])) { +.getPercStudy <- function(jaspResults, ready, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { + if(is.null(jaspResults[["percStudySamples"]]) && ready) { percStudySamples <- createJaspState() percStudySamples$dependOn(c(.varCompTableDependencies(), "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) @@ -1319,8 +1313,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.getPercTol <- function(jaspResults, options, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { - if(is.null(jaspResults[["percTolSamples"]])) { +.getPercTol <- function(jaspResults, options, ready, studyVar = jaspResults[["studyVariation"]][["object"]][[1]]) { + if(is.null(jaspResults[["percTolSamples"]]) && ready) { percTolSamples <- createJaspState() percTolSamples$dependOn(c(.varCompTableDependencies(), "studyVarianceMultiplierType", "studyVarianceMultiplierValue", "tolerance", "toleranceValue")) @@ -1339,8 +1333,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.getStudyVariation <- function(jaspResults, parts, operators, options) { - if(is.null(jaspResults[["studyVariation"]])) { +.getStudyVariation <- function(jaspResults, parts, operators, options, ready) { + if(is.null(jaspResults[["studyVariation"]]) && ready) { studyVariation <- createJaspState() studyVariation$dependOn(c(.varCompTableDependencies(), "studyVarianceMultiplierType", "studyVarianceMultiplierValue")) @@ -1634,8 +1628,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { #### Distribution fitting ### fit functions -.fitDistToSamples <- function(jaspResults, options) { - if(is.null(jaspResults[["distFit"]])){ +.fitDistToSamples <- function(jaspResults, options, ready) { + if(is.null(jaspResults[["distFit"]]) && ready){ distFit <- createJaspState() distFit$dependOn(c(.mcmcDependencies(), "distType", "posteriorPlotType", "processVariationReference", "historicalSdValue", @@ -1712,8 +1706,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { #### posterior summary -.fillPostSummaryTable <- function(jaspResults, options, parts, operators) { - if(is.null(jaspResults[["postSummaryStats"]]) && (options$posteriorCi || options$posteriorPointEstimate)){ +.fillPostSummaryTable <- function(jaspResults, options, parts, operators, ready) { + if(is.null(jaspResults[["postSummaryStats"]]) && (options$posteriorCi || options$posteriorPointEstimate) && ready){ postSummaryStats <- createJaspState() postSummaryStats$dependOn(c(.varCompTableDependencies(), .postPlotDependencies())) From bf564d7154f9d173c929dfaed702299e80f07ed8 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 23 Jul 2025 16:44:51 +0200 Subject: [PATCH 56/65] Clean up & translation - clean up & adding dependencies - assigning colnames to data frames within the .fillTablesGaugeEval function - fixing translation - removing some unnecessary QML code --- R/msaBayesianGaugeRR.R | 25 +++++++++++++------------ inst/qml/msaBayesianGaugeRR.qml | 5 ----- 2 files changed, 13 insertions(+), 17 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 9836dae3..2791c49b 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -266,11 +266,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["variancePosteriors"]][["postSummary"]] <- postSummary # title for point estimate - # note: probably best to change that for translation pointEst <- switch (options$posteriorPointEstimateType, - "mean" = "Mean", - "mode" = "Mode", - "median" = "Median" + "mean" = gettext("Mean"), + "mode" = gettext("Mode"), + "median" = gettext("Median") ) # overtitle for CrI @@ -287,7 +286,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { postSummary$addColumnInfo(name = "parameter", title = gettext("Source"), type = "string") if(options$posteriorPointEstimate) { - postSummary$addColumnInfo(name = "pointEstimate", title = gettext(pointEst), type = "number") + postSummary$addColumnInfo(name = "pointEstimate", title = pointEst, type = "number") } if(options$posteriorCi) { @@ -332,9 +331,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(ready) { stdData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "sd") - colnames(stdData) <- c("sourceName", "meansStd", "lowerStd", "upperStd") # note: this could already be part of the function + studyVarData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "studyVar")[, -1] # remove source name - colnames(studyVarData) <- c("meansStudyVar", "lowerStudyVar", "upperStudyVar") stdTable$setData(cbind(stdData, studyVarData)) stdTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) @@ -367,13 +365,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(ready) { percStudyData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percStudyVar") - colnames(percStudyData) <- c("sourceName", "meansPercStudy", "lowerPercStudy", "upperPercStudy") if(!options$tolerance) { percStudyVarTable$setData(percStudyData) } else { percTolData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "percTol")[, -1] - colnames(percTolData) <- c("meansPercTol", "lowerPercTol", "upperPercTol") percStudyVarTable$setData(cbind(percStudyData, percTolData)) } percStudyVarTable$addFootnote(gettext("Credible intervals are estimated based on the MCMC samples.")) @@ -386,7 +382,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(is.null(jaspResults[["modelComparison"]]) && ready) { modelComparison <- createJaspState() modelComparison$dependOn(c("operatorWideFormat", "operatorLongFormat", "partWideFormat", "partLongFormat", "measurementsWideFormat", - "measurementLongFormat", "seed", "setSeed", "rscalePrior")) + "measurementLongFormat", "seed", "setSeed", "rscalePrior", "type3")) jaspResults[["modelComparison"]] <- modelComparison } else { return() @@ -399,7 +395,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(options$type3){ formula <- as.formula(paste(measurements, "~", parts)) bfFit <- try(BayesFactor::generalTestBF(formula, data = dataset, - whichRandom = c(operators, parts), + whichRandom = parts, rscaleRandom = options$rscalePrior, progress = FALSE)) @@ -1599,8 +1595,13 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { df[df$sourceName == "Total variation", c("lower", "upper")] <- "" } - return(df) + colnames(df) <- switch(whichTable, + "sd" = c("sourceName", "meansStd", "lowerStd", "upperStd"), + "studyVar" = c("sourceName", "meansStudyVar", "lowerStudyVar", "upperStudyVar"), + "percStudyVar" = c("sourceName", "meansPercStudy", "lowerPercStudy", "upperPercStudy"), + "percTol" = c("sourceName", "meansPercTol", "lowerPercTol", "upperPercTol")) + return(df) } .convertToWide <- function(dataset, measurements, parts, operators) { diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index cd829fe0..3665d65b 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -120,11 +120,6 @@ Form name: "type3" id: type3 label: qsTr("Type 3 study (automatic equipment)") - onCheckedChanged: - { - operatorLongFormat.itemDoubleClicked(0) - operatorWideFormat.itemDoubleClicked(0) - } } Group From eb5fcbeed80d6f030e63df338180d7baf5944641 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 23 Jul 2025 17:34:35 +0200 Subject: [PATCH 57/65] Update renv.lock --- renv.lock | 1 - 1 file changed, 1 deletion(-) diff --git a/renv.lock b/renv.lock index fd8bc841..d581c0ef 100644 --- a/renv.lock +++ b/renv.lock @@ -2045,7 +2045,6 @@ "utils" ] }, - "rmetalog": { "Package": "rmetalog", "Version": "1.0.3", From 1bd5eb44e5d68239db2102baa593cb158185850f Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 23 Jul 2025 17:52:30 +0200 Subject: [PATCH 58/65] Update renv.lock --- renv.lock | 1 + 1 file changed, 1 insertion(+) diff --git a/renv.lock b/renv.lock index d581c0ef..56be443c 100644 --- a/renv.lock +++ b/renv.lock @@ -334,6 +334,7 @@ "Version": "1.13.0", "Source": "Repository", "Repository": "CRAN" + }, "beeswarm": { "Package": "beeswarm", "Version": "0.4.0", From 7778f4b48c8759375187ceb1bfe2e7cd9dff2f6f Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 23 Jul 2025 18:17:15 +0200 Subject: [PATCH 59/65] Update renv.lock --- renv.lock | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/renv.lock b/renv.lock index 56be443c..890e6f6c 100644 --- a/renv.lock +++ b/renv.lock @@ -109,6 +109,12 @@ "utils" ] }, + "GeneralizedHyperbolic": { + "Package": "GeneralizedHyperbolic", + "Version": "0.8-7", + "Source": "Repository", + "Repository": "CRAN" + }, "GPArotation": { "Package": "GPArotation", "Version": "2025.3-1", @@ -118,12 +124,6 @@ "stats" ] }, - "GeneralizedHyperbolic": { - "Package": "GeneralizedHyperbolic", - "Version": "0.8-7", - "Source": "Repository", - "Repository": "CRAN" - }, "HDInterval": { "Package": "HDInterval", "Version": "0.2.4", @@ -601,12 +601,9 @@ }, "data.table": { "Package": "data.table", - "Version": "1.17.4", + "Version": "1.17.8", "Source": "Repository", - "Requirements": [ - "methods", - "R" - ] + "Repository": "CRAN" }, "deSolve": { "Package": "deSolve", @@ -2046,12 +2043,6 @@ "utils" ] }, - "rmetalog": { - "Package": "rmetalog", - "Version": "1.0.3", - "Source": "Repository", - "Repository": "CRAN" - }, "rmarkdown": { "Package": "rmarkdown", "Version": "2.29", @@ -2073,6 +2064,12 @@ "yaml" ] }, + "rmetalog": { + "Package": "rmetalog", + "Version": "1.0.3", + "Source": "Repository", + "Repository": "CRAN" + }, "rpart": { "Package": "rpart", "Version": "4.1.24", From b1ee3744d4aa5d2cb4b90de91db775a3f072cb15 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Wed, 23 Jul 2025 20:11:52 +0200 Subject: [PATCH 60/65] Adjusting analysis to changes in other analyses - Adjusting use of .controlChart function and unit tests - Fixing translation issues --- R/msaBayesianGaugeRR.R | 55 +++++++++++++----------- tests/testthat/test-msaBayesianGaugeRR.R | 19 ++++---- 2 files changed, 40 insertions(+), 34 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 2791c49b..fd288962 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -156,7 +156,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { BFtable$addColumnInfo(name = "modelName", title = gettext("Models"), type = "string") BFtable$addColumnInfo(name = "comparisonBF", title = gettext("BF10"), type = "number") - BFtable$addColumnInfo(name = "error", title = gettext("error %"), type = "number") + BFtable$addColumnInfo(name = "error", title = gettextf("error %%"), type = "number") # check for errors & set data if(ready) { @@ -195,8 +195,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { varCompTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") varCompTable$addColumnInfo(name = "postMeans", title = gettext("Mean"), type = "number") varCompTable$addColumnInfo(name = "postSds", title = gettext("Std. Deviation"), type = "number") - varCompTable$addColumnInfo(name = "postCrIlower", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval")) - varCompTable$addColumnInfo(name = "postCrIupper", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval")) + varCompTable$addColumnInfo(name = "postCrIlower", title = gettext("Lower"), type = "number", overtitle = gettextf("95%% Credible Interval")) + varCompTable$addColumnInfo(name = "postCrIupper", title = gettext("Upper"), type = "number", overtitle = gettextf("95%% Credible Interval")) # set data if(ready) { @@ -232,14 +232,14 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(!is.null(jaspResults[["contribTable"]])) { return() } - contribTable <- createJaspTable(title = gettext("% Contribution to Total Variation")) + contribTable <- createJaspTable(title = gettextf("%% Contribution to Total Variation")) contribTable$position <- 3 contribTable$dependOn(.varCompTableDependencies()) jaspResults[["contribTable"]] <- contribTable contribTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") contribTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - overTitle <- gettext("95% Credible Interval") + overTitle <- gettextf("95%% Credible Interval") contribTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = overTitle) contribTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = overTitle) @@ -323,11 +323,11 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { stdTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") stdTable$addColumnInfo(name = "meansStd", title = gettext("Mean
Std"), type = "number") - stdTable$addColumnInfo(name = "lowerStd", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval
Std")) - stdTable$addColumnInfo(name = "upperStd", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval
Std")) + stdTable$addColumnInfo(name = "lowerStd", title = gettext("Lower"), type = "number", overtitle = gettextf("95%% Credible Interval
Std")) + stdTable$addColumnInfo(name = "upperStd", title = gettext("Upper"), type = "number", overtitle = gettextf("95%% Credible Interval
Std")) stdTable$addColumnInfo(name = "meansStudyVar", title = gettext("Mean
Study Variation"), type = "number") - stdTable$addColumnInfo(name = "lowerStudyVar", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval
Study Variation")) - stdTable$addColumnInfo(name = "upperStudyVar", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval
Study Variation")) + stdTable$addColumnInfo(name = "lowerStudyVar", title = gettext("Lower"), type = "number", overtitle = gettextf("95%% Credible Interval
Study Variation")) + stdTable$addColumnInfo(name = "upperStudyVar", title = gettext("Upper"), type = "number", overtitle = gettextf("95%% Credible Interval
Study Variation")) if(ready) { stdData <- .fillTablesGaugeEval(jaspResults, parts, operators, options, whichTable = "sd") @@ -344,23 +344,23 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { ### Percent study variation & percent tolerance table if(options$tolerance) { - title <- gettext("% Study Variation & % Tolerance") + title <- gettextf("%% Study Variation & %% Tolerance") } else { - title <- gettext("% Study Variation") + title <- gettextf("%% Study Variation") } percStudyVarTable <- createJaspTable(title = title) percStudyVarTable$position <- 2 gaugeEvaluation[["percStudyVarTable"]] <- percStudyVarTable - percStudyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") - percStudyVarTable$addColumnInfo(name = "meansPercStudy", title = gettext("Mean
% Study Variation"), type = "number") - percStudyVarTable$addColumnInfo(name = "lowerPercStudy", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval
% Study Variation")) - percStudyVarTable$addColumnInfo(name = "upperPercStudy", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval
% Study Variation")) + percStudyVarTable$addColumnInfo(name = "sourceName", title = gettext("Source"), type = "string") + percStudyVarTable$addColumnInfo(name = "meansPercStudy", title = gettextf("Mean
%% Study Variation"), type = "number") + percStudyVarTable$addColumnInfo(name = "lowerPercStudy", title = gettext("Lower"), type = "number", overtitle = gettextf("95%% Credible Interval
%% Study Variation")) + percStudyVarTable$addColumnInfo(name = "upperPercStudy", title = gettext("Upper"), type = "number", overtitle = gettextf("95%% Credible Interval
%% Study Variation")) if(options$tolerance) { - percStudyVarTable$addColumnInfo(name = "meansPercTol", title = gettext("Mean
% Tolerance"), type = "number") - percStudyVarTable$addColumnInfo(name = "lowerPercTol", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval
% Tolerance")) - percStudyVarTable$addColumnInfo(name = "upperPercTol", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval
% Tolerance")) + percStudyVarTable$addColumnInfo(name = "meansPercTol", title = gettextf("Mean
%% Tolerance"), type = "number") + percStudyVarTable$addColumnInfo(name = "lowerPercTol", title = gettext("Lower"), type = "number", overtitle = gettextf("95%% Credible Interval
%% Tolerance")) + percStudyVarTable$addColumnInfo(name = "upperPercTol", title = gettext("Upper"), type = "number", overtitle = gettextf("95%% Credible Interval
%% Tolerance")) } if(ready) { @@ -479,8 +479,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { risksTable$addColumnInfo(name = "risks", title = gettext("Risk"), type = "string") risksTable$addColumnInfo(name = "means", title = gettext("Mean"), type = "number") - risksTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = gettext("95% Credible Interval")) - risksTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = gettext("95% Credible Interval")) + risksTable$addColumnInfo(name = "lower", title = gettext("Lower"), type = "number", overtitle = gettextf("95%% Credible Interval")) + risksTable$addColumnInfo(name = "upper", title = gettext("Upper"), type = "number", overtitle = gettextf("95%% Credible Interval")) if(!ready) { contourPlot[["plot"]] <- tempPlot @@ -734,7 +734,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["rChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) if (ready) { - rChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "R", + ruleList <- .getRuleListSubgroupCharts(options, type = "R") + rChart <- .controlChart(dataset = dataset[c(measurements, operators)], plotType = "R", ruleList = ruleList, stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], stagesSeparateCalculation = FALSE) @@ -759,8 +760,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { jaspResults[["xBarChart"]][["plot"]] <- createJaspPlot(width = 1200, height = 500) if (ready) { + ruleList <- .getRuleListSubgroupCharts(options, type = "xBar") xBarChart <- .controlChart(dataset = dataset[c(measurements, operators)], - plotType = "xBar", xBarSdType = "r", stages = operators, + plotType = "xBar", ruleList = ruleList, xBarSdType = "r", stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], stagesSeparateCalculation = FALSE) @@ -2216,8 +2218,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { plotIndexCounter <- plotIndexCounter + 1 } if (options[["reportRChartByOperator"]]) { + ruleList1 <- .getRuleListSubgroupCharts(options, "R") plots[[plotIndexCounter]] <- .controlChart(dataset = dataset[c(measurements, operators)], - plotType = "R", stages = operators, + plotType = "R", ruleList = ruleList1, stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], stagesSeparateCalculation = FALSE)$plotObject plotIndexCounter <- plotIndexCounter + 1 @@ -2227,8 +2230,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { plotIndexCounter <- plotIndexCounter + 1 } if (options[["reportAverageChartByOperator"]]) { + ruleList2 <- .getRuleListSubgroupCharts(options, "xBar") plots[[plotIndexCounter]] <- .controlChart(dataset = dataset[c(measurements, operators)], - plotType = "xBar", xBarSdType = "r", stages = operators, + plotType = "xBar", ruleList = ruleList2, xBarSdType = "r", stages = operators, xAxisLabels = dataset[[parts]][order(dataset[[operators]])], stagesSeparateCalculation = FALSE)$plotObject plotIndexCounter <- plotIndexCounter + 1 @@ -2360,6 +2364,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { options$wideFormat <- wideFormat + # rule set for xBar and R charts + options$testSet <- "jaspDefault" + return(options) } diff --git a/tests/testthat/test-msaBayesianGaugeRR.R b/tests/testthat/test-msaBayesianGaugeRR.R index cd2878d5..50fdcbb3 100644 --- a/tests/testthat/test-msaBayesianGaugeRR.R +++ b/tests/testthat/test-msaBayesianGaugeRR.R @@ -232,13 +232,12 @@ test_that("L1 Test results for x-bar chart table results match", { jaspTools::expect_equal_tables(table, list("Operator A", "Point 1", "", "Point 2", "", "Point 3", "", "Point 4", "", "Point 5", "", "Point 6", "", "Point 7", "", "Point 8", - "", "Point 9", "", "Point 10", "Operator B", "Point 11", "", - "Point 12", "", "Point 13", "", "Point 14", "", "Point 15", - "", "Point 16", "", "Point 17", "", "Point 18", "", "Point 19", - "", "Point 20", "Operator C", "Point 21", "", "Point 22", "", - "Point 23", "", "Point 24", "", "Point 25", "", "Point 26", - "", "Point 27", "", "Point 28", "", "Point 29", "", "Point 30" - )) + "", "Point 9", "", "Point 10", "Operator B", "Point 1", "", + "Point 2", "", "Point 3", "", "Point 4", "", "Point 5", "", + "Point 6", "", "Point 7", "", "Point 8", "", "Point 9", "", + "Point 10", "Operator C", "Point 1", "", "Point 2", "", "Point 3", + "", "Point 4", "", "Point 5", "", "Point 6", "", "Point 7", + "", "Point 8", "", "Point 9", "", "Point 10")) }) @@ -904,7 +903,7 @@ test_that("W1 rChart wide matches", { test_that("W1 Test results for range chart table results match", { table <- results[["results"]][["rChart"]][["collection"]][["rChart_table"]][["data"]] jaspTools::expect_equal_tables(table, - list("C", "Point 30")) + list("C", "Point 10")) }) test_that("W1 Traffic light chart wide matches", { @@ -969,8 +968,8 @@ test_that("W1 Test results for x-bar chart table results match", { table <- results[["results"]][["xBarChart"]][["collection"]][["xBarChart_table"]][["data"]] jaspTools::expect_equal_tables(table, list("A", "Point 1", "", "Point 5", "", "Point 8", "", "Point 10", - "B", "Point 11", "", "Point 15", "", "Point 18", "", "Point 20", - "C", "Point 21", "", "Point 23", "", "Point 25", "", "Point 30" + "B", "Point 1", "", "Point 5", "", "Point 8", "", "Point 10", + "C", "Point 1", "", "Point 3", "", "Point 5", "", "Point 10" )) }) From e4694087ef3aed4e80319acc67513955830de70c Mon Sep 17 00:00:00 2001 From: jvli4n Date: Thu, 24 Jul 2025 10:47:10 +0200 Subject: [PATCH 61/65] Adding packages for unit tests --- DESCRIPTION | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION index 87b07305..30086768 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,9 +16,11 @@ Imports: desirability, DoE.base, EnvStats, + extraDistr, FAdist, fitdistrplus, FrF2, + GeneralizedHyperbolic, ggplot2, ggrepel, goftest, @@ -29,8 +31,10 @@ Imports: jaspGraphs, lubridate, mle.tools, + posterior, psych, qcc, + rmetalog, rsm, Rspc, tidyr, From f21e7ca4c0bde1bf46b7d554c59b6f79746296fe Mon Sep 17 00:00:00 2001 From: jvli4n Date: Thu, 24 Jul 2025 10:59:50 +0200 Subject: [PATCH 62/65] Adding packages for unit tests (2) --- DESCRIPTION | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION index 30086768..d077daec 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -10,11 +10,15 @@ Description: Investigate if a manufactured product adheres to a defined set of q License: GPL (>= 2) Encoding: UTF-8 Imports: + BayesFactor, + bayesplot, car, cowplot, daewr, desirability, DoE.base, + dplyr, + ellipse, EnvStats, extraDistr, FAdist, @@ -25,17 +29,20 @@ Imports: ggrepel, goftest, ggpp, + HDInterval, irr, jaspBase, jaspDescriptives, jaspGraphs, lubridate, mle.tools, + mvtnorm, posterior, psych, qcc, rmetalog, rsm, + rstan, Rspc, tidyr, tibble, From 923a50541b2d5be2bf0a7488ac3f935ac49cd63d Mon Sep 17 00:00:00 2001 From: jvli4n Date: Thu, 24 Jul 2025 11:46:50 +0200 Subject: [PATCH 63/65] Changes QML Making sure that plots get unchecked in case type 3 analysis is selected when the checkbox is enabled --- inst/qml/msaBayesianGaugeRR.qml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 3665d65b..7fdf4965 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -120,6 +120,14 @@ Form name: "type3" id: type3 label: qsTr("Type 3 study (automatic equipment)") + onCheckedChanged: + { + rChart.checked = false + xBarChart.checked = false + scatterPlot.checked = false + operatorMeasurementPlot.checked = false + partByOperatorMeasurementPlot.checked = false + } } Group @@ -429,6 +437,7 @@ Form CheckBox { name: "rChart" + id: rChart label: qsTr("Range charts by operator") enabled: !type3.checked } @@ -436,6 +445,7 @@ Form CheckBox { name: "xBarChart" + id: xBarChart label: qsTr("Average chart by operator") enabled: !type3.checked } @@ -444,6 +454,7 @@ Form { name: "scatterPlot" label: qsTr("Scatter plots operators") + id: scatterPlot enabled: !type3.checked CheckBox @@ -474,6 +485,7 @@ Form CheckBox { name: "operatorMeasurementPlot" + id: operatorMeasurementPlot label: qsTr("Measurements by operator plot") enabled: !type3.checked } @@ -481,6 +493,7 @@ Form CheckBox { name: "partByOperatorMeasurementPlot" + id: partByOperatorMeasurementPlot label: qsTr("Part × operator interaction plot") enabled: !type3.checked } From ecc1cc962101f9246f2ea0b1f91218732b025905 Mon Sep 17 00:00:00 2001 From: jvli4n Date: Tue, 12 Aug 2025 10:56:51 +0200 Subject: [PATCH 64/65] Querying posteriors based on cut-off - Allowing the user to query the posterior based on data cut-off - Clean-up - Corresponding changes to unit tests --- R/msaBayesianGaugeRR.R | 270 ++++++++++++++++------- inst/qml/msaBayesianGaugeRR.qml | 93 +++++--- tests/testthat/test-msaBayesianGaugeRR.R | 90 ++++---- 3 files changed, 313 insertions(+), 140 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index fd288962..0cbdd242 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -92,10 +92,9 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { # posteriors if(options$posteriorPlot){ .fillPostSummaryTable(jaspResults, options, parts, operators, ready) - .plotVariancePosteriors(jaspResults, options, parts, operators, ready) - # summary table - .createPostSummaryTable(jaspResults, options, parts, operators, ready) + # summary table & plots + .createPostSummaries(jaspResults, options, parts, operators, ready) } if(options$varianceComponentsGraph) { @@ -252,18 +251,38 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return() } -.createPostSummaryTable <- function(jaspResults, options, parts, operators, ready){ - if(!is.null(jaspResults[["variancePosteriors"]][["postSummary"]]) || - isTryError(jaspResults[["distFit"]][["object"]])){ +.createPostSummaries <- function(jaspResults, options, parts, operators, ready){ + if(!is.null(jaspResults[["posteriorSummaries"]])){ return() } + posteriorSummaries <- createJaspContainer(title = gettext("Posterior Distributions")) + posteriorSummaries$position <- 6 + posteriorSummaries$dependOn(c(.varCompTableDependencies(), + .postPlotDependencies())) + jaspResults[["posteriorSummaries"]] <- posteriorSummaries + + if(isTryError(jaspResults[["distFit"]][["object"]])) { + errorMsg <- gettextf("The %s distribution could not be fit to the samples. + Try selecting another distribution.", .getDistNames(options$distType)) + tempPlot <- createJaspPlot() + tempPlot$setError(errorMsg) + posteriorSummaries[["errorPlot"]] <- tempPlot + return() + } + + if(!ready) { + # create empty plot for posterior distributions + posteriorSummaries[["plot"]] <- createJaspPlot(width = 600, height = 320) + } + + # table postSummary <- createJaspTable(title = gettext("Posterior Summary")) postSummary$position <- 1 postSummary$dependOn(c(.varCompTableDependencies(), .postPlotDependencies())) - jaspResults[["variancePosteriors"]][["postSummary"]] <- postSummary + posteriorSummaries[["postSummary"]] <- postSummary # title for point estimate pointEst <- switch (options$posteriorPointEstimateType, @@ -290,16 +309,56 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } if(options$posteriorCi) { - postSummary$addColumnInfo(name = "ciLower", title = gettext("Lower"), type = "number", overtitle = gettext(overtitle)) - postSummary$addColumnInfo(name = "ciUpper", title = gettext("Upper"), type = "number", overtitle = gettext(overtitle)) - postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) + if(options$posteriorCiType != "custom" || (options$posteriorCiType == "custom" && options$customCiType != "customCiCutOff")) { + postSummary$addColumnInfo(name = "ciLower", title = gettext("Lower"), type = "number", overtitle = gettext(overtitle)) + postSummary$addColumnInfo(name = "ciUpper", title = gettext("Upper"), type = "number", overtitle = gettext(overtitle)) + postSummary$addFootnote(gettext("Credible intervals are estimated based on the distribution fit to the MCMC samples.")) + } else { + cutOff <- options$posteriorCiCutOff + if(cutOff == as.integer(cutOff)) { + postSummary$addColumnInfo(name = "belowCutOff", title = gettextf("p(x < %d | data)", cutOff), type = "number") + } else { + postSummary$addColumnInfo(name = "belowCutOff", title = gettextf("p(x < %.2f | data)", cutOff), type = "number") + } + } } if(!ready) { return() } - postSummary$setData(jaspResults[["postSummaryStats"]][["object"]]) + dat <- jaspResults[["postSummaryStats"]][["object"]] + errors <- .checkProbabilityEstimates(dat$belowCutOff) + dat$belowCutOff <- errors[["estimates"]] # cleaned estimates + + if(options$customCiType == "customCiCutOff") { + # check for too large cut-off + if(errors[["large"]]) { + if(cutOff == as.integer(cutOff)) { + postSummary$addFootnote(gettextf("p(x < %d | data) could not be calculated for some sources. The cut-off is probably too large or too small.", + cutOff), symbol = gettext("Warning:")) + } else { + postSummary$addFootnote(gettextf("p(x < %.2f | data) could not be calculated for some sources. The cut-off is probably too large or too small.", + cutOff), symbol = gettext("Warning:")) + } + } + + # check for negative estimates + if(errors[["negative"]]) { + if(cutOff == as.integer(cutOff)) { + postSummary$addFootnote(gettextf("Some estimates of p(x < %d | data) were negative and, therefore, removed. Try a different cut-off or distribution.", + cutOff), symbol = gettext("Warning:")) + } else { + postSummary$addFootnote(gettextf("Some estimates of p(x < %.2f | data) were negative and, therefore, removed. Try a different cut-off or distribution.", + cutOff), symbol = gettext("Warning:")) + } + } + } + + postSummary$setData(dat) + + # plots + .plotVariancePosteriors(jaspResults, options, parts, operators) return() } @@ -595,34 +654,10 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } ### posterior plots -.plotVariancePosteriors <- function(jaspResults, options, parts, operators, ready){ - - if(!is.null(jaspResults[["variancePosteriors"]])){ - return() - } - - variancePosteriors <- createJaspContainer(title = gettext("Posterior Distributions")) - variancePosteriors$position <- 6 - variancePosteriors$dependOn(c(.varCompTableDependencies(), - .postPlotDependencies())) - jaspResults[["variancePosteriors"]] <- variancePosteriors - - if(!ready) { - jaspResults[["variancePosteriors"]][["plot"]] <- createJaspPlot(width = 600, height = 320) - return() - } - +.plotVariancePosteriors <- function(jaspResults, options, parts, operators){ + dat <- jaspResults[["posteriorSummaries"]][["postSummary"]] fits <- jaspResults[["distFit"]][["object"]] - if(isTryError(fits)) { - errorMsg <- gettextf("The %s distribution could not be fit to the samples. - Try selecting another distribution.", .getDistNames(options$distType)) - tempPlot <- createJaspPlot() - tempPlot$setError(errorMsg) - jaspResults[["variancePosteriors"]][["errorPlot"]] <- tempPlot - return() - } - samplesMat <- switch(options$posteriorPlotType, "var" = .arrayToMat(jaspResults[["MCMCsamples"]][["object"]]), "percContrib" = jaspResults[["percContribSamples"]][["object"]], @@ -650,27 +685,40 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { maxHistDens <- max(pBuild$data[[1]][, "density"]) } - # select function for axis limits based on distribution - axisFun <- .axisLimFuns()[[options$distType]] - - lims <- axisFun(fits[[i]], postSummary, options, iter = i, - histDens = ifelse(options$posteriorHistogram, maxHistDens, 0)) - # credible interval if(options$posteriorCi) { - ciUpper <- postSummary[i, "ciUpper"] - ciLower <- postSummary[i, "ciLower"] - - p <- p + - if(options$distType == "metalog") { - ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), - geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") - # note: it might make sense to just pass some approximation of the density to the plotting function in case of the metalog - # so it only has to evaluate the density function once - } else { # note: this would be nicer with a list of functions again, but the functions take different arguments - ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), - geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") + if(options$posteriorCiType != "custom" || (options$posteriorCiType == "custom" && options$customCiType != "customCiCutOff")) { + ciUpper <- postSummary[i, "ciUpper"] + ciLower <- postSummary[i, "ciLower"] + + p <- p + + if(options$distType == "metalog") { + ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), + geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") + # note: it might make sense to just pass some approximation of the density to the plotting function in case of the metalog + # so it only has to evaluate the density function once + } else { # note: this would be nicer with a list of functions again, but the functions take different arguments + ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), + geom = "area", xlim = c(ciLower, ciUpper), fill = "grey") + } + } else { + + # do not plot if p(x < cut-off | data) was not computed correctly + est <- .checkProbabilityEstimates(jaspResults[["postSummaryStats"]][["object"]]$belowCutOff)[["estimates"]] + + if(!i %in% which(is.na(est))) { + p <- p + + if(options$distType == "metalog") { + ggplot2::stat_function(fun = rmetalog::dmetalog, args = list(m = fits[[i]], term = fits[[i]]$params$term_limit), + geom = "area", xlim = c(0, options$posteriorCiCutOff), fill = "grey") + # note: it might make sense to just pass some approximation of the density to the plotting function in case of the metalog + # so it only has to evaluate the density function once + } else { # note: this would be nicer with a list of functions again, but the functions take different arguments + ggplot2::stat_function(fun = GeneralizedHyperbolic::dgig, args = list(param = fits[[i]]$param), + geom = "area", xlim = c(0, options$posteriorCiCutOff), fill = "grey") + } } + } } p <- p + @@ -695,6 +743,12 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } # axes + # select function for axis limits based on distribution + axisFun <- .axisLimFuns()[[options$distType]] + + lims <- axisFun(fits[[i]], postSummary, options, iter = i, + histDens = ifelse(options$posteriorHistogram, maxHistDens, 0)) + xLab <- switch(options$posteriorPlotType, "var" = titles[i], "percContrib" = "% Contribution", @@ -715,7 +769,7 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe(sides = "bl") tempPlot$plotObject <- p - variancePosteriors[[titles[i]]] <- tempPlot + jaspResults[["posteriorSummaries"]][[titles[i]]] <- tempPlot } return() } @@ -1364,6 +1418,24 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { } #### helper functions +.checkProbabilityEstimates <- function(estimates) { + l <- list() + # check for too large cut-off + l[["large"]] <- ifelse(anyNA(estimates), TRUE, FALSE) + + # check for negative estimates + if(any(estimates[!is.na(estimates)] < 0)) { + estimates[!is.na(estimates) & estimates < 0] <- NA + l[["negative"]] <- TRUE + } else { + l[["negative"]] <- FALSE + } + + l[["estimates"]] <- estimates + + return(l) +} + .hasExtremeValues <- function(df) { nums <- unlist(df, use.names = FALSE) nums <- suppressWarnings(as.numeric(nums)) @@ -1473,7 +1545,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { return(c("posteriorCi", "posteriorCiLower", "posteriorCiMass", "posteriorCiType", "posteriorCiUpper", "posteriorPointEstimate", "posteriorPointEstimateType", "posteriorPlot", "distType", "posteriorPlotType", "tolerance", "toleranceValue", "posteriorHistogram", "report", "type3", - "processVariationReference", "historicalSdValue")) + "processVariationReference", "historicalSdValue", "customCiType", + "posteriorCiCutOff")) } .convertOutputNames <- function(name, parts, operators, includeSigma = TRUE) { @@ -1555,7 +1628,12 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { if(!gaugeReport) { # add footnote factorSd <- jaspResults[["studyVariation"]][["object"]][[2]] - jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) + + if(factorSd == as.integer(factorSd)) { + jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %d", factorSd)) + } else { + jaspResults[["gaugeEvaluation"]][["stdTable"]]$addFootnote(gettextf("Study variation is calculated as std. dev. × %.2f", factorSd)) + } } # summaries @@ -1763,25 +1841,41 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { "HPD" = Map(interFun, fits, mass = options$posteriorCiMass), "custom" = Map(interFun, fits, lower = options$posteriorCiLower, - upper = options$posteriorCiUpper)) - - # lower and upper bounds separately - lower <- sapply(intervals, function(x) x[1]) - upper <- sapply(intervals, function(x) x[2]) + upper = options$posteriorCiUpper, + cutoff = options$posteriorCiCutOff, + options = rep(list(options), length(fits))) + ) + + if(options$posteriorCiType != "custom" || (options$posteriorCiType == "custom" && options$customCiType != "customCiCutOff")) { + # lower and upper bounds separately + lower <- sapply(intervals, function(x) x[1]) + upper <- sapply(intervals, function(x) x[2]) + } } if(options$posteriorPointEstimate && options$posteriorCi == FALSE) { df <- data.frame(parameter, pointEstimate) } else if(options$posteriorPointEstimate == FALSE && options$posteriorCi) { - df <- data.frame(parameter, - ciLower = lower, - ciUpper = upper) + if(options$posteriorCiType != "custom" || (options$posteriorCiType == "custom" && options$customCiType != "customCiCutOff")) { + df <- data.frame(parameter, + ciLower = lower, + ciUpper = upper) + } else { + df <- data.frame(parameter, + belowCutOff = unlist(intervals)) + } } else { - df <- data.frame(parameter, - pointEstimate, - ciLower = lower, - ciUpper = upper) + if(options$posteriorCiType != "custom" || (options$posteriorCiType == "custom" && options$customCiType != "customCiCutOff")) { + df <- data.frame(parameter, + pointEstimate, + ciLower = lower, + ciUpper = upper) + } else { + df <- data.frame(parameter, + pointEstimate, + belowCutOff = unlist(intervals)) + } } postSummaryStats[["object"]] <- df @@ -1861,8 +1955,19 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { int <- HDInterval::hdi(samples, credMass = mass) } -.customInterMetaLog <- function(fit, lower, upper) { - int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$params$term_limit) +.customInterMetaLog <- function(fit, lower, upper, cutoff, options) { + if(options$customCiType == "customCiQuantiles") { + int <- rmetalog::qmetalog(m = fit, y = c(lower, upper), term = fit$params$term_limit) + return(int) + } else { + res <- try(rmetalog::pmetalog(m = fit, q = cutoff, term = fit$params$term_limit), + silent = TRUE) + + if(isTryError(res)) + return(NA) + + return(res) + } } ## Generalized inverse Gaussian @@ -1876,8 +1981,25 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { int <- HDInterval::hdi(fit$randData, credMass = mass) } -.customInterGIG <- function(fit, lower, upper) { - int <- quantile(fit$randData, probs = c(lower, upper)) +.customInterGIG <- function(fit, lower, upper, cutoff, options) { + if(options$customCiType == "customCiQuantiles") { + int <- quantile(fit$randData, probs = c(lower, upper)) + return(int) + } else { + res <- tryCatch( + { + GeneralizedHyperbolic::pgig(q = cutoff, param = fit$param) + }, + warning = function(w) { + return(NA) + }, + error = function(e) { + return(NA) + } + ) + + return(res) + } } ## axis limits diff --git a/inst/qml/msaBayesianGaugeRR.qml b/inst/qml/msaBayesianGaugeRR.qml index 7fdf4965..510ab3d5 100644 --- a/inst/qml/msaBayesianGaugeRR.qml +++ b/inst/qml/msaBayesianGaugeRR.qml @@ -364,33 +364,74 @@ Form inclusive: JASP.MinOnly } - DoubleField - { - visible: posteriorCiType.currentText == "custom" - enabled: posteriorCi.checked - name: "posteriorCiLower" - label: qsTr("Lower") - id: posteriorCiLower - fieldWidth: 50 - defaultValue: 0.25 - min: 0 - max: posteriorCiUpper.value - inclusive: JASP.None - } - - DoubleField + RadioButtonGroup { - visible: posteriorCiType.currentText === "custom" - enabled: posteriorCi.checked - name: "posteriorCiUpper" - label: qsTr("Upper") - id: posteriorCiUpper - fieldWidth: 50 - defaultValue: 0.75 - min: posteriorCiLower.value - max: 1 - inclusive: JASP.None - } + name: "customCiType" + visible: posteriorCiType.currentText === "custom" + enabled: posteriorCi.checked + + RadioButton + { + name: "customCiQuantiles" + visible: posteriorCiType.currentText === "custom" + label: qsTr("Quantiles") + enabled: posteriorCi.checked + checked: true + + Group + { + columns: 2 + DoubleField + { + visible: posteriorCiType.currentText === "custom" + enabled: posteriorCi.checked + name: "posteriorCiLower" + label: qsTr("Lower") + id: posteriorCiLower + fieldWidth: 50 + defaultValue: 0.25 + min: 0 + max: posteriorCiUpper.value + inclusive: JASP.None + } + + DoubleField + { + visible: posteriorCiType.currentText === "custom" + enabled: posteriorCi.checked + name: "posteriorCiUpper" + label: qsTr("Upper") + id: posteriorCiUpper + fieldWidth: 50 + defaultValue: 0.75 + min: posteriorCiLower.value + max: 1 + inclusive: JASP.None + } + } + + } + + RadioButton + { + name: "customCiCutOff" + visible: posteriorCiType.currentText === "custom" + label: qsTr("Cut-off") + enabled: posteriorCi.checked + + DoubleField + { + name: "posteriorCiCutOff" + visible: posteriorCiType.currentText === "custom" + enabled: posteriorCi.checked + fieldWidth: 50 + defaultValue: 10 + decimals: 3 + min: 0 + inclusive: JASP.None + } + } + } } } diff --git a/tests/testthat/test-msaBayesianGaugeRR.R b/tests/testthat/test-msaBayesianGaugeRR.R index 50fdcbb3..4a1479eb 100644 --- a/tests/testthat/test-msaBayesianGaugeRR.R +++ b/tests/testthat/test-msaBayesianGaugeRR.R @@ -27,6 +27,7 @@ options$partByOperatorMeasurementPlot <- TRUE options$trafficLightChart <- TRUE options$distType <- "gig" options$mcmcChains <- 2 +options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) @@ -195,25 +196,25 @@ test_that("L1 Variance Components table results match", { }) test_that("L1 Error plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Error"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Error"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L1 error") }) test_that("L1 Operator plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Operator"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L1 operator") }) test_that("L1 Part plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Part"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L1 part") }) test_that("L1 Posterior Summary table results match", { - table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + table <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_postSummary"]][["data"]] jaspTools::expect_equal_tables(table, list(4.78249678043341, 29.8522838983694, "2Part", 12.2063561157816, 0.019717972167065, 0.963666980675533, "2Operator", @@ -257,6 +258,7 @@ options$diagnosticsPlotType <- "autocor" options$distType <- "metalog" options$modelType <- "fullModel" options$mcmcChains <- 2 +options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) @@ -377,37 +379,37 @@ test_that("L2 Variance Components table results match", { }) test_that("L2 Operator plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Operator"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L2 operator") }) test_that("L2 Part-to-part plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part-to-part"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Part-to-part"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L2 part-to-part") }) test_that("L2 Repeatability plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Repeatability"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L2 repeatability") }) test_that("L2 Reproducibility plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Reproducibility"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Reproducibility"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L2 reproducibility") }) test_that("L2 Total gauge r&R plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Total gauge r&R"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L2 total-gauge-r-r") }) test_that("L2 Posterior Summary table results match", { - table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + table <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_postSummary"]][["data"]] jaspTools::expect_equal_tables(table, list(8.40483271767977, 33.0057533152063, "Total gauge r&R", 16.4140241975042, 6.04889943061452, 15.7471976500399, "Repeatability", 10.5766752981399, @@ -431,6 +433,7 @@ options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "density" options$distType <- "metalog" options$mcmcChains <- 2 +options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) @@ -522,31 +525,31 @@ test_that("L3 Variance Components table results match", { }) test_that("L3 Part-to-part plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part-to-part"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Part-to-part"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L3 part-to-part") }) test_that("L3 Repeatability plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Repeatability"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L3 repeatability") }) test_that("L3 Total gauge r&R plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Total gauge r&R"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L3 total-gauge-r-r") }) test_that("L3 Total variation plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total variation"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Total variation"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L3 total-variation") }) test_that("L3 Posterior Summary table results match", { - table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + table <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_postSummary"]][["data"]] jaspTools::expect_equal_tables(table, list(20.4255240578281, 27.7936833384094, "Total gauge r&R", 23.7462166121699, 20.4255240578281, 27.7936833384094, "Repeatability", 23.7462166121699, @@ -572,6 +575,7 @@ options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "density" options$distType <- "metalog" options$mcmcChains <- 2 +options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) @@ -679,31 +683,31 @@ test_that("L4 Variance Components table results match", { }) test_that("L4 Operator plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Operator"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L4 operator") }) test_that("L4 Repeatability plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Repeatability"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L4 repeatability") }) test_that("L4 Reproducibility plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Reproducibility"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Reproducibility"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L4 reproducibility") }) test_that("L4 Total gauge r&R plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Total gauge r&R"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "L4 total-gauge-r-r") }) test_that("L4 Posterior Summary table results match", { - table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + table <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_postSummary"]][["data"]] jaspTools::expect_equal_tables(table, list(6.08426523238411, 49.8077618247364, "Total gauge r&R", 15.0301360534277, 4.50423780799053, 8.31507421356034, "Repeatability", 6.1266418829029, @@ -727,6 +731,7 @@ test_that("L Gauge r&R report plot matches", { options$reportAverageChartByOperator <- TRUE options$reportPartByOperatorPlot <- TRUE options$mcmcChains <- 2 + options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_long.csv", options) plotName <- results[["results"]][["report"]][["data"]] @@ -765,6 +770,7 @@ options$partByOperatorMeasurementPlot <- TRUE options$trafficLightChart <- TRUE options$distType <- "gig" options$mcmcChains <- 2 +options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) @@ -932,25 +938,25 @@ test_that("W1 Variance Components table results match", { }) test_that("W1 Error plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Error"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Error"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W1 error") }) test_that("W1 Operator plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Operator"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W1 operator") }) test_that("W1 Part plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Part"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W1 part") }) test_that("W1 Posterior Summary table results match", { - table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + table <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_postSummary"]][["data"]] jaspTools::expect_equal_tables(table, list(1.27284283054443, 8.51804137015566, "2Part", 3.3737108373, 0.098113661553187, 4.61971702790384, "2Operator", @@ -990,6 +996,7 @@ options$diagnosticsPlotType <- "autocor" options$distType <- "metalog" options$modelType <- "fullModel" options$mcmcChains <- 2 +options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) @@ -1109,37 +1116,37 @@ test_that("W2 Variance Components table results match", { }) test_that("W2 Operator plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Operator"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W2 operator") }) test_that("W2 Part-to-part plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part-to-part"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Part-to-part"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W2 part-to-part") }) test_that("W2 Repeatability plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Repeatability"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W2 repeatability") }) test_that("W2 Reproducibility plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Reproducibility"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Reproducibility"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W2 reproducibility") }) test_that("W2 Total gauge r&R plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Total gauge r&R"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W2 total-gauge-r-r") }) test_that("W2 Posterior Summary table results match", { - table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + table <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_postSummary"]][["data"]] jaspTools::expect_equal_tables(table, list(36.6908448164942, 84.640380749268, "Total gauge r&R", 59.0499639096235, 25.5255275390376, 56.9200489576364, "Repeatability", 42.03575729992, @@ -1164,6 +1171,7 @@ options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "density" options$distType <- "metalog" options$mcmcChains <- 2 +options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) @@ -1255,31 +1263,31 @@ test_that("W3 Variance Components table results match", { }) test_that("W3 Part-to-part plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Part-to-part"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Part-to-part"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W3 part-to-part") }) test_that("W3 Repeatability plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Repeatability"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W3 repeatability") }) test_that("W3 Total gauge r&R plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Total gauge r&R"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W3 total-gauge-r-r") }) test_that("W3 Total variation plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total variation"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Total variation"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W3 total-variation") }) test_that("W3 Posterior Summary table results match", { - table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + table <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_postSummary"]][["data"]] jaspTools::expect_equal_tables(table, list(48.1714882535499, 65.4777848056588, "Total gauge r&R", 55.9859173475586, 48.1714882535499, 65.4777848056588, "Repeatability", 55.9859173475586, @@ -1305,6 +1313,7 @@ options$trafficLightChart <- TRUE options$diagnosticsPlotType <- "density" options$distType <- "metalog" options$mcmcChains <- 2 +options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) @@ -1411,31 +1420,31 @@ test_that("W4 Variance Components table results match", { }) test_that("W4 Operator plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Operator"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Operator"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W4 operator") }) test_that("W4 Repeatability plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Repeatability"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Repeatability"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W4 repeatability") }) test_that("W4 Reproducibility plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Reproducibility"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Reproducibility"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W4 reproducibility") }) test_that("W4 Total gauge r&R plot matches", { - plotName <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_Total gauge r&R"]][["data"]] + plotName <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_Total gauge r&R"]][["data"]] testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]] jaspTools::expect_equal_plots(testPlot, "W4 total-gauge-r-r") }) test_that("W4 Posterior Summary table results match", { - table <- results[["results"]][["variancePosteriors"]][["collection"]][["variancePosteriors_postSummary"]][["data"]] + table <- results[["results"]][["posteriorSummaries"]][["collection"]][["posteriorSummaries_postSummary"]][["data"]] jaspTools::expect_equal_tables(table, list(36.2684396989805, 246.249732595721, "Total gauge r&R", 79.4194770714244, 28.0791556215122, 51.6892435406356, "Repeatability", 38.1493514877285, @@ -1459,6 +1468,7 @@ test_that("W Gauge r&R report plot matches", { options$reportAverageChartByOperator <- TRUE options$reportPartByOperatorPlot <- TRUE options$mcmcChains <- 2 + options$customCiType <- "customCiQuantiles" set.seed(1) results <- runAnalysis("msaBayesianGaugeRR", "datasets/msaGaugeRRCrossed/msaGaugeRRCrossed_wide.csv", options) plotName <- results[["results"]][["report"]][["data"]] From 73b6d5afbfb3df7f7d98c6d91c9809fcbde7b20b Mon Sep 17 00:00:00 2001 From: jvli4n Date: Fri, 15 Aug 2025 13:47:49 +0200 Subject: [PATCH 65/65] Axis limits density diagnostics plots - Fixing bug in determining axis limits - Updating corresponding snapshots --- R/msaBayesianGaugeRR.R | 34 +++++--- .../l3-density-plot-type-3-error.svg | 44 ++++++---- .../l3-density-plot-type3-parts.svg | 74 +++++++++-------- .../l4-density-plot-histsd-error.svg | 40 ++++++---- .../l4-density-plot-histsd-operators.svg | 80 +++++++++---------- .../l4-density-plot-histsd-parts.svg | 74 +++++++++-------- .../w3-density-plot-type-3-error-wide.svg | 74 +++++++++-------- .../w3-density-plot-type3-parts-wide.svg | 20 ++--- .../w4-density-plot-histsd-error-wide.svg | 74 +++++++++-------- .../w4-density-plot-histsd-operators-wide.svg | 40 ++++++---- .../w4-density-plot-histsd-parts-wide.svg | 20 ++--- 11 files changed, 323 insertions(+), 251 deletions(-) diff --git a/R/msaBayesianGaugeRR.R b/R/msaBayesianGaugeRR.R index 0cbdd242..b84060a3 100644 --- a/R/msaBayesianGaugeRR.R +++ b/R/msaBayesianGaugeRR.R @@ -2243,23 +2243,34 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { for(i in seq_along(paramNames)) { tempPlot <- createJaspPlot(width = 600, height = 320) - # density for axis limits - d <- apply(chains[, , paramNames[i]], 2, function(x) { - df <- data.frame(x = density(x)$x, - y = density(x)$y) - return(df) - }) - d <- do.call(rbind.data.frame, d) - xLims <- c(0, d$x[d$y < 1e-3 & d$x > 3][1]) # note: there should be a better way to handle the part with x > 3 + # initilize plot + p <- bayesplot::mcmc_dens_overlay(chains, pars = paramNames[i]) + + d <- density(chains[, , paramNames[i]], n = 64000) + + # x-lims + m <- quantile(chains[, , paramNames[i]], 0.5) + xUpper <- d$x[d$y < 1e-3 & d$x > m][1] + xLower <- quantile(chains[, , paramNames[i]], 0.001) + xLower <- ifelse(xLower < 1, 0, xLower) + xLims <- c(xLower, xUpper) manualScaleX <- FALSE - if(!any(is.na(xLims))) { + if(!anyNA(xLims)) { manualScaleX <- TRUE axisBreaksX <- jaspGraphs::getPrettyAxisBreaks(xLims) xLims <- c(axisBreaksX[1], axisBreaksX[length(axisBreaksX)]) } - p <- bayesplot::mcmc_dens_overlay(chains, pars = paramNames[i]) + + # y-lims + yValues <- d$y + padding <- 0.05 * diff(range(yValues)) + yLims <- c(0, max(yValues) + padding) + axisBreaksY <- jaspGraphs::getPrettyAxisBreaks(yLims) + yLims <- c(axisBreaksY[1], axisBreaksY[length(axisBreaksY)]) + + # aesthetics + p <- p + ggplot2::scale_color_manual(values = colors) + ggplot2::xlab(bquote(sigma[.(xLabs[i])]^2)) + ggplot2::xlim(xLims) @@ -2271,7 +2282,8 @@ msaBayesianGaugeRR <- function(jaspResults, dataset, options, ...) { p <- p + jaspGraphs::themeJaspRaw() + jaspGraphs::geom_rangeframe() + - ggplot2::scale_y_continuous("Density") + + ggplot2::scale_y_continuous("Density", limits = yLims, + breaks = axisBreaksY) + ggplot2::theme(axis.ticks.y = ggplot2::element_line()) tempPlot$plotObject <- p diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type-3-error.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type-3-error.svg index 5273a775..6ec896df 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type-3-error.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type-3-error.svg @@ -27,31 +27,41 @@ - - - - + + + + 0 -5 -10 -15 +5 +10 +15 +20 - - - + + + + - - - -0.0 -0.1 -0.2 -0.3 + + + + + + + +0.00 +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 +0.35 σ Error 2 diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type3-parts.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type3-parts.svg index a97201f3..f84bc583 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type3-parts.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l3-density-plot-type3-parts.svg @@ -21,45 +21,49 @@ - - + + - - - - - - - + + + + + + + - -0.000 -0.025 -0.050 -0.075 -0.100 - - - - - - - - - - - -0 -10 -20 -30 -40 -σ -Part -2 + +0.00 +0.02 +0.04 +0.06 +0.08 +0.10 +0.12 + + + + + + + + + + + + + +0 +10 +20 +30 +40 +σ +Part +2 Density -L3 Density plot type3 parts +L3 Density plot type3 parts diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-error.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-error.svg index 84819a01..0e572b3c 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-error.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-error.svg @@ -27,29 +27,39 @@ - - - - + + + + 0 -5 -10 -15 +5 +10 +15 +20 - - - + + + + - - -0.0 -0.1 -0.2 + + + + + + +0.00 +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 σ Error 2 diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-operators.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-operators.svg index f5b07fa9..fd42dd98 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-operators.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-operators.svg @@ -18,52 +18,52 @@ - + - - + + - - - - - - - + + + + + + + - -0.0 -2.5 -5.0 -7.5 - - - - - - - - - - - - - -0.0 -0.5 -1.0 -1.5 -2.0 -2.5 -3.0 -3.5 -σ -Operator -2 + +0 +2 +4 +6 +8 +10 + + + + + + + + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 +2.5 +σ +Operator +2 Density -L4 Density plot histSd operators +L4 Density plot histSd operators diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-parts.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-parts.svg index 8b885740..959deef0 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-parts.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/l4-density-plot-histsd-parts.svg @@ -21,45 +21,49 @@ - - + + - - - - - - - + + + + + + + - -0.000 -0.025 -0.050 -0.075 -0.100 - - - - - - - - - - - -0 -10 -20 -30 -40 -σ -Part -2 + +0.00 +0.02 +0.04 +0.06 +0.08 +0.10 +0.12 + + + + + + + + + + + + + +0 +10 +20 +30 +40 +σ +Part +2 Density -L4 Density plot histSd parts +L4 Density plot histSd parts diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type-3-error-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type-3-error-wide.svg index 007c004c..49a8bff3 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type-3-error-wide.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type-3-error-wide.svg @@ -18,44 +18,54 @@ - + - - + + - - - - - - - + + + + + + + - -0 -1 -2 -3 - - - - - - - - - -0.0 -0.5 -1.0 -1.5 -σ -Error -2 + +0.0 +0.5 +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 + + + + + + + + + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 +σ +Error +2 Density -W3 Density plot type 3 error wide +W3 Density plot type 3 error wide diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type3-parts-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type3-parts-wide.svg index 248259dd..3953944a 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type3-parts-wide.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w3-density-plot-type3-parts-wide.svg @@ -27,22 +27,24 @@ - - + + - + 0.0 -0.1 -0.2 -0.3 +0.1 +0.2 +0.3 +0.4 - - - + + + + diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-error-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-error-wide.svg index c440d267..892bc843 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-error-wide.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-error-wide.svg @@ -18,44 +18,54 @@ - + - - + + - - - - - - - + + + + + + + - -0 -1 -2 -3 - - - - - - - - - -0.0 -0.5 -1.0 -1.5 -σ -Error -2 + +0.0 +0.5 +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 + + + + + + + + + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 +σ +Error +2 Density -W4 Density plot histSd error wide +W4 Density plot histSd error wide diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-operators-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-operators-wide.svg index 8f2ec1cb..3fb816ec 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-operators-wide.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-operators-wide.svg @@ -27,33 +27,41 @@ - - + + - + 0.0 -0.5 -1.0 -1.5 +0.5 +1.0 +1.5 +2.0 - - - + + + + - - - + + + + + + 0 -5 -10 -15 -20 +1 +2 +3 +4 +5 +6 +7 σ Operator 2 diff --git a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-parts-wide.svg b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-parts-wide.svg index 9dc25c3f..63d860a9 100644 --- a/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-parts-wide.svg +++ b/tests/testthat/_snaps/msaBayesianGaugeRR/w4-density-plot-histsd-parts-wide.svg @@ -27,22 +27,24 @@ - - + + - + 0.0 -0.1 -0.2 -0.3 +0.1 +0.2 +0.3 +0.4 - - - + + + +