From 1e51e66825613b1eaa6c67ec9e56020df18f9e2f Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Thu, 25 Jul 2024 16:47:52 +0200
Subject: [PATCH 01/25] CUSUM chart
---
R/TimeWeightedCharts.R | 228 +++++++++++++++++++++-----------
R/commonQualityControl.R | 140 ++++++++++++++++----
inst/Description.qml | 6 +
inst/qml/rareEventCharts.qml | 44 ++++++
inst/qml/timeWeightedCharts.qml | 224 +++++++++++++++++++++++++++----
5 files changed, 512 insertions(+), 130 deletions(-)
create mode 100644 inst/qml/rareEventCharts.qml
diff --git a/R/TimeWeightedCharts.R b/R/TimeWeightedCharts.R
index 9f385ade..b0b19331 100644
--- a/R/TimeWeightedCharts.R
+++ b/R/TimeWeightedCharts.R
@@ -1,84 +1,156 @@
#' @export
timeWeightedCharts <- function(jaspResults, dataset, options) {
- variables <- options[["measurements"]]
- numeric_variables <- variables[variables != ""]
- dataset <- .readDataSetToEnd(columns.as.numeric = numeric_variables, exclude.na.listwise = numeric_variables)
- #Checking for errors in the dataset
- .hasErrors(dataset, type = c('infinity', 'missingValues'),
- all.target = options[["measurements"]], exitAnalysisIfErrors = TRUE)
-
- ready <- length(variables) > 0
-
- if (length(variables) > 0) {
- #Cusum chart
- if (options[["cumulativeSumChart"]] && is.null(jaspResults[["CusumPlot"]])) {
- jaspResults[["CusumPlot"]] <- createJaspPlot(title = gettext("Cumulative sum chart"), width = 1200, height = 500)
- jaspResults[["CusumPlot"]]$dependOn(c("cumulativeSumChart", "measurements"))
- jaspResults[["CusumPlot"]]$plotObject <- .Cusumchart(dataset = dataset, options = options, ready = ready)
+ wideFormat <- (options[["dataFormat"]] == "wideFormat")
+ # In wide format we have one subgroup per row, else we need a either a grouping variable or later specify subgroup size manually
+ if (wideFormat) {
+ measurements <- unlist(options[["measurementsWideFormat"]])
+ stages <- options[["stagesWideFormat"]]
+ axisLabels <- options[["axisLabels"]]
+ factorVariables <- c(axisLabels, stages)
+ } else {
+ measurements <- options[["measurementLongFormat"]]
+ stages <- options[["stagesLongFormat"]]
+ subgroupVariable <- options[["subgroup"]]
+ factorVariables <- c(subgroupVariable, stages)
+ }
+
+ measurements <- measurements[measurements != ""]
+ factorVariables <- factorVariables[factorVariables != ""]
+
+ # Check if analysis is ready
+ if (wideFormat) {
+ ready <- length(measurements) >= 1
+ } else if (!wideFormat && options[["subgroupSizeType"]] == "manual"){
+ ready <- length(measurements) == 1
+ } else if (!wideFormat && options[["subgroupSizeType"]] == "groupingVariable") {
+ ready <- length(measurements) == 1 && subgroupVariable != ""
+ }
+
+ # Data reading
+ if (is.null(dataset) && ready) {
+ if (length(factorVariables) >= 1) {
+ dataset <- .readDataSetToEnd(columns.as.numeric = measurements, columns.as.factor = factorVariables)
+ } else {
+ dataset <- .readDataSetToEnd(columns.as.numeric = measurements)
}
- #EWMA chart
- if (options[["exponentiallyWeightedMovingAverageChart"]] && is.null(jaspResults[["EWMAPlot"]])) {
- jaspResults[["EWMAPlot"]] <- createJaspPlot(title = gettext("Exponentially weighted moving average chart"), width = 1200, height = 500)
- jaspResults[["EWMAPlot"]]$dependOn(c("ExponentiallyWeightedMovingAverageChart", "measurements"))
- jaspResults[["EWMAPlot"]]$plotObject <- .EWMA(dataset = dataset, options = options, ready = ready)
+ }
+ if (!wideFormat && !identical(subgroupVariable, "")) # empty strings should also be treated as NA
+ dataset[,subgroupVariable][dataset[[subgroupVariable]] == ""] <- NA
+
+ # error handling
+ .hasErrors(dataset, type = c('infinity'),
+ infinity.target = c(measurements, options$subgroup),
+ exitAnalysisIfErrors = TRUE)
+
+ plotNotes <- ""
+ if (!identical(stages, "")) {
+ if ((!wideFormat && options[["subgroupSizeType"]] == "manual" &&
+ any(lapply(split(dataset[[stages]], ceiling(seq_along(dataset[[stages]])/options[["manualSubgroupSizeValue"]])), FUN = function(x)length(unique(x))) > 1)) ||
+ (!wideFormat && options[["subgroupSizeType"]] == "groupingVariable" &&
+ any(table(dplyr::count_(dataset, vars = c(stages, subgroupVariable))[subgroupVariable]) > 1))) {
+ plotNotes <- paste0(plotNotes, gettext("One or more subgroups are assigned to more than one stage, only first stage is considered.
"))
+ }
+ if (anyNA(dataset[[stages]])) {
+ nDroppedStageRows <- sum(is.na(dataset[[stages]]))
+ dataset <- dataset[!is.na(dataset[[stages]]),]
+ removalType <- if (wideFormat) "subgroup(s)" else "observation(s)"
+ plotNotes <- paste0(plotNotes, gettextf("Removed %1$i %2$s that were not assigned to any stage.
", nDroppedStageRows, removalType))
}
- #G chart
- if (options[["gChart"]] && is.null(jaspResults[["GPlot"]])) {
- jaspResults[["GPlot"]] <- createJaspPlot(title = gettext("G chart"), width = 1200, height = 500)
- jaspResults[["GPlot"]]$dependOn(c("gChart", "measurements"))
- jaspResults[["GPlot"]]$plotObject <- .Gchart(dataset = dataset, options = options, ready = ready)$p
+ }
+
+ if (!wideFormat && options[["subgroupSizeType"]] == "groupingVariable" && anyNA(dataset[[subgroupVariable]])) {
+ nDroppedSubgroupRows <- sum(is.na(dataset[[subgroupVariable]]))
+ dataset <- dataset[!is.na(dataset[[subgroupVariable]]),]
+ plotNotes <- paste0(plotNotes, gettextf("Removed %i observation(s) that were not assigned to any subgroups.
", nDroppedSubgroupRows))
+ }
+
+ # Rearrange data if not already wide format (one group per row)
+ if (!wideFormat && ready) {
+ reshapeOutputList <- .reshapeSubgroupDataLongToWide(dataset, measurements, stages = stages, subgroupVariable = subgroupVariable,
+ subgroupSizeType = options[["subgroupSizeType"]],
+ manualSubgroupSizeValue = options[["manualSubgroupSizeValue"]],
+ subgroupVariableMethod = options[["groupingVariableMethod"]])
+ dataset <- reshapeOutputList$dataset
+ measurements <- reshapeOutputList$measurements
+ axisLabels <- reshapeOutputList$axisLabels
+ xAxisTitle <- reshapeOutputList$xAxisTitle
+ } else if (wideFormat && ready) {
+ if (axisLabels != "") {
+ xAxisTitle <- options[["axisLabels"]]
+ axisLabels <- dataset[[axisLabels]]
+ } else {
+ xAxisTitle <- gettext("Sample")
}
- #T chart
- # if (options[["tChart"]] && is.null(jaspResults[["TPlot"]])) {
- # jaspResults[["TPlot"]] <- createJaspPlot(title = gettext("T chart"), width = 1200, height = 500)
- # jaspResults[["TPlot"]]$dependOn(c("tChart", "measurements"))
- # jaspResults[["TPlot"]]$plotObject <- .Tchart(dataset = dataset, options = options, ready = ready)$p
- # }
+ }
+
+ #Cusum chart
+ if (options[["cumulativeSumChart"]] && is.null(jaspResults[["CusumPlot"]])) {
+ jaspResults[["CusumPlot"]] <- .Cusumchart(dataset = dataset, measurements = measurements, stages = stages,
+ axisLabels = axisLabels, options = options, ready = ready)
+ }
+ #EWMA chart
+ if (options[["exponentiallyWeightedMovingAverageChart"]] && is.null(jaspResults[["EWMAPlot"]])) {
+ jaspResults[["EWMAPlot"]] <- createJaspPlot(title = gettext("Exponentially weighted moving average chart"), width = 1200, height = 500)
+ jaspResults[["EWMAPlot"]]$dependOn(c("ExponentiallyWeightedMovingAverageChart", "measurements"))
+ jaspResults[["EWMAPlot"]]$plotObject <- .EWMA(dataset = dataset, options = options, ready = ready)
}
}
-.Cusumchart <- function(dataset, options, ready) {
+.Cusumchart <- function(dataset, measurements, stages, axisLabels, options, ready) {
+
+ plot <- createJaspPlot(title = gettext("Cumulative sum chart"), width = 1200, height = 500)
+ plot$dependOn(c("cumulativeSumChart", "measurements"))
+
if (!ready)
- return()
-
- data1 <- dataset[, options[["measurements"]]]
- sixsigma <- qcc::cusum(data1, decision.interval = options[["cumulativeSumChartNumberSd"]], se.shift = options[["cumulativeSumChartShiftSize"]], plot = FALSE)
- subgroups <- c(1:length(sixsigma$pos))
- data_plot <- data.frame(y_neg = sixsigma$neg , y_pos = sixsigma$pos, x = subgroups)
- center <- 0
- UCL <- sixsigma$decision.interval
- LCL <- -UCL
- yBreaks <- jaspGraphs::getPrettyAxisBreaks(c(LCL, UCL, data_plot$y_neg, data_plot$y_pos))
- yLimits <- range(yBreaks)
- if (length(subgroups) > 60)
- xBreaks <- c(1,jaspGraphs::getPrettyAxisBreaks(subgroups)[-1])
- else
- xBreaks <- c(subgroups)
- xLimits <- c(1,max(xBreaks) + 2.5)
- dfLabel <- data.frame(
- x = max(xLimits - 1),
- y = c(center, UCL, LCL),
- l = c(
- gettextf("CL = %g", round(center, 4)),
- gettextf("UCL = %g", round(UCL, 5)),
- gettextf("LCL = %g", round(LCL, 5))
- )
- )
-
- p <- ggplot2::ggplot(data_plot, ggplot2::aes(x)) +
- ggplot2::geom_hline(yintercept = center, color = 'green') +
- ggplot2::geom_hline(yintercept = c(UCL, LCL), color = "red", linetype = "dashed", size = 1.5) +
- ggplot2::geom_label(data = dfLabel, mapping = ggplot2::aes(x = x, y = y, label = l),inherit.aes = FALSE, size = 4.5) +
- ggplot2::scale_y_continuous(name = gettext("Cumulative sum") ,limits = yLimits, breaks = yBreaks) +
- ggplot2::scale_x_continuous(name = gettext('Subgroups'), breaks = xBreaks, limits = range(xLimits)) +
- jaspGraphs::geom_line(ggplot2::aes(y = y_neg), col = "blue") +
- jaspGraphs::geom_line(ggplot2::aes(y = y_pos), col = "blue")+
- jaspGraphs::geom_point(ggplot2::aes(y = y_neg), size = 4, fill = ifelse(data_plot$y_neg < LCL, 'red', 'blue')) +
- jaspGraphs::geom_point(ggplot2::aes(y = y_pos), size = 4, fill = ifelse(data_plot$y_pos > UCL, 'red', 'blue')) +
- jaspGraphs::geom_rangeframe() +
- jaspGraphs::themeJaspRaw()
-
- return(p)
+ return(plot)
+
+
+ columnsToPass <- c(measurements, stages)
+ columnsToPass <- columnsToPass[columnsToPass != ""]
+ plotObject <- .controlChart(dataset[columnsToPass], plotType = "cusum", stages = stages, xBarSdType = options[["cumulativeSumChartSdMethod"]],
+ nSigmasControlLimits = options[["cumulativeSumChartNumberSd"]], xAxisLabels = axisLabels,
+ cusumShiftSize = options[["cumulativeSumChartShiftSize"]], cusumTarget = options[["cumulativeSumChartTarget"]])$plotObject
+
+ plot$plotObject <- plotObject
+ #
+ # data1 <- dataset[, options[["measurements"]]]
+ # sixsigma <- qcc::cusum(data1, decision.interval = options[["cumulativeSumChartNumberSd"]], se.shift = options[["cumulativeSumChartShiftSize"]], plot = FALSE)
+ # subgroups <- c(1:length(sixsigma$pos))
+ # data_plot <- data.frame(y_neg = sixsigma$neg , y_pos = sixsigma$pos, x = subgroups)
+ # center <- 0
+ # UCL <- sixsigma$decision.interval
+ # LCL <- -UCL
+ # yBreaks <- jaspGraphs::getPrettyAxisBreaks(c(LCL, UCL, data_plot$y_neg, data_plot$y_pos))
+ # yLimits <- range(yBreaks)
+ # if (length(subgroups) > 60)
+ # xBreaks <- c(1,jaspGraphs::getPrettyAxisBreaks(subgroups)[-1])
+ # else
+ # xBreaks <- c(subgroups)
+ # xLimits <- c(1,max(xBreaks) + 2.5)
+ # dfLabel <- data.frame(
+ # x = max(xLimits - 1),
+ # y = c(center, UCL, LCL),
+ # l = c(
+ # gettextf("CL = %g", round(center, 4)),
+ # gettextf("UCL = %g", round(UCL, 5)),
+ # gettextf("LCL = %g", round(LCL, 5))
+ # )
+ # )
+ #
+ # p <- ggplot2::ggplot(data_plot, ggplot2::aes(x)) +
+ # ggplot2::geom_hline(yintercept = center, color = 'green') +
+ # ggplot2::geom_hline(yintercept = c(UCL, LCL), color = "red", linetype = "dashed", size = 1.5) +
+ # ggplot2::geom_label(data = dfLabel, mapping = ggplot2::aes(x = x, y = y, label = l),inherit.aes = FALSE, size = 4.5) +
+ # ggplot2::scale_y_continuous(name = gettext("Cumulative sum") ,limits = yLimits, breaks = yBreaks) +
+ # ggplot2::scale_x_continuous(name = gettext('Subgroups'), breaks = xBreaks, limits = range(xLimits)) +
+ # jaspGraphs::geom_line(ggplot2::aes(y = y_neg), col = "blue") +
+ # jaspGraphs::geom_line(ggplot2::aes(y = y_pos), col = "blue")+
+ # jaspGraphs::geom_point(ggplot2::aes(y = y_neg), size = 4, fill = ifelse(data_plot$y_neg < LCL, 'red', 'blue')) +
+ # jaspGraphs::geom_point(ggplot2::aes(y = y_pos), size = 4, fill = ifelse(data_plot$y_pos > UCL, 'red', 'blue')) +
+ # jaspGraphs::geom_rangeframe() +
+ # jaspGraphs::themeJaspRaw()
+
+ return(plot)
}
.EWMA <- function(dataset, options, ready) {
if (!ready)
@@ -110,7 +182,7 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
gettextf("LCL = %g", round(LCL.label, decimals + 2))
)
)
-
+
p <- ggplot2::ggplot(data_plot, ggplot2::aes(x = x, y = y)) +
ggplot2::geom_step(ggplot2::aes(x = x, y = UCL, color = "red"),linetype = "dashed", size = 1.5) +
ggplot2::geom_step(ggplot2::aes(x = x, y = LCL, color = "red"), linetype = "dashed", size = 1.5) +
@@ -122,7 +194,7 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
jaspGraphs::geom_point(size = 4, fill = ifelse(data_plot$y > UCL | data_plot$y < LCL, 'red', 'blue')) +
jaspGraphs::geom_rangeframe() +
jaspGraphs::themeJaspRaw()
-
+
return(p)
}
.Gchart <- function(dataset, options, ready){
@@ -153,7 +225,7 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
gettextf("LCL = %g", round(LCL, 5))
)
)
-
+
p <- ggplot2::ggplot(data_plot, ggplot2::aes(x = x, y = y)) +
ggplot2::geom_line(ggplot2::aes(x = x, y = UCL, color = "red"),linetype = "dashed", size = 1.5) +
ggplot2::geom_line(ggplot2::aes(x = x, y = LCL, color = "red"), linetype = "dashed", size = 1.5) +
@@ -165,7 +237,7 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
jaspGraphs::geom_point(size = 4, fill = ifelse(data_plot$y > UCL | data_plot$y < LCL, 'red', 'blue')) +
jaspGraphs::geom_rangeframe() +
jaspGraphs::themeJaspRaw()
-
+
return(list(p = p, sixsigma = sixsigma))
}
.Tchart <- function(dataset, options){
@@ -199,7 +271,7 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
gettextf("LCL = %g", round(LCL, 5))
)
)
-
+
p <- ggplot2::ggplot(data_plot, ggplot2::aes(x = x, y = y)) +
ggplot2::geom_line(ggplot2::aes(x = x, y = UCL, color = "red"),linetype = "dashed", linewidth = 1.5) +
ggplot2::geom_line(ggplot2::aes(x = x, y = LCL, color = "red"), linetype = "dashed", linewidth = 1.5) +
@@ -211,6 +283,6 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
jaspGraphs::geom_point(size = 4, fill = ifelse(data_plot$y > UCL | data_plot$y < LCL, 'red', 'blue')) +
jaspGraphs::geom_rangeframe() +
jaspGraphs::themeJaspRaw()
-
+
return(list(p = p, sixsigma = sixsigma))
}
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index 03435fe3..bedf9028 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -393,7 +393,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
return(list(LCL = LCLvector, UCL = UCLvector))
}
-.controlChart <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s"),
+.controlChart <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum"),
stages = "",
xBarSdType = c("r", "s"),
nSigmasControlLimits = 3,
@@ -409,7 +409,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
movingRangeLength = 2,
clLabelSize = 4.5,
stagesSeparateCalculation = TRUE,
- unbiasingConstantUsed = TRUE
+ unbiasingConstantUsed = TRUE,
+ cusumShiftSize = 0.5,
+ cusumTarget = 0
) {
plotType <- match.arg(plotType)
@@ -418,7 +420,8 @@ KnownControlStats.RS <- function(N, sigma = 3) {
nSigmasControlLimits = nSigmasControlLimits, phase2 = phase2,
phase2Mu = phase2Mu, phase2Sd = phase2Sd, fixedSubgroupSize = fixedSubgroupSize,
warningLimits = warningLimits, movingRangeLength = movingRangeLength,
- stagesSeparateCalculation = stagesSeparateCalculation, unbiasingConstantUsed = unbiasingConstantUsed)
+ stagesSeparateCalculation = stagesSeparateCalculation, unbiasingConstantUsed = unbiasingConstantUsed,
+ cusumShiftSize = cusumShiftSize, cusumTarget = cusumTarget)
# This function turns the point violation list into a JASP table
@@ -436,7 +439,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
return(list(plotObject = plotObject, table = table, controlChartData = controlChartData))
}
-.controlChart_calculations <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s"),
+.controlChart_calculations <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum"),
stages = "",
xBarSdType = c("r", "s"),
nSigmasControlLimits = 3,
@@ -447,7 +450,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
warningLimits = FALSE,
movingRangeLength = 2,
stagesSeparateCalculation = TRUE,
- unbiasingConstantUsed = TRUE
+ unbiasingConstantUsed = TRUE,
+ cusumShiftSize = 0.5,
+ cusumTarget = 0
) {
plotType <- match.arg(plotType)
if (identical(stages, "")) {
@@ -593,15 +598,38 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
UCL <- limits$UCL
LCL <- limits$LCL
+ ###
+ ### Calculations for cusum chart
+ ###
+ } else if (plotType == "cusum") {
+ n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
+ # sigma for subgroup size = 1
+ if (all(n == 1)) {
+
+ # sigma for subgroup size > 1
+ } else {
+ sigma <- .sdXbar(dataCurrentStage, type = xBarSdType, unbiasingConstantUsed = unbiasingConstantUsed)
+ }
+ plotStatisticUpper <- .cusumPoints(dataCurrentStage, sigma, n, cusumTarget, cusumShiftSize, cuType = "upper")
+ plotStatisticLower <- .cusumPoints(dataCurrentStage, sigma, n, cusumTarget, cusumShiftSize, cuType = "lower")
+ plotStatistic <- c(plotStatisticUpper, plotStatisticLower)
+ UCL <- nSigmasControlLimits*sigma/sqrt(n)
+ LCL <- -UCL
+ center <- 0 # not to be confused with the target, even if target != 0, the center line of the plot should be at 0
}
if (i != 1) {
+ # TODO: adjust for cusum chart
subgroups <- seq(max(plotData$subgroup) + 1, max(plotData$subgroup) + length(plotStatistic))
dfStageLabels <- rbind(dfStageLabels, data.frame(x = max(plotData$subgroup) + length(subgroups)/2,
y = NA, # the y value will be filled in later
label = stage,
separationLine = max(plotData$subgroup) + .5))
} else {
- subgroups <- seq_along(plotStatistic)
+ if (plotType == "cusum") {
+ subgroups <- rep(seq_along(plotStatisticUpper), 2)
+ } else {
+ subgroups <- seq_along(plotStatistic)
+ }
dfStageLabels <- rbind(dfStageLabels, data.frame(x = max(subgroups)/2 + 0.5,
y = NA, # the y value will be filled in later
label = stage,
@@ -611,8 +639,11 @@ KnownControlStats.RS <- function(N, sigma = 3) {
if (length(na.omit(plotStatistic)) > 1) {
if (plotType == "MR" || plotType == "MMR") {
dotColor <- ifelse(c(rep(NA, k-1), NelsonLaws(qccObject)$red_points), 'red', 'blue')
+ } else if (plotType == "cusum") {
+ dotColor <- ifelse(plotStatistic > UCL | plotStatistic < LCL, "red", "blue")
+ dotColor[is.na(dotColor)] <- "blue"
} else {
- dotColor <- ifelse(NelsonLaws(qccObject, allsix = plotType == "I")$red_points, 'red', 'blue')
+ dotColor <- ifelse(NelsonLaws(qccObject, allsix = (plotType == "I"))$red_points, 'red', 'blue')
}
} else {
dotColor <- ifelse(plotStatistic > UCL | plotStatistic < LCL, "red", "blue")
@@ -620,7 +651,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
# if more than half of the dots are violations, do not show red dots.
nOutOfLimits <- sum(dotColor[!is.na(dotColor)] == "red")
- if (nOutOfLimits > length(qccObject$statistics)/2)
+ if (nOutOfLimits > length(plotStatistic)/2)
dotColor <- "blue"
stagePlotData <- data.frame("plotStatistic" = plotStatistic,
@@ -674,11 +705,15 @@ KnownControlStats.RS <- function(N, sigma = 3) {
tableLabelsCurrentStage <- subgroups
if (plotType == "MR" || plotType == "MMR")
tableLabelsCurrentStage <- tableLabelsCurrentStage[-seq(1, k-1)]
- tableList[[i]] <- .NelsonTableList(qccObject = qccObject, type = plotType, labels = tableLabelsCurrentStage)
- tableListLengths <- sapply(tableList[[i]], length)
- if (any(tableListLengths > 0)) {
- tableList[[i]][["stage"]] <- as.character(stage)
- tableList[[i]] <- lapply(tableList[[i]], "length<-", max(lengths(tableList[[i]]))) # this fills up all elements of the list with NAs so all elements are the same size
+ if (plotType == "cusum") {
+ tableList[[i]] <- c() # pass empty vector for now, until Nelson Laws are updated and can handle other input than QCC objects
+ } else {
+ tableList[[i]] <- .NelsonTableList(qccObject = qccObject, type = plotType, labels = tableLabelsCurrentStage)
+ tableListLengths <- sapply(tableList[[i]], length)
+ if (any(tableListLengths > 0)) {
+ tableList[[i]][["stage"]] <- as.character(stage)
+ tableList[[i]] <- lapply(tableList[[i]], "length<-", max(lengths(tableList[[i]]))) # this fills up all elements of the list with NAs so all elements are the same size
+ }
}
}
return(list("pointData" = plotData,
@@ -691,7 +726,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
.controlChart_table <- function(tableList,
- plotType = c("xBar", "R", "I", "MR", "MMR", "s"),
+ plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum"),
stages = "",
tableLabels = "") {
plotType <- match.arg(plotType)
@@ -701,12 +736,13 @@ KnownControlStats.RS <- function(N, sigma = 3) {
"I" = "individuals",
"MR" = "moving range",
"MMR" = "moving range",
- "s" = "s"
+ "s" = "s",
+ "cusum" = "cumulative sum"
)
table <- createJaspTable(title = gettextf("Test results for %1$s chart", tableTitle))
table$showSpecifiedColumnsOnly <- TRUE
tableListVectorized <- unlist(tableList, recursive = FALSE)
- tableLongestVector <- max(sapply(tableListVectorized, length))
+ tableLongestVector <- if (is.null(tableListVectorized)) 0 else max(sapply(tableListVectorized, length))
if (tableLongestVector > 0) {
# combine the tests for different stages in same column
tableListCombined <- tapply(tableListVectorized, names(tableListVectorized), function(x) unlist(x, FALSE, FALSE))
@@ -761,7 +797,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
.controlChart_plotting <- function(pointData, clData, stageLabels, clLabels,
- plotType = c("xBar", "R", "I", "MR", "MMR", "s"),
+ plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum"),
stages = "",
phase2 = FALSE,
warningLimits = FALSE,
@@ -788,12 +824,13 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
yTitle <- switch (plotType,
- "xBar" = "Sample average",
- "R" = "Sample range",
- "I" = "Individual value",
- "MR" = "Moving range",
- "MMR" = "Moving range of subgroup mean",
- "s" = "Sample std. dev.")
+ "xBar" = "Sample average",
+ "R" = "Sample range",
+ "I" = "Individual value",
+ "MR" = "Moving range",
+ "MMR" = "Moving range of subgroup mean",
+ "s" = "Sample std. dev.",
+ "cusum" = "Cumulative sum")
lineType <- if (phase2) "solid" else "dashed"
# Create plot
plotObject <- ggplot2::ggplot(clData, ggplot2::aes(x = subgroup, group = stage)) +
@@ -853,8 +890,37 @@ KnownControlStats.RS <- function(N, sigma = 3) {
plotObject <- plotObject + ggplot2::geom_label(data = clLabels, mapping = ggplot2::aes(x = x, y = y, label = label),
inherit.aes = FALSE, size = clLabelSize, na.rm = TRUE) +
ggplot2::scale_y_continuous(name = yTitle, breaks = yBreaks, limits = yLimits) +
+ ggplot2::scale_x_continuous(name = xAxisTitle, breaks = xBreaks, limits = xLimits, labels = xLabels)
+ if (plotType != "cusum") {
+ plotObject <- plotObject +
+ jaspGraphs::geom_line(pointData, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
+ na.rm = TRUE)
+ } else {
+ # since the upper and lower part of the cusum chart are in the same df, we split the first and second half
+ maxSubgroup <- max(pointData$subgroup)
+ firstHalf <- seq(1, maxSubgroup)
+ secondHalf <- firstHalf + maxSubgroup
+ pointDataFirstHalf <- pointData[firstHalf,]
+ pointDataSecondHalf <- pointData[secondHalf,]
+ plotObject <- plotObject +
+ jaspGraphs::geom_line(pointDataFirstHalf, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
+ na.rm = TRUE) +
+ jaspGraphs::geom_line(pointDataSecondHalf, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
+ na.rm = TRUE)
+ }
+ plotObject <- plotObject +
+ jaspGraphs::geom_point(pointData, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage),
+ size = 4, fill = pointData$dotColor, inherit.aes = TRUE, na.rm = TRUE) +
+ jaspGraphs::geom_rangeframe() +
+ jaspGraphs::themeJaspRaw()
+
+ plotObject + ggplot2::geom_label(data = clLabels, mapping = ggplot2::aes(x = x, y = y, label = label),
+ inherit.aes = FALSE, size = clLabelSize, na.rm = TRUE) +
+ ggplot2::scale_y_continuous(name = yTitle, breaks = yBreaks, limits = yLimits) +
ggplot2::scale_x_continuous(name = xAxisTitle, breaks = xBreaks, limits = xLimits, labels = xLabels) +
- jaspGraphs::geom_line(pointData, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
+ jaspGraphs::geom_line(pointData[1:25,], mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
+ na.rm = TRUE) +
+ jaspGraphs::geom_line(pointData[26:50,], mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
na.rm = TRUE) +
jaspGraphs::geom_point(pointData, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage),
size = 4, fill = pointData$dotColor, inherit.aes = TRUE, na.rm = TRUE) +
@@ -889,3 +955,29 @@ KnownControlStats.RS <- function(N, sigma = 3) {
return(violationsList)
}
+
+.cusumPoints <- function(data, sigma, n, target, shiftSize, cuType = c("lower", "upper")) {
+ cuType <- match.arg(cuType)
+
+ # Initialize vector and first point
+ cuSumPoints <- c()
+ if (cuType == "lower") {
+ initialPoint <- rowMeans(data[1,], na.rm = T) - (target - shiftSize*(sigma/sqrt(n[1])))
+ cuSumPoints[1] <- min(0, initialPoint)
+ } else {
+ initialPoint <- rowMeans(data[1,], na.rm = T) - (target + shiftSize*(sigma/sqrt(n[1])))
+ cuSumPoints[1] <- max(0, initialPoint)
+ }
+
+ # Loop over remaining data
+ for (i in seq(2, nrow(data))) {
+ if (cuType == "lower") {
+ cuSumPoint <- cuSumPoints[i-1] + rowMeans(data[i,], na.rm = T) - (target - shiftSize*(sigma/sqrt(n[i])))
+ cuSumPoints[i] <- min(0, cuSumPoint)
+ } else {
+ cuSumPoint <- cuSumPoints[i-1] + rowMeans(data[i,], na.rm = T) - (target + shiftSize*(sigma/sqrt(n[i])))
+ cuSumPoints[i] <- max(0, cuSumPoint)
+ }
+ }
+ return(cuSumPoints)
+}
diff --git a/inst/Description.qml b/inst/Description.qml
index 4c15e047..0d278304 100644
--- a/inst/Description.qml
+++ b/inst/Description.qml
@@ -82,6 +82,12 @@ Description
func: "timeWeightedCharts"
}
+ Analysis
+ {
+ title: qsTr("Rare Event Charts")
+ func: "rareEventCharts"
+ }
+
GroupTitle
{
title: qsTr("Capability Analysis")
diff --git a/inst/qml/rareEventCharts.qml b/inst/qml/rareEventCharts.qml
new file mode 100644
index 00000000..fbae82a6
--- /dev/null
+++ b/inst/qml/rareEventCharts.qml
@@ -0,0 +1,44 @@
+import QtQuick 2.8
+import QtQuick.Layouts 1.3
+import JASP.Controls 1.0
+import JASP.Widgets 1.0
+
+Form
+{
+ columns: 2
+
+ VariablesForm
+ {
+ id: variablesForm
+ AvailableVariablesList
+ {
+ name: "variablesForm"
+ }
+
+ AssignedVariablesList
+ {
+ name: "variables"
+ title: qsTr("Variables")
+ id: variable
+ allowedColumns: ["scale"]
+ singleVariable: false
+ }
+ }
+
+ Group
+ {
+ CheckBox
+ {
+ name: "gChart"
+ label: qsTr("g chart")
+ checked: true
+ }
+
+ CheckBox
+ {
+ name: "tChart"
+ label: qsTr("t chart")
+ checked: true
+ }
+ }
+}
diff --git a/inst/qml/timeWeightedCharts.qml b/inst/qml/timeWeightedCharts.qml
index aac05c85..d8213f71 100644
--- a/inst/qml/timeWeightedCharts.qml
+++ b/inst/qml/timeWeightedCharts.qml
@@ -5,28 +5,150 @@ import JASP.Widgets 1.0
Form
{
- columns: 1
+ columns: 2
+
+ DropDown
+ {
+ name: "dataFormat"
+ label: qsTr("Data format")
+ id: dataFormat
+ indexDefaultValue: 0
+ values: [
+ { label: qsTr("Single column"), value: "longFormat"},
+ { label: qsTr("Across rows"), value: "wideFormat"}
+ ]
+ }
VariablesForm
{
- preferredHeight: jaspTheme.smallDefaultVariablesFormHeight
+ id: variablesFormLongFormat
+ visible: dataFormat.currentValue == "longFormat"
AvailableVariablesList
{
- name: "variablesForm"
+ name: "variablesFormLongFormat"
}
AssignedVariablesList
{
- name: "measurements"
+ name: "measurementLongFormat"
+ title: qsTr("Measurement")
+ id: measurementLongFormat
+ allowedColumns: ["scale"]
+ singleVariable: true
+ }
+
+ AssignedVariablesList
+ {
+ id: subgroup
+ name: "subgroup"
+ title: qsTr("Subgroups")
+ singleVariable: true
+ allowedColumns: ["nominal"]
+ enabled: subgroupSizeType.value == "groupingVariable"
+ }
+
+ AssignedVariablesList
+ {
+ name: "stagesLongFormat"
+ id: stagesLongFormat
+ title: qsTr("Stages")
+ singleVariable: true
+ allowedColumns: ["nominal"]
+ }
+ }
+
+
+ VariablesForm
+ {
+ id: variablesFormWideFormat
+ visible: dataFormat.currentValue == "wideFormat"
+
+ AvailableVariablesList
+ {
+ name: "variablesFormWideFormat"
+ }
+
+
+ AssignedVariablesList
+ {
+ name: "measurementsWideFormat"
title: qsTr("Measurements")
+ id: measurementsWideFormat
allowedColumns: ["scale"]
}
+
+
+
+ AssignedVariablesList
+ {
+ id: axisLabels
+ name: "axisLabels"
+ title: qsTr("Timestamp (optional)")
+ singleVariable: true
+ allowedColumns: ["nominal"]
+ }
+
+ AssignedVariablesList
+ {
+ name: "stagesWideFormat"
+ id: stagesWideFormat
+ title: qsTr("Stages")
+ singleVariable: true
+ allowedColumns: ["nominal"]
+ }
}
Group
{
- columns: 1
+
+ RadioButtonGroup
+ {
+ name: "subgroupSizeType"
+ title: qsTr("Specify subgroups")
+ id: subgroupSizeType
+ visible: dataFormat.currentValue == "longFormat"
+
+ RadioButton
+ {
+ value: "manual"
+ label: qsTr("Subgroup size")
+ checked: true
+ childrenOnSameRow: true
+
+ DoubleField
+ {
+ name: "manualSubgroupSizeValue"
+ min: 1
+ defaultValue: 5
+ }
+ }
+
+ RadioButton
+ {
+ value: "groupingVariable"
+ label: qsTr("Through grouping variable")
+
+ DropDown
+ {
+ name: "groupingVariableMethod"
+ id: groupingVariable
+ label: "Grouping method"
+ values:
+ [
+ { label: qsTr("Subgroup value change"), value: "newLabel"},
+ { label: qsTr("Same subgroup value"), value: "sameLabel"}
+ ]
+ indexDefaultValue: 0
+ }
+ }
+ }
+ }
+
+
+
+ Group
+ {
CheckBox
{
@@ -37,9 +159,8 @@ Form
DoubleField
{
name: "cumulativeSumChartNumberSd"
- label: qsTr("Number of standard deviations")
+ label: qsTr("Number of std. dev. for limits")
defaultValue: 4
- enabled: variationReference.currentValue != "studyVariation"
}
DoubleField
@@ -47,7 +168,50 @@ Form
name: "cumulativeSumChartShiftSize"
label: qsTr("Shift size")
defaultValue: 0.5
- enabled: variationReference.currentValue != "studyVariation"
+ }
+
+ DoubleField
+ {
+ name: "cumulativeSumChartTarget"
+ label: qsTr("Target")
+ defaultValue: 0
+ }
+
+ Group
+ {
+ DropDown
+ {
+ name: "cumulativeSumChartSdSource"
+ label: qsTr("Std. dev.")
+ id: cumulativeSumChartSdSource
+ indexDefaultValue: 0
+ values: [
+ { label: qsTr("Estimated from data"), value: "data"},
+ { label: qsTr("Historical"), value: "historical"}
+ ]
+ }
+
+ DropDown
+ {
+ name: "cumulativeSumChartSdMethod"
+ visible: cumulativeSumChartSdSource.currentValue == "data"
+ label: qsTr("Std. dev. estimation method")
+ id: cumulativeSumChartSdMethod
+ indexDefaultValue: 0
+ values: [
+ { label: qsTr("R-bar"), value: "r"},
+ { label: qsTr("S-bar"), value: "s"}
+ ]
+ }
+
+ DoubleField
+ {
+ name: "cumulativeSumChartSdValue"
+ label: qsTr("Std. dev. value")
+ visible: cumulativeSumChartSdSource.currentValue == "historical"
+ defaultValue: 3
+ fieldWidth: 50
+ }
}
}
@@ -59,42 +223,46 @@ Form
DoubleField
{
name: "exponentiallyWeightedMovingAverageChartLambda"
- label: qsTr("Lambda")
+ label: qsTr("Lambda (smoothing parameter)")
defaultValue: 0.3
}
DoubleField
{
name: "exponentiallyWeightedMovingAverageChartCenter"
- label: qsTr("Center")
+ label: qsTr("Target of the mean")
}
- DoubleField
+ Group
{
- name: "exponentiallyWeightedMovingAverageChartSd"
- label: qsTr("Within-group standard deviation")
- defaultValue: 3
- fieldWidth: 50
+ DropDown
+ {
+ name: "exponentiallyWeightedMovingAverageChartSdSource"
+ label: qsTr("In-control std. dev.")
+ id: exponentiallyWeightedMovingAverageChartSdSource
+ indexDefaultValue: 0
+ values: [
+ { label: qsTr("Estimated from data"), value: "data"},
+ { label: qsTr("Historical"), value: "historical"}
+ ]
+ }
+
+ DoubleField
+ {
+ name: "exponentiallyWeightedMovingAverageChartSdValue"
+ label: qsTr("Std. dev. value")
+ visible: exponentiallyWeightedMovingAverageChartSdSource.currentValue == "historical"
+ defaultValue: 3
+ fieldWidth: 50
+ }
}
DoubleField
{
name: "exponentiallyWeightedMovingAverageChartSigmaControlLimits"
- label: qsTr("Sigmas for computing control limits")
+ label: qsTr("Number of sigmas for control limits")
defaultValue: 3
}
}
-
- CheckBox
- {
- name: "gChart"
- label: qsTr("g chart")
- }
-
- // CheckBox
- // {
- // name: "tchart"
- // label: qsTr("t chart")
- // }
}
}
From 4ff6265325f6e95703fa7c0fa4f829d666974494 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 7 Aug 2024 16:48:13 +0200
Subject: [PATCH 02/25] Cusum chart final features
---
R/TimeWeightedCharts.R | 57 +++++++++++++++----------
R/commonQualityControl.R | 74 ++++++++++++++++++---------------
inst/qml/timeWeightedCharts.qml | 66 ++++++++++++++++++++++-------
3 files changed, 126 insertions(+), 71 deletions(-)
diff --git a/R/TimeWeightedCharts.R b/R/TimeWeightedCharts.R
index b0b19331..83e51b1a 100644
--- a/R/TimeWeightedCharts.R
+++ b/R/TimeWeightedCharts.R
@@ -10,8 +10,17 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
} else {
measurements <- options[["measurementLongFormat"]]
stages <- options[["stagesLongFormat"]]
- subgroupVariable <- options[["subgroup"]]
- factorVariables <- c(subgroupVariable, stages)
+ # Workaround to create subgroups of size 1 in long format while still using axis labels, but not creating a whole separate variable form
+ if (options[["subgroupSizeType"]] == "individual") {
+ axisLabels <- options[["subgroup"]]
+ options[["subgroupSizeType"]] <- "manual"
+ options[["manualSubgroupSizeValue"]] <- 1
+ subgroupVariable <- ""
+ } else {
+ subgroupVariable <- options[["subgroup"]]
+ axisLabels <- ""
+ }
+ factorVariables <- c(axisLabels, subgroupVariable, stages)
}
measurements <- measurements[measurements != ""]
@@ -42,26 +51,29 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
infinity.target = c(measurements, options$subgroup),
exitAnalysisIfErrors = TRUE)
- plotNotes <- ""
- if (!identical(stages, "")) {
- if ((!wideFormat && options[["subgroupSizeType"]] == "manual" &&
- any(lapply(split(dataset[[stages]], ceiling(seq_along(dataset[[stages]])/options[["manualSubgroupSizeValue"]])), FUN = function(x)length(unique(x))) > 1)) ||
- (!wideFormat && options[["subgroupSizeType"]] == "groupingVariable" &&
- any(table(dplyr::count_(dataset, vars = c(stages, subgroupVariable))[subgroupVariable]) > 1))) {
- plotNotes <- paste0(plotNotes, gettext("One or more subgroups are assigned to more than one stage, only first stage is considered.
"))
- }
- if (anyNA(dataset[[stages]])) {
- nDroppedStageRows <- sum(is.na(dataset[[stages]]))
- dataset <- dataset[!is.na(dataset[[stages]]),]
- removalType <- if (wideFormat) "subgroup(s)" else "observation(s)"
- plotNotes <- paste0(plotNotes, gettextf("Removed %1$i %2$s that were not assigned to any stage.
", nDroppedStageRows, removalType))
+ # warning handling
+ if (ready) {
+ plotNotes <- ""
+ if (!identical(stages, "")) {
+ if ((!wideFormat && options[["subgroupSizeType"]] == "manual" &&
+ any(lapply(split(dataset[[stages]], ceiling(seq_along(dataset[[stages]])/options[["manualSubgroupSizeValue"]])), FUN = function(x)length(unique(x))) > 1)) ||
+ (!wideFormat && options[["subgroupSizeType"]] == "groupingVariable" &&
+ any(table(dplyr::count_(dataset, vars = c(stages, subgroupVariable))[subgroupVariable]) > 1))) {
+ plotNotes <- paste0(plotNotes, gettext("One or more subgroups are assigned to more than one stage, only first stage is considered.
"))
+ }
+ if (anyNA(dataset[[stages]])) {
+ nDroppedStageRows <- sum(is.na(dataset[[stages]]))
+ dataset <- dataset[!is.na(dataset[[stages]]),]
+ removalType <- if (wideFormat) "subgroup(s)" else "observation(s)"
+ plotNotes <- paste0(plotNotes, gettextf("Removed %1$i %2$s that were not assigned to any stage.
", nDroppedStageRows, removalType))
+ }
}
- }
- if (!wideFormat && options[["subgroupSizeType"]] == "groupingVariable" && anyNA(dataset[[subgroupVariable]])) {
- nDroppedSubgroupRows <- sum(is.na(dataset[[subgroupVariable]]))
- dataset <- dataset[!is.na(dataset[[subgroupVariable]]),]
- plotNotes <- paste0(plotNotes, gettextf("Removed %i observation(s) that were not assigned to any subgroups.
", nDroppedSubgroupRows))
+ if (!wideFormat && options[["subgroupSizeType"]] == "groupingVariable" && anyNA(dataset[[subgroupVariable]])) {
+ nDroppedSubgroupRows <- sum(is.na(dataset[[subgroupVariable]]))
+ dataset <- dataset[!is.na(dataset[[subgroupVariable]]),]
+ plotNotes <- paste0(plotNotes, gettextf("Removed %i observation(s) that were not assigned to any subgroups.
", nDroppedSubgroupRows))
+ }
}
# Rearrange data if not already wide format (one group per row)
@@ -70,9 +82,9 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
subgroupSizeType = options[["subgroupSizeType"]],
manualSubgroupSizeValue = options[["manualSubgroupSizeValue"]],
subgroupVariableMethod = options[["groupingVariableMethod"]])
+ axisLabels <- if (axisLabels == "") reshapeOutputList$axisLabels else dataset[[axisLabels]]
dataset <- reshapeOutputList$dataset
measurements <- reshapeOutputList$measurements
- axisLabels <- reshapeOutputList$axisLabels
xAxisTitle <- reshapeOutputList$xAxisTitle
} else if (wideFormat && ready) {
if (axisLabels != "") {
@@ -109,7 +121,8 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
columnsToPass <- columnsToPass[columnsToPass != ""]
plotObject <- .controlChart(dataset[columnsToPass], plotType = "cusum", stages = stages, xBarSdType = options[["cumulativeSumChartSdMethod"]],
nSigmasControlLimits = options[["cumulativeSumChartNumberSd"]], xAxisLabels = axisLabels,
- cusumShiftSize = options[["cumulativeSumChartShiftSize"]], cusumTarget = options[["cumulativeSumChartTarget"]])$plotObject
+ cusumShiftSize = options[["cumulativeSumChartShiftSize"]], cusumTarget = options[["cumulativeSumChartTarget"]],
+ movingRangeLength = options[["averageMovingRangeLength"]])$plotObject
plot$plotObject <- plotObject
#
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index bedf9028..f59d4374 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -603,9 +603,17 @@ KnownControlStats.RS <- function(N, sigma = 3) {
###
} else if (plotType == "cusum") {
n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
- # sigma for subgroup size = 1
+ # sigma for subgroup size = 1 is calculated as the average moving range sd
if (all(n == 1)) {
-
+ k <- movingRangeLength
+ dataCurrentStageVector <- unlist(dataCurrentStage)
+ mrMatrix <- matrix(dataCurrentStageVector[seq((k), length(dataCurrentStageVector))]) # remove first k - 1 elements
+ for (j in seq(1, k-1)) {
+ mrMatrix <- cbind(mrMatrix, matrix(dataCurrentStageVector[seq(k-j, length(dataCurrentStageVector)-j)]))
+ }
+ meanMovingRange <- mean(.rowRanges(mrMatrix)$ranges, na.rm = TRUE)
+ d2 <- KnownControlStats.RS(k)$constants[1]
+ sigma <- meanMovingRange/d2
# sigma for subgroup size > 1
} else {
sigma <- .sdXbar(dataCurrentStage, type = xBarSdType, unbiasingConstantUsed = unbiasingConstantUsed)
@@ -618,8 +626,12 @@ KnownControlStats.RS <- function(N, sigma = 3) {
center <- 0 # not to be confused with the target, even if target != 0, the center line of the plot should be at 0
}
if (i != 1) {
- # TODO: adjust for cusum chart
+ if (plotType == "cusum") {
+ subgroups <- rep(seq_along(plotStatisticUpper), 2) + max(plotData$subgroup)
+ } else {
subgroups <- seq(max(plotData$subgroup) + 1, max(plotData$subgroup) + length(plotStatistic))
+ }
+
dfStageLabels <- rbind(dfStageLabels, data.frame(x = max(plotData$subgroup) + length(subgroups)/2,
y = NA, # the y value will be filled in later
label = stage,
@@ -884,7 +896,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
if (!identical(stages, "")) {
stageLabels$y <- max(yLimits)
plotObject <- plotObject + ggplot2::geom_vline(xintercept = na.omit(stageLabels[["separationLine"]])) +
- ggplot2::geom_text(data = stageLabels, mapping = ggplot2::aes(x = x, y = y, label = label, na.rm = TRUE),
+ ggplot2::geom_text(data = stageLabels, mapping = ggplot2::aes(x = x, y = y, label = label),
size = 6, fontface = "bold", inherit.aes = FALSE)
}
plotObject <- plotObject + ggplot2::geom_label(data = clLabels, mapping = ggplot2::aes(x = x, y = y, label = label),
@@ -894,19 +906,26 @@ KnownControlStats.RS <- function(N, sigma = 3) {
if (plotType != "cusum") {
plotObject <- plotObject +
jaspGraphs::geom_line(pointData, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
- na.rm = TRUE)
- } else {
- # since the upper and lower part of the cusum chart are in the same df, we split the first and second half
- maxSubgroup <- max(pointData$subgroup)
- firstHalf <- seq(1, maxSubgroup)
- secondHalf <- firstHalf + maxSubgroup
- pointDataFirstHalf <- pointData[firstHalf,]
- pointDataSecondHalf <- pointData[secondHalf,]
- plotObject <- plotObject +
- jaspGraphs::geom_line(pointDataFirstHalf, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
- na.rm = TRUE) +
- jaspGraphs::geom_line(pointDataSecondHalf, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
na.rm = TRUE)
+ } else {
+ # since the upper and lower part of the cusum chart are in the same df, we split the first and second half; if there are stages, do this for each stage
+ # loop over stages
+ for (stage_i in unique(pointData[["stage"]])) {
+ pointDataSubset <- subset.data.frame(pointData, pointData$stage == stage_i)
+ if (length(pointDataSubset$subgroup) %% 2 != 0)
+ stop("Data provided to cusum plot function is not symmetric, i.e. unequal amount of points above and below 0.")
+ nSubgroupsStage <- length(pointDataSubset$subgroup)/2 # the data should always be symmetrical, hence we can divide by two
+ firstHalf <- seq(1, nSubgroupsStage)
+ secondHalf <- firstHalf + nSubgroupsStage
+ pointDataFirstHalf <- pointDataSubset[firstHalf,]
+ pointDataSecondHalf <- pointDataSubset[secondHalf,]
+ plotObject <- plotObject +
+ jaspGraphs::geom_line(pointDataFirstHalf, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
+ na.rm = TRUE) +
+ jaspGraphs::geom_line(pointDataSecondHalf, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
+ na.rm = TRUE)
+ }
+
}
plotObject <- plotObject +
jaspGraphs::geom_point(pointData, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage),
@@ -914,19 +933,6 @@ KnownControlStats.RS <- function(N, sigma = 3) {
jaspGraphs::geom_rangeframe() +
jaspGraphs::themeJaspRaw()
- plotObject + ggplot2::geom_label(data = clLabels, mapping = ggplot2::aes(x = x, y = y, label = label),
- inherit.aes = FALSE, size = clLabelSize, na.rm = TRUE) +
- ggplot2::scale_y_continuous(name = yTitle, breaks = yBreaks, limits = yLimits) +
- ggplot2::scale_x_continuous(name = xAxisTitle, breaks = xBreaks, limits = xLimits, labels = xLabels) +
- jaspGraphs::geom_line(pointData[1:25,], mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
- na.rm = TRUE) +
- jaspGraphs::geom_line(pointData[26:50,], mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage), color = "blue",
- na.rm = TRUE) +
- jaspGraphs::geom_point(pointData, mapping = ggplot2::aes(x = subgroup, y = plotStatistic, group = stage),
- size = 4, fill = pointData$dotColor, inherit.aes = TRUE, na.rm = TRUE) +
- jaspGraphs::geom_rangeframe() +
- jaspGraphs::themeJaspRaw()
-
return(plotObject)
}
@@ -961,21 +967,23 @@ KnownControlStats.RS <- function(N, sigma = 3) {
# Initialize vector and first point
cuSumPoints <- c()
+ rowMeanInitial <- if (length(data[1,]) == 1) data[1,] else rowMeans(data[1,], na.rm = T)
if (cuType == "lower") {
- initialPoint <- rowMeans(data[1,], na.rm = T) - (target - shiftSize*(sigma/sqrt(n[1])))
+ initialPoint <- rowMeanInitial - (target - shiftSize*(sigma/sqrt(n[1])))
cuSumPoints[1] <- min(0, initialPoint)
} else {
- initialPoint <- rowMeans(data[1,], na.rm = T) - (target + shiftSize*(sigma/sqrt(n[1])))
+ initialPoint <- rowMeanInitial - (target + shiftSize*(sigma/sqrt(n[1])))
cuSumPoints[1] <- max(0, initialPoint)
}
# Loop over remaining data
for (i in seq(2, nrow(data))) {
+ rowMean_i <- if (length(data[i,]) == 1) data[i,] else rowMeans(data[i,], na.rm = T)
if (cuType == "lower") {
- cuSumPoint <- cuSumPoints[i-1] + rowMeans(data[i,], na.rm = T) - (target - shiftSize*(sigma/sqrt(n[i])))
+ cuSumPoint <- cuSumPoints[i-1] + rowMean_i - (target - shiftSize*(sigma/sqrt(n[i])))
cuSumPoints[i] <- min(0, cuSumPoint)
} else {
- cuSumPoint <- cuSumPoints[i-1] + rowMeans(data[i,], na.rm = T) - (target + shiftSize*(sigma/sqrt(n[i])))
+ cuSumPoint <- cuSumPoints[i-1] + rowMean_i - (target + shiftSize*(sigma/sqrt(n[i])))
cuSumPoints[i] <- max(0, cuSumPoint)
}
}
diff --git a/inst/qml/timeWeightedCharts.qml b/inst/qml/timeWeightedCharts.qml
index d8213f71..4eca3809 100644
--- a/inst/qml/timeWeightedCharts.qml
+++ b/inst/qml/timeWeightedCharts.qml
@@ -42,10 +42,10 @@ Form
{
id: subgroup
name: "subgroup"
- title: qsTr("Subgroups")
+ title: subgroupSizeType.value == "individual" ? qsTr("Timestamp (optional)") : qsTr("Subgroups")
singleVariable: true
allowedColumns: ["nominal"]
- enabled: subgroupSizeType.value == "groupingVariable"
+ enabled: subgroupSizeType.value == "groupingVariable" | subgroupSizeType.value == "individual"
}
AssignedVariablesList
@@ -107,19 +107,25 @@ Form
name: "subgroupSizeType"
title: qsTr("Specify subgroups")
id: subgroupSizeType
- visible: dataFormat.currentValue == "longFormat"
+ visible: dataFormat.currentValue == "longFormat"
+
+ RadioButton
+ {
+ value: "individual"
+ label: qsTr("No subgroups (n = 1)")
+ checked: true
+ }
RadioButton
{
value: "manual"
label: qsTr("Subgroup size")
- checked: true
childrenOnSameRow: true
- DoubleField
+ IntegerField
{
name: "manualSubgroupSizeValue"
- min: 1
+ min: 2
defaultValue: 5
}
}
@@ -142,6 +148,7 @@ Form
indexDefaultValue: 0
}
}
+
}
}
@@ -197,11 +204,15 @@ Form
visible: cumulativeSumChartSdSource.currentValue == "data"
label: qsTr("Std. dev. estimation method")
id: cumulativeSumChartSdMethod
- indexDefaultValue: 0
- values: [
- { label: qsTr("R-bar"), value: "r"},
- { label: qsTr("S-bar"), value: "s"}
+ values: subgroupSizeType.value == "individual" ?
+ [
+ { label: qsTr("X-mR"), value: "averageMovingRange"}
+ ] :
+ [
+ { label: qsTr("S-bar"), value: "s"},
+ { label: qsTr("R-bar"), value: "r"}
]
+ indexDefaultValue: subgroupSizeType.value == "individual" ? 0 : 1
}
DoubleField
@@ -212,6 +223,15 @@ Form
defaultValue: 3
fieldWidth: 50
}
+
+ IntegerField
+ {
+ name: "averageMovingRangeLength"
+ label: qsTr("Moving range length")
+ visible: cumulativeSumChartSdMethod.currentValue == "averageMovingRange"
+ min: 2
+ defaultValue: 2
+ }
}
}
@@ -220,6 +240,14 @@ Form
name: "exponentiallyWeightedMovingAverageChart"
label: qsTr("Exponentially weighted moving average chart")
+
+ DoubleField
+ {
+ name: "exponentiallyWeightedMovingAverageChartSigmaControlLimits"
+ label: qsTr("Number of sigmas for control limits")
+ defaultValue: 3
+ }
+
DoubleField
{
name: "exponentiallyWeightedMovingAverageChartLambda"
@@ -255,13 +283,19 @@ Form
defaultValue: 3
fieldWidth: 50
}
- }
- DoubleField
- {
- name: "exponentiallyWeightedMovingAverageChartSigmaControlLimits"
- label: qsTr("Number of sigmas for control limits")
- defaultValue: 3
+ DropDown
+ {
+ name: "exponentiallyWeightedMovingAverageChartSdMethod"
+ visible: exponentiallyWeightedMovingAverageChartSdSource.currentValue == "data"
+ label: qsTr("Std. dev. estimation method")
+ id: exponentiallyWeightedMovingAverageChartSdMethod
+ indexDefaultValue: 0
+ values: [
+ { label: qsTr("R-bar"), value: "r"},
+ { label: qsTr("S-bar"), value: "s"}
+ ]
+ }
}
}
}
From 6ac39e6bc6b03a380848e7ad5a86687c6eb6dfe1 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Fri, 9 Aug 2024 16:54:58 +0200
Subject: [PATCH 03/25] ewma chart
---
R/TimeWeightedCharts.R | 106 ++++--------------
R/commonQualityControl.R | 192 +++++++++++++++++++++-----------
inst/qml/timeWeightedCharts.qml | 51 +++++----
3 files changed, 178 insertions(+), 171 deletions(-)
diff --git a/R/TimeWeightedCharts.R b/R/TimeWeightedCharts.R
index 83e51b1a..46f47828 100644
--- a/R/TimeWeightedCharts.R
+++ b/R/TimeWeightedCharts.R
@@ -102,9 +102,8 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
}
#EWMA chart
if (options[["exponentiallyWeightedMovingAverageChart"]] && is.null(jaspResults[["EWMAPlot"]])) {
- jaspResults[["EWMAPlot"]] <- createJaspPlot(title = gettext("Exponentially weighted moving average chart"), width = 1200, height = 500)
- jaspResults[["EWMAPlot"]]$dependOn(c("ExponentiallyWeightedMovingAverageChart", "measurements"))
- jaspResults[["EWMAPlot"]]$plotObject <- .EWMA(dataset = dataset, options = options, ready = ready)
+ jaspResults[["EWMAPlot"]] <- .EWMA(dataset = dataset, measurements = measurements, stages = stages,
+ axisLabels = axisLabels, options = options, ready = ready)
}
}
@@ -119,97 +118,38 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
columnsToPass <- c(measurements, stages)
columnsToPass <- columnsToPass[columnsToPass != ""]
+ phase2 <- (options[["cumulativeSumChartSdSource"]] == "historical")
plotObject <- .controlChart(dataset[columnsToPass], plotType = "cusum", stages = stages, xBarSdType = options[["cumulativeSumChartSdMethod"]],
nSigmasControlLimits = options[["cumulativeSumChartNumberSd"]], xAxisLabels = axisLabels,
cusumShiftSize = options[["cumulativeSumChartShiftSize"]], cusumTarget = options[["cumulativeSumChartTarget"]],
- movingRangeLength = options[["averageMovingRangeLength"]])$plotObject
+ movingRangeLength = options[["cumulativeSumChartAverageMovingRangeLength"]], phase2 = phase2,
+ phase2Sd = options[["cumulativeSumChartSdValue"]])$plotObject
plot$plotObject <- plotObject
- #
- # data1 <- dataset[, options[["measurements"]]]
- # sixsigma <- qcc::cusum(data1, decision.interval = options[["cumulativeSumChartNumberSd"]], se.shift = options[["cumulativeSumChartShiftSize"]], plot = FALSE)
- # subgroups <- c(1:length(sixsigma$pos))
- # data_plot <- data.frame(y_neg = sixsigma$neg , y_pos = sixsigma$pos, x = subgroups)
- # center <- 0
- # UCL <- sixsigma$decision.interval
- # LCL <- -UCL
- # yBreaks <- jaspGraphs::getPrettyAxisBreaks(c(LCL, UCL, data_plot$y_neg, data_plot$y_pos))
- # yLimits <- range(yBreaks)
- # if (length(subgroups) > 60)
- # xBreaks <- c(1,jaspGraphs::getPrettyAxisBreaks(subgroups)[-1])
- # else
- # xBreaks <- c(subgroups)
- # xLimits <- c(1,max(xBreaks) + 2.5)
- # dfLabel <- data.frame(
- # x = max(xLimits - 1),
- # y = c(center, UCL, LCL),
- # l = c(
- # gettextf("CL = %g", round(center, 4)),
- # gettextf("UCL = %g", round(UCL, 5)),
- # gettextf("LCL = %g", round(LCL, 5))
- # )
- # )
- #
- # p <- ggplot2::ggplot(data_plot, ggplot2::aes(x)) +
- # ggplot2::geom_hline(yintercept = center, color = 'green') +
- # ggplot2::geom_hline(yintercept = c(UCL, LCL), color = "red", linetype = "dashed", size = 1.5) +
- # ggplot2::geom_label(data = dfLabel, mapping = ggplot2::aes(x = x, y = y, label = l),inherit.aes = FALSE, size = 4.5) +
- # ggplot2::scale_y_continuous(name = gettext("Cumulative sum") ,limits = yLimits, breaks = yBreaks) +
- # ggplot2::scale_x_continuous(name = gettext('Subgroups'), breaks = xBreaks, limits = range(xLimits)) +
- # jaspGraphs::geom_line(ggplot2::aes(y = y_neg), col = "blue") +
- # jaspGraphs::geom_line(ggplot2::aes(y = y_pos), col = "blue")+
- # jaspGraphs::geom_point(ggplot2::aes(y = y_neg), size = 4, fill = ifelse(data_plot$y_neg < LCL, 'red', 'blue')) +
- # jaspGraphs::geom_point(ggplot2::aes(y = y_pos), size = 4, fill = ifelse(data_plot$y_pos > UCL, 'red', 'blue')) +
- # jaspGraphs::geom_rangeframe() +
- # jaspGraphs::themeJaspRaw()
-
return(plot)
}
-.EWMA <- function(dataset, options, ready) {
+
+.EWMA <- function(dataset, measurements, stages, axisLabels, options, ready) {
+
+ plot <- createJaspPlot(title = gettext("Exponentially weighted moving average chart"), width = 1200, height = 500)
+ plot$dependOn(c(""))
+
if (!ready)
- return()
- decimals <- .numDecimals
- data1 <- dataset[, options[["measurements"]]]
- sixsigma <- qcc::ewma(data1, center = options[["exponentiallyWeightedMovingAverageChartCenter"]] , lambda = options[["exponentiallyWeightedMovingAverageChartLambda"]],
- std.dev = options[["exponentiallyWeightedMovingAverageChartSd"]], nsigmas = options[["exponentiallyWeightedMovingAverageChartSigmaControlLimits"]], plot = FALSE)
- subgroups <- 1:length(sixsigma$sizes)
- center <- sixsigma$center
- UCL <- sixsigma$limits[,2]
- LCL <- sixsigma$limits[,1]
- data_plot <- data.frame(y = sixsigma$y, x = subgroups, UCL = UCL, LCL = LCL)
- yBreaks <- jaspGraphs::getPrettyAxisBreaks(c(LCL, UCL, data_plot$y))
- yLimits <- range(yBreaks)
- if (length(subgroups) > 60)
- xBreaks <- c(1,jaspGraphs::getPrettyAxisBreaks(subgroups)[-1])
- else
- xBreaks <- c(subgroups)
- xLimits <- c(1,max(xBreaks-0.5) * 1.15)
- UCL.label <- center + options[["exponentiallyWeightedMovingAverageChartSigmaControlLimits"]] * sqrt(options[["exponentiallyWeightedMovingAverageChartLambda"]] / (2-options[["exponentiallyWeightedMovingAverageChartLambda"]])) * options[["exponentiallyWeightedMovingAverageChartSd"]]
- LCL.label <- center - options[["exponentiallyWeightedMovingAverageChartSigmaControlLimits"]] * sqrt(options[["exponentiallyWeightedMovingAverageChartLambda"]] / (2-options[["exponentiallyWeightedMovingAverageChartLambda"]])) * options[["exponentiallyWeightedMovingAverageChartSd"]]
- dfLabel <- data.frame(
- x = max(xLimits) * 0.95,
- y = c(center, UCL.label, LCL.label),
- l = c(
- gettextf("CL = %g", round(center, decimals + 1)),
- gettextf("UCL = %g", round(UCL.label, decimals + 2)),
- gettextf("LCL = %g", round(LCL.label, decimals + 2))
- )
- )
+ return(plot)
- p <- ggplot2::ggplot(data_plot, ggplot2::aes(x = x, y = y)) +
- ggplot2::geom_step(ggplot2::aes(x = x, y = UCL, color = "red"),linetype = "dashed", size = 1.5) +
- ggplot2::geom_step(ggplot2::aes(x = x, y = LCL, color = "red"), linetype = "dashed", size = 1.5) +
- ggplot2::geom_hline(yintercept = center, color = 'green') +
- ggplot2::geom_label(data = dfLabel, mapping = ggplot2::aes(x = x, y = y, label = l),inherit.aes = FALSE, size = 4.5) +
- ggplot2::scale_y_continuous(name = gettext("EWMA") ,limits = yLimits, breaks = yBreaks) +
- ggplot2::scale_x_continuous(name = gettext('Subgroup'), breaks = xBreaks, limits = range(xLimits)) +
- ggplot2::geom_line(color = "blue") +
- jaspGraphs::geom_point(size = 4, fill = ifelse(data_plot$y > UCL | data_plot$y < LCL, 'red', 'blue')) +
- jaspGraphs::geom_rangeframe() +
- jaspGraphs::themeJaspRaw()
+ columnsToPass <- c(measurements, stages)
+ columnsToPass <- columnsToPass[columnsToPass != ""]
+ phase2 <- (options[["exponentiallyWeightedMovingAverageChartSdSource"]] == "historical")
+ plotObject <- .controlChart(dataset[columnsToPass], plotType = "ewma", stages = stages, xBarSdType = options[["exponentiallyWeightedMovingAverageChartSdMethod"]],
+ nSigmasControlLimits = options[["exponentiallyWeightedMovingAverageChartSigmaControlLimits"]],
+ xAxisLabels = axisLabels, movingRangeLength = options[["exponentiallyWeightedMovingAverageChartMovingRangeLength"]],
+ ewmaLambda = options[["exponentiallyWeightedMovingAverageChartLambda"]], phase2 = phase2,
+ phase2Sd = options[["exponentiallyWeightedMovingAverageChartSdValue"]])$plotObject
- return(p)
+ plot$plotObject <- plotObject
+ return(plot)
}
+
.Gchart <- function(dataset, options, ready){
if (!ready)
return()
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index f59d4374..3a6738a1 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -225,10 +225,10 @@ NelsonLaws <- function(data, allsix = FALSE, chart = "i", xLabels = NULL) {
warnings[i,] <- warningsRaw
}
} else {
- lcl <- ifelse(is.nan(data$limits[1,1]) || is.na(data$limits[1,1]), NA, data$limits[1,1])
- ucl <- ifelse(is.nan(data$limits[1,2]) || is.na(data$limits[1,2]), NA, data$limits[1,2])
- warnings <- Rspc::EvaluateRules(x = data$statistics, type = chart, lcl = lcl, ucl = ucl, cl = data$center[1], parRules = pars,
- whichRules = c(1:3,5,7:8))
+ lcl <- ifelse(is.nan(data$limits[1,1]) || is.na(data$limits[1,1]), NA, data$limits[1,1])
+ ucl <- ifelse(is.nan(data$limits[1,2]) || is.na(data$limits[1,2]), NA, data$limits[1,2])
+ warnings <- Rspc::EvaluateRules(x = data$statistics, type = chart, lcl = lcl, ucl = ucl, cl = data$center[1], parRules = pars,
+ whichRules = c(1:3,5,7:8))
}
if (allsix) {
@@ -272,7 +272,7 @@ NelsonLaws <- function(data, allsix = FALSE, chart = "i", xLabels = NULL) {
# exclude groups with single observation from calculation
rowRemovalIndex <- which(apply(df, 1, function(x) sum(!is.na(x)) < 2)) # get index of rows with less than 2 obs.
- if (length(rowRemovalIndex) > 0)
+ if (length(rowRemovalIndex) > 0)
df <- df[-rowRemovalIndex, ]
# return sdWithin = 0 if no groups have more than 1 obs
@@ -326,9 +326,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
Data.d2 <- data.frame(
n = 0:50,
d2 = c(NA, NA, 1.128, 1.693 ,2.059, 2.326, 2.534, 2.704, 2.847, 2.970, 3.078, 3.173, 3.258, 3.336, 3.407, 3.472, 3.532,
- 3.588 ,3.640 ,3.689, 3.735, 3.778, 3.819, 3.858, 3.895, 3.931, 3.964, 3.997, 4.027, 4.057, 4.086, 4.113,
- 4.139 ,4.165 ,4.189, 4.213, 4.236, 4.259, 4.280, 4.301, 4.322, 4.341, 4.361, 4.379, 4.398, 4.415, 4.433,
- 4.450 ,4.466, 4.482, 4.498))
+ 3.588 ,3.640 ,3.689, 3.735, 3.778, 3.819, 3.858, 3.895, 3.931, 3.964, 3.997, 4.027, 4.057, 4.086, 4.113,
+ 4.139 ,4.165 ,4.189, 4.213, 4.236, 4.259, 4.280, 4.301, 4.322, 4.341, 4.361, 4.379, 4.398, 4.415, 4.433,
+ 4.450 ,4.466, 4.482, 4.498))
if (N > 25 && N <= 50){
d3 <- 0.80818 - 0.0051871 * N + 0.00005098 * N^2 - 0.00000019 * N^3
@@ -393,26 +393,27 @@ KnownControlStats.RS <- function(N, sigma = 3) {
return(list(LCL = LCLvector, UCL = UCLvector))
}
-.controlChart <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum"),
- stages = "",
- xBarSdType = c("r", "s"),
- nSigmasControlLimits = 3,
- phase2 = FALSE,
- phase2Mu = "",
- phase2Sd = "",
- fixedSubgroupSize = "",
- warningLimits = FALSE,
- specificationLimits = NA,
- xAxisLabels = "",
- tableLabels = "",
- xAxisTitle = gettext("Sample"),
- movingRangeLength = 2,
- clLabelSize = 4.5,
- stagesSeparateCalculation = TRUE,
- unbiasingConstantUsed = TRUE,
- cusumShiftSize = 0.5,
- cusumTarget = 0
- ) {
+.controlChart <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma"),
+ stages = "",
+ xBarSdType = c("r", "s"),
+ nSigmasControlLimits = 3,
+ phase2 = FALSE,
+ phase2Mu = "",
+ phase2Sd = "",
+ fixedSubgroupSize = "",
+ warningLimits = FALSE,
+ specificationLimits = NA,
+ xAxisLabels = "",
+ tableLabels = "",
+ xAxisTitle = gettext("Sample"),
+ movingRangeLength = 2,
+ clLabelSize = 4.5,
+ stagesSeparateCalculation = TRUE,
+ unbiasingConstantUsed = TRUE,
+ cusumShiftSize = 0.5,
+ cusumTarget = 0,
+ ewmaLambda = 0.3
+) {
plotType <- match.arg(plotType)
# This function returns all the needed data for the plot and table: data for the points, the limits, the labels and a list of point violations for the table
@@ -421,7 +422,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
phase2Mu = phase2Mu, phase2Sd = phase2Sd, fixedSubgroupSize = fixedSubgroupSize,
warningLimits = warningLimits, movingRangeLength = movingRangeLength,
stagesSeparateCalculation = stagesSeparateCalculation, unbiasingConstantUsed = unbiasingConstantUsed,
- cusumShiftSize = cusumShiftSize, cusumTarget = cusumTarget)
+ cusumShiftSize = cusumShiftSize, cusumTarget = cusumTarget, ewmaLambda = ewmaLambda)
# This function turns the point violation list into a JASP table
@@ -439,21 +440,22 @@ KnownControlStats.RS <- function(N, sigma = 3) {
return(list(plotObject = plotObject, table = table, controlChartData = controlChartData))
}
-.controlChart_calculations <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum"),
- stages = "",
- xBarSdType = c("r", "s"),
- nSigmasControlLimits = 3,
- phase2 = FALSE,
- phase2Mu = "",
- phase2Sd = "",
- fixedSubgroupSize = "",
- warningLimits = FALSE,
- movingRangeLength = 2,
- stagesSeparateCalculation = TRUE,
- unbiasingConstantUsed = TRUE,
- cusumShiftSize = 0.5,
- cusumTarget = 0
- ) {
+.controlChart_calculations <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma"),
+ stages = "",
+ xBarSdType = c("r", "s"),
+ nSigmasControlLimits = 3,
+ phase2 = FALSE,
+ phase2Mu = "",
+ phase2Sd = "",
+ fixedSubgroupSize = "",
+ warningLimits = FALSE,
+ movingRangeLength = 2,
+ stagesSeparateCalculation = TRUE,
+ unbiasingConstantUsed = TRUE,
+ cusumShiftSize = 0.5,
+ cusumTarget = 0,
+ ewmaLambda = 0.3
+) {
plotType <- match.arg(plotType)
if (identical(stages, "")) {
nStages <- 1
@@ -517,9 +519,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
LCL <- limits[1]
UCL <- limits[2]
center <- qccObject$center
- ###
- ### Calculations for R chart
- ###
+ ###
+ ### Calculations for R chart
+ ###
} else if (plotType == "R") {
n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
# manually calculate mean and sd as the package gives wrong results with NAs
@@ -542,9 +544,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
center <- mu
UCL <- limits$UCL
LCL <- limits$LCL
- ###
- ### Calculations for X-bar chart
- ###
+ ###
+ ### Calculations for X-bar chart
+ ###
} else if (plotType == "xBar") {
xBarSdType <- match.arg(xBarSdType)
if (phase2) {
@@ -574,9 +576,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
LWL1 <- WL1$LCL
UWL2 <- WL2$UCL
LWL2 <- WL2$LCL
- ###
- ### Calculations for S chart
- ###
+ ###
+ ### Calculations for S chart
+ ###
} else if (plotType == "s") {
if(phase2) {
sigma <- phase2Sd
@@ -598,13 +600,15 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
UCL <- limits$UCL
LCL <- limits$LCL
- ###
- ### Calculations for cusum chart
- ###
+ ###
+ ### Calculations for cusum chart
+ ###
} else if (plotType == "cusum") {
n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
# sigma for subgroup size = 1 is calculated as the average moving range sd
- if (all(n == 1)) {
+ if (phase2) {
+ sigma <- as.numeric(phase2Sd)
+ } else if (all(n == 1)) {
k <- movingRangeLength
dataCurrentStageVector <- unlist(dataCurrentStage)
mrMatrix <- matrix(dataCurrentStageVector[seq((k), length(dataCurrentStageVector))]) # remove first k - 1 elements
@@ -614,7 +618,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
meanMovingRange <- mean(.rowRanges(mrMatrix)$ranges, na.rm = TRUE)
d2 <- KnownControlStats.RS(k)$constants[1]
sigma <- meanMovingRange/d2
- # sigma for subgroup size > 1
+ # sigma for subgroup size > 1
} else {
sigma <- .sdXbar(dataCurrentStage, type = xBarSdType, unbiasingConstantUsed = unbiasingConstantUsed)
}
@@ -624,6 +628,32 @@ KnownControlStats.RS <- function(N, sigma = 3) {
UCL <- nSigmasControlLimits*sigma/sqrt(n)
LCL <- -UCL
center <- 0 # not to be confused with the target, even if target != 0, the center line of the plot should be at 0
+ ###
+ ### Calculations for ewma chart
+ ###
+ } else if (plotType == "ewma") {
+ n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
+ if (phase2) {
+ sigma <- as.numeric(phase2Sd)
+ } else if (all(n == 1)) {
+ k <- movingRangeLength
+ dataCurrentStageVector <- unlist(dataCurrentStage)
+ mrMatrix <- matrix(dataCurrentStageVector[seq((k), length(dataCurrentStageVector))]) # remove first k - 1 elements
+ for (j in seq(1, k-1)) {
+ mrMatrix <- cbind(mrMatrix, matrix(dataCurrentStageVector[seq(k-j, length(dataCurrentStageVector)-j)]))
+ }
+ meanMovingRange <- mean(.rowRanges(mrMatrix)$ranges, na.rm = TRUE)
+ d2 <- KnownControlStats.RS(k)$constants[1]
+ sigma <- meanMovingRange/d2
+ # sigma for subgroup size > 1
+ } else {
+ sigma <- .sdXbar(dataCurrentStage, type = xBarSdType, unbiasingConstantUsed = unbiasingConstantUsed)
+ }
+ plotStatistic <- .ewmaPlotStatistic(data = dataCurrentStage, lambda = ewmaLambda)
+ center <- mean(unlist(dataCurrentStage), na.rm = TRUE)
+ individualPointSigmas <- .ewmaPointSigmas(n = n, sigma = sigma, lambda = ewmaLambda)
+ UCL <- center + individualPointSigmas * nSigmasControlLimits
+ LCL <- center - individualPointSigmas * nSigmasControlLimits
}
if (i != 1) {
if (plotType == "cusum") {
@@ -651,7 +681,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
if (length(na.omit(plotStatistic)) > 1) {
if (plotType == "MR" || plotType == "MMR") {
dotColor <- ifelse(c(rep(NA, k-1), NelsonLaws(qccObject)$red_points), 'red', 'blue')
- } else if (plotType == "cusum") {
+ } else if (plotType == "cusum" || plotType == "ewma") {
dotColor <- ifelse(plotStatistic > UCL | plotStatistic < LCL, "red", "blue")
dotColor[is.na(dotColor)] <- "blue"
} else {
@@ -717,7 +747,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
tableLabelsCurrentStage <- subgroups
if (plotType == "MR" || plotType == "MMR")
tableLabelsCurrentStage <- tableLabelsCurrentStage[-seq(1, k-1)]
- if (plotType == "cusum") {
+ if (plotType == "cusum" || plotType == "ewma") {
tableList[[i]] <- c() # pass empty vector for now, until Nelson Laws are updated and can handle other input than QCC objects
} else {
tableList[[i]] <- .NelsonTableList(qccObject = qccObject, type = plotType, labels = tableLabelsCurrentStage)
@@ -734,11 +764,11 @@ KnownControlStats.RS <- function(N, sigma = 3) {
"stageLabels" = dfStageLabels,
"violationTable" = tableList,
"sd" = sigma
- ))
+ ))
}
.controlChart_table <- function(tableList,
- plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum"),
+ plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma"),
stages = "",
tableLabels = "") {
plotType <- match.arg(plotType)
@@ -749,7 +779,8 @@ KnownControlStats.RS <- function(N, sigma = 3) {
"MR" = "moving range",
"MMR" = "moving range",
"s" = "s",
- "cusum" = "cumulative sum"
+ "cusum" = "cumulative sum",
+ "ewma" = "Exponentially weighted moving average"
)
table <- createJaspTable(title = gettextf("Test results for %1$s chart", tableTitle))
table$showSpecifiedColumnsOnly <- TRUE
@@ -809,7 +840,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
.controlChart_plotting <- function(pointData, clData, stageLabels, clLabels,
- plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum"),
+ plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma"),
stages = "",
phase2 = FALSE,
warningLimits = FALSE,
@@ -842,7 +873,8 @@ KnownControlStats.RS <- function(N, sigma = 3) {
"MR" = "Moving range",
"MMR" = "Moving range of subgroup mean",
"s" = "Sample std. dev.",
- "cusum" = "Cumulative sum")
+ "cusum" = "Cumulative sum",
+ "ewma" = "Exponentially weighted moving average")
lineType <- if (phase2) "solid" else "dashed"
# Create plot
plotObject <- ggplot2::ggplot(clData, ggplot2::aes(x = subgroup, group = stage)) +
@@ -864,7 +896,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
plotObject <- plotObject + ggplot2::geom_line(data = lslLineDf, mapping = ggplot2::aes(x = xPos, y = yPos),
inherit.aes = FALSE, linewidth = 1.5, col = "darkred", na.rm = TRUE) +
ggplot2::geom_label(data = lslLabelDf, mapping = ggplot2::aes(x = xPos, y = yPos, label = label),
- inherit.aes = FALSE, size = clLabelSize, hjust = "inward", na.rm = TRUE)
+ inherit.aes = FALSE, size = clLabelSize, hjust = "inward", na.rm = TRUE)
}
if (!is.na(targetYPos)) {
targetLineDf <- data.frame(xPos = xRange, yPos = rep(targetYPos, each = 2))
@@ -978,7 +1010,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
# Loop over remaining data
for (i in seq(2, nrow(data))) {
- rowMean_i <- if (length(data[i,]) == 1) data[i,] else rowMeans(data[i,], na.rm = T)
+ rowMean_i <- if (length(data[i,]) == 1) data[i,] else rowMeans(data[i,], na.rm = TRUE)
if (cuType == "lower") {
cuSumPoint <- cuSumPoints[i-1] + rowMean_i - (target - shiftSize*(sigma/sqrt(n[i])))
cuSumPoints[i] <- min(0, cuSumPoint)
@@ -989,3 +1021,29 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
return(cuSumPoints)
}
+
+.ewmaPlotStatistic <- function(data, lambda) {
+ ewmaPoints <- c()
+ initialPoint <- mean(unlist(data), na.rm = TRUE)
+ rowMeanVector <- if (ncol(data) == 1) unlist(data) else rowMeans(data, na.rm = TRUE)
+ for (i in seq(1, nrow(data))) {
+ previousPoint <- if (i == 1) initialPoint else ewmaPoints[i - 1]
+ ewmaPoint <- lambda * rowMeanVector[i] + (1 - lambda) * previousPoint
+ ewmaPoints[i] <- ewmaPoint
+ }
+return(ewmaPoints)
+}
+
+.ewmaPointSigmas <- function(n = n, sigma = sigma, lambda = ewmaLambda) {
+ ewmaPointSigmas <- c()
+ initialPoint <- (lambda * sigma) / n[1]
+ ewmaPointSigmas[1] <- initialPoint
+ for (i in seq(2, length(n))) {
+ nVector <- n[seq(i-1, 1)]
+ exponentVector <- 2*seq(1, i-1)
+ exponentiallyWeightedVector <- ((1 - lambda)^(exponentVector)) / nVector
+ ewmaPointSigma <- sigma * lambda * sqrt(sum(1/n[i], exponentiallyWeightedVector))
+ ewmaPointSigmas[i] <- ewmaPointSigma
+ }
+ return(ewmaPointSigmas)
+}
diff --git a/inst/qml/timeWeightedCharts.qml b/inst/qml/timeWeightedCharts.qml
index 4eca3809..6858d737 100644
--- a/inst/qml/timeWeightedCharts.qml
+++ b/inst/qml/timeWeightedCharts.qml
@@ -166,7 +166,7 @@ Form
DoubleField
{
name: "cumulativeSumChartNumberSd"
- label: qsTr("Number of std. dev. for limits")
+ label: qsTr("Number of std. dev. for control limits")
defaultValue: 4
}
@@ -226,9 +226,9 @@ Form
IntegerField
{
- name: "averageMovingRangeLength"
+ name: "cumulativeSumChartAverageMovingRangeLength"
label: qsTr("Moving range length")
- visible: cumulativeSumChartSdMethod.currentValue == "averageMovingRange"
+ visible: exponentiallyWeightedMovingAverageChartSdSource.currentValue == "data" & cumulativeSumChartSdMethod.currentValue == "averageMovingRange"
min: 2
defaultValue: 2
}
@@ -244,7 +244,7 @@ Form
DoubleField
{
name: "exponentiallyWeightedMovingAverageChartSigmaControlLimits"
- label: qsTr("Number of sigmas for control limits")
+ label: qsTr("Number of std. dev. for control limits")
defaultValue: 3
}
@@ -255,12 +255,6 @@ Form
defaultValue: 0.3
}
- DoubleField
- {
- name: "exponentiallyWeightedMovingAverageChartCenter"
- label: qsTr("Target of the mean")
- }
-
Group
{
DropDown
@@ -274,6 +268,23 @@ Form
{ label: qsTr("Historical"), value: "historical"}
]
}
+
+ DropDown
+ {
+ name: "exponentiallyWeightedMovingAverageChartSdMethod"
+ visible: exponentiallyWeightedMovingAverageChartSdSource.currentValue == "data"
+ label: qsTr("Std. dev. estimation method")
+ id: exponentiallyWeightedMovingAverageChartSdMethod
+ values: subgroupSizeType.value == "individual" ?
+ [
+ { label: qsTr("X-mR"), value: "averageMovingRange"}
+ ] :
+ [
+ { label: qsTr("S-bar"), value: "s"},
+ { label: qsTr("R-bar"), value: "r"}
+ ]
+ indexDefaultValue: subgroupSizeType.value == "individual" ? 0 : 1
+ }
DoubleField
{
@@ -283,19 +294,17 @@ Form
defaultValue: 3
fieldWidth: 50
}
-
- DropDown
+
+ IntegerField
{
- name: "exponentiallyWeightedMovingAverageChartSdMethod"
- visible: exponentiallyWeightedMovingAverageChartSdSource.currentValue == "data"
- label: qsTr("Std. dev. estimation method")
- id: exponentiallyWeightedMovingAverageChartSdMethod
- indexDefaultValue: 0
- values: [
- { label: qsTr("R-bar"), value: "r"},
- { label: qsTr("S-bar"), value: "s"}
- ]
+ name: "exponentiallyWeightedMovingAverageChartMovingRangeLength"
+ label: qsTr("Moving range length")
+ visible: exponentiallyWeightedMovingAverageChartSdSource.currentValue == "data" & exponentiallyWeightedMovingAverageChartSdMethod.currentValue == "averageMovingRange"
+ min: 2
+ defaultValue: 2
}
+
+
}
}
}
From e838718c0fc13c036b84d4d9db501753990c74ec Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 14 Aug 2024 16:46:46 +0200
Subject: [PATCH 04/25] GUI and r code start for rare event charts
---
NAMESPACE | 1 +
R/TimeWeightedCharts.R | 89 ---------------------
R/rareEventCharts.R | 92 ++++++++++++++++++++++
inst/qml/rareEventCharts.qml | 148 +++++++++++++++++++++++++++++++++--
4 files changed, 235 insertions(+), 95 deletions(-)
create mode 100644 R/rareEventCharts.R
diff --git a/NAMESPACE b/NAMESPACE
index a5e6edae..ccae865c 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -13,6 +13,7 @@ export(msaType1Gauge)
export(probabilityOfDetection)
export(processCapabilityStudies)
export(timeWeightedCharts)
+export(rareEventCharts)
export(variablesChartsIndividuals)
export(variablesChartsSubgroups)
importFrom(jaspBase,.extractErrorMessage)
diff --git a/R/TimeWeightedCharts.R b/R/TimeWeightedCharts.R
index 46f47828..2636f3db 100644
--- a/R/TimeWeightedCharts.R
+++ b/R/TimeWeightedCharts.R
@@ -150,92 +150,3 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
return(plot)
}
-.Gchart <- function(dataset, options, ready){
- if (!ready)
- return()
-
- data1 <- dataset[, options[["measurements"]]]
- subgroups <- c(1:length(data1))
- data_plot <- data.frame(x = subgroups, y = data1)
- center = mean(data1)
- UCL = center+3*sqrt(center*(center + 1))
- LCL = center-3*sqrt(center*(center + 1))
- LCL <- ifelse(LCL < 0 , 0, LCL)
- sixsigma <- list(statistics = data1, limits = data.frame(LCL, UCL), center = center)
- yBreaks <- jaspGraphs::getPrettyAxisBreaks(c(LCL, UCL, data_plot$y))
- yLimits <- range(yBreaks)
- if (length(subgroups) > 60)
- xBreaks <- c(1,jaspGraphs::getPrettyAxisBreaks(subgroups)[-1])
- else
- xBreaks <- c(subgroups)
- xLimits <- c(1,max(xBreaks) + 2.5)
- dfLabel <- data.frame(
- x = max(xLimits - 1),
- y = c(center, UCL, LCL),
- l = c(
- gettextf("CL = %g", round(center, 4)),
- gettextf("UCL = %g", round(UCL, 5)),
- gettextf("LCL = %g", round(LCL, 5))
- )
- )
-
- p <- ggplot2::ggplot(data_plot, ggplot2::aes(x = x, y = y)) +
- ggplot2::geom_line(ggplot2::aes(x = x, y = UCL, color = "red"),linetype = "dashed", size = 1.5) +
- ggplot2::geom_line(ggplot2::aes(x = x, y = LCL, color = "red"), linetype = "dashed", size = 1.5) +
- ggplot2::geom_hline(yintercept = center, color = 'green') +
- ggplot2::geom_label(data = dfLabel, mapping = ggplot2::aes(x = x, y = y, label = l),inherit.aes = FALSE, size = 4.5) +
- ggplot2::scale_y_continuous(name = gettext("Counts") ,limits = yLimits, breaks = yBreaks) +
- ggplot2::scale_x_continuous(name = gettext('Subgroup'), breaks = xBreaks, limits = range(xLimits)) +
- ggplot2::geom_line(color = "blue") +
- jaspGraphs::geom_point(size = 4, fill = ifelse(data_plot$y > UCL | data_plot$y < LCL, 'red', 'blue')) +
- jaspGraphs::geom_rangeframe() +
- jaspGraphs::themeJaspRaw()
-
- return(list(p = p, sixsigma = sixsigma))
-}
-.Tchart <- function(dataset, options){
- if (!ready)
- return()
-
- data1 <- dataset[, options[["measurements"]]]
- subgroups <- c(1:length(data1))
- data_plot <- data.frame(x = subgroups , y = data1^0.2777)
- data2 <- data.frame(process = data1)
- MR_T <- qcc::qcc(matrix(cbind(data2$process[1:length(data2$process)-1], data2$process[2:length(data2$process)]), ncol=2)
- , type="R", plot = FALSE)$statistics
- center = mean(data_plot$y)^3.6
- UCL = (mean(data_plot$y) + 2.66 * mean(MR_T))^3.6
- LCL = (mean(data_plot$y, na.rm = TRUE) - 2.66 * mean(MR_T, na.rm =))^3.6
- LCL <- ifelse(LCL < 0 , 0, LCL)
- sixsigma <- list(statistics = data1, limits = data.frame(LCL, UCL), center = center)
- yBreaks <- jaspGraphs::getPrettyAxisBreaks(c(LCL, UCL, data_plot$y))
- yLimits <- range(yBreaks)
- if (length(subgroups) > 60)
- xBreaks <- c(1,jaspGraphs::getPrettyAxisBreaks(subgroups)[-1])
- else
- xBreaks <- c(subgroups)
- xLimits <- c(1,max(xBreaks) + 2.5)
- dfLabel <- data.frame(
- x = max(xLimits - 1),
- y = c(center, UCL, LCL),
- l = c(
- gettextf("CL = %g", round(center, 4)),
- gettextf("UCL = %g", round(UCL, 5)),
- gettextf("LCL = %g", round(LCL, 5))
- )
- )
-
- p <- ggplot2::ggplot(data_plot, ggplot2::aes(x = x, y = y)) +
- ggplot2::geom_line(ggplot2::aes(x = x, y = UCL, color = "red"),linetype = "dashed", linewidth = 1.5) +
- ggplot2::geom_line(ggplot2::aes(x = x, y = LCL, color = "red"), linetype = "dashed", linewidth = 1.5) +
- ggplot2::geom_hline(yintercept = center, color = 'green') +
- ggplot2::geom_label(data = dfLabel, mapping = ggplot2::aes(x = x, y = y, label = l), inherit.aes = FALSE, size = 4.5) +
- ggplot2::scale_y_continuous(name = gettext("Counts") ,limits = yLimits, breaks = yBreaks) +
- ggplot2::scale_x_continuous(name = gettext('Subgroup'), breaks = xBreaks, limits = range(xLimits)) +
- ggplot2::geom_line(color = "blue") +
- jaspGraphs::geom_point(size = 4, fill = ifelse(data_plot$y > UCL | data_plot$y < LCL, 'red', 'blue')) +
- jaspGraphs::geom_rangeframe() +
- jaspGraphs::themeJaspRaw()
-
- return(list(p = p, sixsigma = sixsigma))
-}
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
new file mode 100644
index 00000000..cc12c803
--- /dev/null
+++ b/R/rareEventCharts.R
@@ -0,0 +1,92 @@
+#
+# 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
+rareEventCharts <- function(jaspResults, dataset, options) {
+ # reading variables in from the GUI
+ variable <- unlist(options[["variable"]])
+ stages <- unlist(options[["stage"]])
+ variable <- variable[variable != ""]
+ stages <- stages[stages != ""]
+ factorVariables <- c(variable, stages)
+ ready <- length(variable) == 1
+
+
+
+ if (is.null(dataset)) {
+ dataset <- .readDataSetToEnd(columns.as.factor = factorVariables)
+ }
+
+
+ # Checking for errors in the dataset
+ .hasErrors(dataset, type = c('infinity'),
+ infinity.target = c(options$variable),
+ exitAnalysisIfErrors = TRUE)
+
+
+ # If variable is data/time transform into same format
+
+
+ # Transform variable to intervals between events
+
+
+
+ # G chart
+ if (options[["gChart"]] && is.null(jaspResults[["gChart"]])) {
+ jaspResults[["gChart"]] <- .gChart(intervals, stages, intervalType, options, ready)
+ }
+
+ # T chart
+ if (options[["tChart"]] && is.null(jaspResults[["tChart"]])) {
+ jaspResults[["tChart"]] <- .tChart(intervals, stages, intervalType, options, ready)
+ }
+}
+
+
+.gChart <- function(intervals, stages, intervalType, options, ready) {
+ plot <- createJaspPlot(title = gettext("G chart"), width = 1200, height = 500)
+ plot$dependOn(c(""))
+
+ if (!ready)
+ return(plot)
+
+ plotObject <- .rareEventPlottingFunction()
+ plot$plotObject <- plotObject
+
+ return(plot)
+
+}
+
+.tChart <- function(intervals, stages, intervalType, options, ready) {
+ plot <- createJaspPlot(title = gettext("T chart"), width = 1200, height = 500)
+ plot$dependOn(c(""))
+
+ if (!ready)
+ return(plot)
+
+ plotObject <- .rareEventPlottingFunction()
+ plot$plotObject <- plotObject
+
+ return(plot)
+}
+
+.rareEventPlottingFunction <- function(intervals,
+ intervalType = c("days", "hours", "minutes", "opportunities"),
+ chartType = c("g", "t"),
+ tChartDistribution = c("weibull", "exponential")) {
+
+}
diff --git a/inst/qml/rareEventCharts.qml b/inst/qml/rareEventCharts.qml
index fbae82a6..5906437d 100644
--- a/inst/qml/rareEventCharts.qml
+++ b/inst/qml/rareEventCharts.qml
@@ -17,12 +17,75 @@ Form
AssignedVariablesList
{
- name: "variables"
- title: qsTr("Variables")
+ name: "variable"
+ title: qsTr("Variable")
id: variable
- allowedColumns: ["scale"]
- singleVariable: false
+ allowedColumns: ["nominal"]
+ singleVariable: true
}
+
+ AssignedVariablesList
+ {
+ name: "stage"
+ title: qsTr("Stage")
+ id: stages
+ allowedColumns: ["nominal"]
+ singleVariable: true
+ }
+ }
+
+ RadioButtonGroup
+ {
+ name: "dataType"
+ title: qsTr("Data type")
+ id: dataType
+
+ RadioButton
+ {
+ value: "dataTypeDates"
+ label: qsTr("Date/time")
+ checked: true
+
+ TextField
+ {
+ name: "dataTypeDatesFormat"
+ label: qsTr("Format")
+ defaultValue: "dd/mm/yy hh:mm"
+ fieldWidth: 100
+ }
+ }
+
+ RadioButton
+ {
+ value: "dataTypeInterval"
+ label: qsTr("Interval between events")
+ childrenOnSameRow: false
+
+ DropDown
+ {
+ name: "dataTypeIntervalType"
+ id: dataTypeIntervalType
+ label: qsTr("Interval type")
+ values:
+ [
+ { label: qsTr("Opportunities"), value: "dataTypeIntervalTypeOpportunities"},
+ { label: qsTr("Time"), value: "dataTypeIntervalTypeTime"},
+ { label: qsTr("Hours (decimal)"), value: "dataTypeIntervalTypeHours"},
+ { label: qsTr("Days (decimal)"), value: "dataTypeIntervalTypeDays"}
+ ]
+ indexDefaultValue: 0
+ }
+
+ TextField
+ {
+ name: "dataTypeIntervalTimeFormat"
+ label: qsTr("Format")
+ defaultValue: "hh:mm"
+ visible: dataTypeIntervalType.value == "dataTypeIntervalTypeTime"
+ fieldWidth: 50
+ }
+ }
+
}
Group
@@ -30,15 +93,88 @@ Form
CheckBox
{
name: "gChart"
- label: qsTr("g chart")
+ label: qsTr("G chart")
checked: true
+
+ DropDown
+ {
+ name: "gChartProportionSource"
+ id: gChartProportionSource
+ label: qsTr("Proportion")
+ values:
+ [
+ { label: qsTr("Estimated from data"), value: "gChartProportionSourceData"},
+ { label: qsTr("Historical"), value: "gChartProportionSourceHistorical"}
+ ]
+ indexDefaultValue: 0
+ }
+
+ DoubleField
+ {
+ name: "gChartHistoricalProportion"
+ id: gChartHistoricalProportion
+ label: qsTr("Proportion value")
+ min: 0
+ max: 1
+ visible: gChartProportionSource.value == "gChartProportionSourceHistorical"
+ defaultValue: 0.5
+ }
}
CheckBox
{
name: "tChart"
- label: qsTr("t chart")
+ label: qsTr("T chart")
checked: true
+
+ DropDown
+ {
+ name: "tChartDistribution"
+ id: tChartDistribution
+ label: qsTr("Based on")
+ values:
+ [
+ { label: qsTr("Weibull distribution"), value: "tChartDistributionWeibull"},
+ { label: qsTr("Exponential distribution"), value: "tChartDistributionExponential"}
+ ]
+ indexDefaultValue: 0
+ }
+
+ DropDown
+ {
+ name: "tChartDistributionParameterSource"
+ id: tChartDistributionParameterSource
+ label: qsTr("Distribution parameters")
+ values:
+ [
+ { label: qsTr("Estimated from data"), value: "tChartDistributionParameterSourceData"},
+ { label: qsTr("Historical"), value: "tChartDistributionParameterSourceHistorical"}
+ ]
+ indexDefaultValue: 0
+ }
+
+ DoubleField
+ {
+ name: "tChartHistoricalParametersWeibullShape"
+ id: tChartHistoricalParametersWeibullShape
+ label: qsTr("Shape")
+ min: 0
+ inclusive: JASP.None
+ visible: tChartDistributionParameterSource.value == "tChartDistributionParameterSourceHistorical" & tChartDistribution.value == "tChartDistributionWeibull"
+ defaultValue: 2
+ }
+
+
+ DoubleField
+ {
+ name: "tChartHistoricalParametersScale"
+ id: tChartHistoricalParametersScale
+ label: qsTr("Scale")
+ min: 0
+ inclusive: JASP.None
+ visible: tChartDistributionParameterSource.value == "tChartDistributionParameterSourceHistorical"
+ defaultValue: 2
+ }
}
}
}
From f6f9ecad5d4763e744b4ac596628a565c8dccbc7 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Fri, 16 Aug 2024 16:55:56 +0200
Subject: [PATCH 05/25] Date and time format processing
---
DESCRIPTION | 1 +
R/rareEventCharts.R | 126 +++++++++++++++++++++++++++++++----
inst/qml/rareEventCharts.qml | 71 +++++++++++++++++---
3 files changed, 175 insertions(+), 23 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index c290bf5f..253494d8 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -27,6 +27,7 @@ Imports:
jaspBase,
jaspDescriptives,
jaspGraphs,
+ lubridate,
mle.tools,
psych,
qcc,
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index cc12c803..be95ba3e 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -38,12 +38,100 @@ rareEventCharts <- function(jaspResults, dataset, options) {
exitAnalysisIfErrors = TRUE)
- # If variable is data/time transform into same format
-
-
- # Transform variable to intervals between events
-
-
+ #
+ # ### TESTING #####
+ # # date and time
+ # timepoints <- c("01.04.2024, 9:11", "04.04.2024, 11:11", "09.04.2024, 3:11", "15.04.2024, 18:11", "30.04.2024, 1:11")
+ # dataset <- list()
+ # dataset[["variable"]] <- timepoints
+ # options <- list()
+ # options[["dataType"]] <- "dataTypeDates"
+ # options[["dataTypeDatesStructure"]] <- "dateTime"
+ # options[["dataTypeDatesFormatDate"]] <- "dmy"
+ # options[["dataTypeDatesFormatTime"]] <- "HM"
+ # # time and date
+ # timepoints <- c("9:11 01.04.2024", "11:11 04.04.2024", "3:11 09.04.2024", " 18:11: 15.04.2024", " 1:11 30.04.2024")
+ # dataset <- list()
+ # dataset[["variable"]] <- timepoints
+ # options <- list()
+ # options[["dataType"]] <- "dataTypeDates"
+ # options[["dataTypeDatesStructure"]] <- "timeDate"
+ # options[["dataTypeDatesFormatDate"]] <- "dmy"
+ # options[["dataTypeDatesFormatTime"]] <- "HM"
+ # # date only
+ # timepoints <- c("01.04.2024", "04.04.2024", "09.04.2024", "15.04.2024", " 30.04.2024")
+ # dataset <- list()
+ # dataset[["variable"]] <- timepoints
+ # options <- list()
+ # options[["dataType"]] <- "dataTypeDates"
+ # options[["dataTypeDatesStructure"]] <- "dateOnly"
+ # options[["dataTypeDatesFormatDate"]] <- "dmy"
+ # options[["dataTypeDatesFormatTime"]] <- "HM"
+ # # time only
+ # timepoints <- c("1:32", "3:24", "5:17", "9:22", "12:21")
+ # dataset <- list()
+ # dataset[["variable"]] <- timepoints
+ # options <- list()
+ # options[["dataType"]] <- "dataTypeDates"
+ # options[["dataTypeDatesStructure"]] <- "timeOnly"
+ # options[["dataTypeDatesFormatDate"]] <- "dmy"
+ # options[["dataTypeDatesFormatTime"]] <- "HM"
+ # ###########################
+ if (ready) {
+ # If variable is date/time transform into day, hour and minute intervals
+ if (options[["dataType"]] == "dataTypeDates") {
+ timepoints <- dataset[[variable]]
+ timeStructure <- options[["dataTypeDatesStructure"]]
+ timeFormat <- switch(timeStructure,
+ "dateTime" = paste(options[["dataTypeDatesFormatDate"]], options[["dataTypeDatesFormatTime"]]),
+ "timeDate" = paste(options[["dataTypeDatesFormatTime"]], options[["dataTypeDatesFormatDate"]]),
+ "dateOnly" = options[["dataTypeDatesFormatDate"]],
+ "timeOnly" = options[["dataTypeDatesFormatTime"]])
+ print("debug2")
+ print(timepoints)
+ print(timeFormat)
+ timepoints <- lubridate::parse_date_time(timepoints, orders = timeFormat) # returns all data in DMY HMS format
+ print("debug1")
+ print(timepoints)
+ print(seq(1, length(timepoints) - 1))
+ timepointsLag1 <- c(NA, timepoints[seq(1, length(timepoints) - 1)]) # because of the NA, everything is converted to seconds
+ intervalsMinutes <- as.numeric(timepoints - timepointsLag1)/60
+ intervalsHours <- intervalsMinutes/60
+ intervalsDays <- intervalsHours/24
+ } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "dataTypeIntervalTypeTime") {
+ timepoints <- dataset[[variable]]
+ timeFormat <- options[["dataTypeIntervalTimeFormat"]]
+ timepoints <- lubridate::parse_date_time(timepoints, orders = timeFormat) # returns all data in HMS format
+ intervalsMinutes <- as.numeric(timepoints - lubridate::as_datetime("0000-01-01 UTC")) # transform to minutes
+ intervalsHours <- intervalsMinutes/60
+ }
+
+ # Get the interval type, depending on the input type and, if applicable, the calculated intervals
+ if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalTypeOpportunities"]]) {
+ intervals <- dataset[[variable]]
+ intervalType <- "opportunities"
+ } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalTypeHours"]]) {
+ intervals <- dataset[[variable]]
+ intervalType <- "hours"
+ } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalTypeDays"]]) {
+ intervals <- dataset[[variable]]
+ intervalType <- "days"
+ } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalTypeTime"]]) {
+ intervals <- if(all(intervalsHours < 1, na.rm = TRUE) ) intervalsMinutes else intervalsHours
+ intervalType <- if(all(intervalsHours < 1, na.rm = TRUE)) "minutes" else "hours"
+ } else if (options[["dataType"]] == "dataTypeDates") {
+ if (all(intervalsDays < 1, na.rm = TRUE) && all(intervalsHours < 1, na.rm = TRUE)) {
+ intervals <- intervalsMinutes
+ intervalType <- "minutes"
+ } else if (all(intervalsDays < 1, na.rm = TRUE)) {
+ intervals <- intervalsHours
+ intervalType <- "hours"
+ } else {
+ intervals <- intervalsDays
+ intervalType <- "days"
+ }
+ }
+ }
# G chart
if (options[["gChart"]] && is.null(jaspResults[["gChart"]])) {
@@ -57,36 +145,50 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
-.gChart <- function(intervals, stages, intervalType, options, ready) {
+.gChart <- function(intervals,
+ stages = NULL,
+ intervalType = c("days", "hours", "minutes", "opportunities"),
+ options, ready) {
plot <- createJaspPlot(title = gettext("G chart"), width = 1200, height = 500)
plot$dependOn(c(""))
if (!ready)
return(plot)
- plotObject <- .rareEventPlottingFunction()
+ plotObject <- .rareEventPlottingFunction(intervals = intervals,
+ stages = stages,
+ intervalType = intervalType,
+ chartType = "g")
plot$plotObject <- plotObject
return(plot)
-
}
-.tChart <- function(intervals, stages, intervalType, options, ready) {
+.tChart <- function(intervals,
+ stages = NULL,
+ intervalType = c("days", "hours", "minutes", "opportunities"),
+ options, ready) {
plot <- createJaspPlot(title = gettext("T chart"), width = 1200, height = 500)
plot$dependOn(c(""))
- if (!ready)
+ if (!ready)
return(plot)
- plotObject <- .rareEventPlottingFunction()
+ plotObject <- .rareEventPlottingFunction(intervals = intervals,
+ stages = stages,
+ intervalType = intervalType,
+ chartType = "t",
+ tChartDistribution = options[["tChartDistribution"]])
plot$plotObject <- plotObject
return(plot)
}
.rareEventPlottingFunction <- function(intervals,
+ stages = NULL,
intervalType = c("days", "hours", "minutes", "opportunities"),
chartType = c("g", "t"),
tChartDistribution = c("weibull", "exponential")) {
}
+
diff --git a/inst/qml/rareEventCharts.qml b/inst/qml/rareEventCharts.qml
index 5906437d..34906ac0 100644
--- a/inst/qml/rareEventCharts.qml
+++ b/inst/qml/rareEventCharts.qml
@@ -46,12 +46,53 @@ Form
label: qsTr("Date/time")
checked: true
- TextField
+ DropDown
+ {
+ name: "dataTypeDatesStructure"
+ id: dataTypeDatesStructure
+ label: qsTr("Structure")
+ values:
+ [
+ { label: qsTr("Date + Time"), value: "dateTime"},
+ { label: qsTr("Time + Date"), value: "timeDate"},
+ { label: qsTr("Date only"), value: "dateOnly"},
+ { label: qsTr("Time only"), value: "timeOnly"}
+ ]
+ indexDefaultValue: 0
+ }
+
+ DropDown
+ {
+ name: "dataTypeDatesFormatDate"
+ id: dataTypeDatesFormatDate
+ label: qsTr("Date format")
+ visible: dataTypeDatesStructure.value != "timeOnly"
+ values:
+ [
+ { label: qsTr("DMY"), value: "dmy"},
+ { label: qsTr("MDY"), value: "mdy"},
+ { label: qsTr("YMD"), value: "ymd"},
+ { label: qsTr("DM"), value: "dm"},
+ { label: qsTr("MD"), value: "md"}
+ ]
+ indexDefaultValue: 0
+ }
+
+ DropDown
{
- name: "dataTypeDatesFormat"
- label: qsTr("Format")
- defaultValue: "dd/mm/yy hh:mm"
- fieldWidth: 100
+ name: "dataTypeDatesFormatTime"
+ id: dataTypeDatesFormatTime
+ label: qsTr("Time format")
+ visible: dataTypeDatesStructure.value != "dateOnly"
+ values:
+ [
+ { label: qsTr("H"), value: "H"},
+ { label: qsTr("HM"), value: "HM"},
+ { label: qsTr("HMS"), value: "HMS"},
+ { label: qsTr("Ip"), value: "Ip"},
+ { label: qsTr("IMp"), value: "IMp"}
+ ]
+ indexDefaultValue: 1
}
}
@@ -76,13 +117,21 @@ Form
indexDefaultValue: 0
}
- TextField
+ DropDown
{
- name: "dataTypeIntervalTimeFormat"
- label: qsTr("Format")
- defaultValue: "hh:mm"
- visible: dataTypeIntervalType.value == "dataTypeIntervalTypeTime"
- fieldWidth: 50
+ name: "dataTypeIntervalTimeFormat"
+ id: dataTypeIntervalTimeFormat
+ label: qsTr("Time format")
+ visible: dataTypeIntervalType.value == "dataTypeIntervalTypeTime"
+ values:
+ [
+ { label: qsTr("H"), value: "H"},
+ { label: qsTr("HM"), value: "HM"},
+ { label: qsTr("HMS"), value: "HMS"},
+ { label: qsTr("Ip"), value: "Ip"},
+ { label: qsTr("IMp"), value: "IMp"}
+ ]
+ indexDefaultValue: 1
}
}
From b26a2aad8c3de763395f980042682c218873ccbe Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Mon, 19 Aug 2024 18:39:54 +0200
Subject: [PATCH 06/25] g chart functionality
---
R/commonQualityControl.R | 125 ++++++++++++++++++++++++++++++---------
R/rareEventCharts.R | 71 +++++++++++++---------
2 files changed, 140 insertions(+), 56 deletions(-)
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index 3a6738a1..fd081489 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -393,7 +393,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
return(list(LCL = LCLvector, UCL = UCLvector))
}
-.controlChart <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma"),
+.controlChart <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma", "g", "t"),
stages = "",
xBarSdType = c("r", "s"),
nSigmasControlLimits = 3,
@@ -412,7 +412,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
unbiasingConstantUsed = TRUE,
cusumShiftSize = 0.5,
cusumTarget = 0,
- ewmaLambda = 0.3
+ ewmaLambda = 0.3,
+ gAndtUnit = c("days", "hours", "minutes", "opportunities"),
+ tChartDistribution = c("weibull", "exponential")
) {
plotType <- match.arg(plotType)
@@ -422,7 +424,8 @@ KnownControlStats.RS <- function(N, sigma = 3) {
phase2Mu = phase2Mu, phase2Sd = phase2Sd, fixedSubgroupSize = fixedSubgroupSize,
warningLimits = warningLimits, movingRangeLength = movingRangeLength,
stagesSeparateCalculation = stagesSeparateCalculation, unbiasingConstantUsed = unbiasingConstantUsed,
- cusumShiftSize = cusumShiftSize, cusumTarget = cusumTarget, ewmaLambda = ewmaLambda)
+ cusumShiftSize = cusumShiftSize, cusumTarget = cusumTarget, ewmaLambda = ewmaLambda,
+ tChartDistribution = tChartDistribution)
# This function turns the point violation list into a JASP table
@@ -434,13 +437,13 @@ KnownControlStats.RS <- function(N, sigma = 3) {
stageLabels = controlChartData$stageLabels, clLabels = controlChartData$clLabels,
plotType = plotType, stages = stages, phase2 = phase2, warningLimits = warningLimits,
xAxisLabels = xAxisLabels, xAxisTitle = xAxisTitle, clLabelSize = clLabelSize,
- specificationLimits = specificationLimits)
+ specificationLimits = specificationLimits, gAndtUnit = gAndtUnit)
return(list(plotObject = plotObject, table = table, controlChartData = controlChartData))
}
-.controlChart_calculations <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma"),
+.controlChart_calculations <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma", "g", "t"),
stages = "",
xBarSdType = c("r", "s"),
nSigmasControlLimits = 3,
@@ -454,7 +457,8 @@ KnownControlStats.RS <- function(N, sigma = 3) {
unbiasingConstantUsed = TRUE,
cusumShiftSize = 0.5,
cusumTarget = 0,
- ewmaLambda = 0.3
+ ewmaLambda = 0.3,
+ tChartDistribution = c("weibull", "exponential")
) {
plotType <- match.arg(plotType)
if (identical(stages, "")) {
@@ -580,7 +584,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
### Calculations for S chart
###
} else if (plotType == "s") {
- if(phase2) {
+ if (phase2) {
sigma <- phase2Sd
} else if (stagesSeparateCalculation) {
sigma <- .sdXbar(df = dataCurrentStage, type = "s", unbiasingConstantUsed = unbiasingConstantUsed)
@@ -654,6 +658,23 @@ KnownControlStats.RS <- function(N, sigma = 3) {
individualPointSigmas <- .ewmaPointSigmas(n = n, sigma = sigma, lambda = ewmaLambda)
UCL <- center + individualPointSigmas * nSigmasControlLimits
LCL <- center - individualPointSigmas * nSigmasControlLimits
+ ###
+ ### Calculations for g chart
+ ###
+ } else if (plotType == "g") {
+ plotStatistic <- unname(unlist(dataCurrentStage))
+ gChartStatistics <- .gChartStatistics(intervals = plotStatistic)
+ center <- gChartStatistics$CL
+ UCL <- gChartStatistics$UCL
+ LCL <- gChartStatistics$LCL
+ p <- gChartStatistics$p
+ ###
+ ### Calculations for t chart
+ ###
+ } else if (plotType == "t") {
+
+
+
}
if (i != 1) {
if (plotType == "cusum") {
@@ -681,7 +702,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
if (length(na.omit(plotStatistic)) > 1) {
if (plotType == "MR" || plotType == "MMR") {
dotColor <- ifelse(c(rep(NA, k-1), NelsonLaws(qccObject)$red_points), 'red', 'blue')
- } else if (plotType == "cusum" || plotType == "ewma") {
+ } else if (plotType == "cusum" || plotType == "ewma" || plotType == "g" || plotType == "t") {
dotColor <- ifelse(plotStatistic > UCL | plotStatistic < LCL, "red", "blue")
dotColor[is.na(dotColor)] <- "blue"
} else {
@@ -747,7 +768,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
tableLabelsCurrentStage <- subgroups
if (plotType == "MR" || plotType == "MMR")
tableLabelsCurrentStage <- tableLabelsCurrentStage[-seq(1, k-1)]
- if (plotType == "cusum" || plotType == "ewma") {
+ if (plotType == "cusum" || plotType == "ewma" || plotType == "g" || plotType == "t") {
tableList[[i]] <- c() # pass empty vector for now, until Nelson Laws are updated and can handle other input than QCC objects
} else {
tableList[[i]] <- .NelsonTableList(qccObject = qccObject, type = plotType, labels = tableLabelsCurrentStage)
@@ -768,7 +789,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
.controlChart_table <- function(tableList,
- plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma"),
+ plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma", "g", "t"),
stages = "",
tableLabels = "") {
plotType <- match.arg(plotType)
@@ -780,7 +801,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
"MMR" = "moving range",
"s" = "s",
"cusum" = "cumulative sum",
- "ewma" = "Exponentially weighted moving average"
+ "ewma" = "exponentially weighted moving average",
+ "g" = "g",
+ "t" = "t"
)
table <- createJaspTable(title = gettextf("Test results for %1$s chart", tableTitle))
table$showSpecifiedColumnsOnly <- TRUE
@@ -840,14 +863,15 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
.controlChart_plotting <- function(pointData, clData, stageLabels, clLabels,
- plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma"),
- stages = "",
- phase2 = FALSE,
- warningLimits = FALSE,
+ plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma", "g", "t"),
+ stages = "",
+ phase2 = FALSE,
+ warningLimits = FALSE,
specificationLimits = NA,
- xAxisLabels = "",
- xAxisTitle = "",
- clLabelSize = 4.5) {
+ xAxisLabels = "",
+ xAxisTitle = "",
+ clLabelSize = 4.5,
+ gAndtUnit = c("days", "hours", "minutes", "opportunities")) {
plotType <- match.arg(plotType)
yBreakDeterminants <- c(pointData$plotStatistic, clData$LCL, clData$UCL, clData$center)
# if all statistics are 0, pretty will select c(-1, 0). But c(0, 1) is better
@@ -866,15 +890,20 @@ KnownControlStats.RS <- function(N, sigma = 3) {
xLabels <- xBreaks
}
- yTitle <- switch (plotType,
- "xBar" = "Sample average",
- "R" = "Sample range",
- "I" = "Individual value",
- "MR" = "Moving range",
- "MMR" = "Moving range of subgroup mean",
- "s" = "Sample std. dev.",
- "cusum" = "Cumulative sum",
- "ewma" = "Exponentially weighted moving average")
+ if (plotType == "g" || plotType == "t") {
+ unitString <- paste0(toupper(substr(gAndtUnit, 1, 1)), substr(gAndtUnit, 2, nchar(gAndtUnit)))
+ yTitle <- gettextf("%1$s between events", unitString)
+ } else {
+ yTitle <- switch (plotType,
+ "xBar" = "Sample average",
+ "R" = "Sample range",
+ "I" = "Individual value",
+ "MR" = "Moving range",
+ "MMR" = "Moving range of subgroup mean",
+ "s" = "Sample std. dev.",
+ "cusum" = "Cumulative sum",
+ "ewma" = "Exponentially weighted moving average")
+ }
lineType <- if (phase2) "solid" else "dashed"
# Create plot
plotObject <- ggplot2::ggplot(clData, ggplot2::aes(x = subgroup, group = stage)) +
@@ -945,7 +974,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
for (stage_i in unique(pointData[["stage"]])) {
pointDataSubset <- subset.data.frame(pointData, pointData$stage == stage_i)
if (length(pointDataSubset$subgroup) %% 2 != 0)
- stop("Data provided to cusum plot function is not symmetric, i.e. unequal amount of points above and below 0.")
+ stop("Data provided to cusum plot function is not symmetric, i.e., unequal amount of points above and below 0.")
nSubgroupsStage <- length(pointDataSubset$subgroup)/2 # the data should always be symmetrical, hence we can divide by two
firstHalf <- seq(1, nSubgroupsStage)
secondHalf <- firstHalf + nSubgroupsStage
@@ -1047,3 +1076,43 @@ return(ewmaPoints)
}
return(ewmaPointSigmas)
}
+
+.gChartStatistics <- function(intervals) {
+ intervalsMean <- mean(intervals, na.rm = TRUE)
+ n <- sum(!is.na(intervals))
+ p <- ((n - 1) / n) / (intervalsMean + 1)
+
+ # calculate CL
+ p2a <- pgeom(qgeom(0.5, prob = p) - 1, prob = p, lower.tail = T) # p2a is the CDF at G2a
+ p2b <- pgeom(qgeom(0.5, prob = p), prob = p, lower.tail = T) # p2b is the CDF at G2b
+ # Find G2a and G2b
+ G2a <- qgeom(p2a, prob = p) + 1 # Add 1 to get trials count
+ G2b <- G2a + 1 # Since G2b = G2a + 1
+ # Perform linear interpolation to find G2
+ G2 <- G2a + (0.5 - p2a) / (p2b - p2a)
+ # Calculate CL = G2 - 1
+ CL <- G2 - 1
+
+ # calculate LCL
+ p1a <- pgeom(qgeom(0.99865, prob = p, lower.tail = F) - 1, prob = p, lower.tail = T)
+ p1b <- pgeom(qgeom(0.99865, prob = p, lower.tail = F), prob = p, lower.tail = T)
+ # Find G2a and G2b
+ G1a <- qgeom(p1a, prob = p) + 1
+ G1b <- G1a + 1
+ # Perform linear interpolation to find G1
+ G1 <- G1a + (0.00135 - p1a) / (p1b - p1a)
+ LCL <- G1 - 1
+ LCL <- max(0, LCL)
+
+ # calculate UCL
+ p3a <- pgeom(qgeom(0.00135, prob = p, lower.tail = F) - 1, prob = p, lower.tail = T) # p2a is the CDF at G2a
+ p3b <- pgeom(qgeom(0.00135, prob = p, lower.tail = F), prob = p, lower.tail = T) # p2b is the CDF at G2b
+ # Find G2a and G2b
+ G3a <- qgeom(p3a, prob = p) + 1 # Add 1 to get trials count
+ G3b <- G3a + 1 # Since G2b = G2a + 1
+ # Perform linear interpolation to find G2
+ G3 <- G3a + (0.99865 - p3a) / (p3b - p3a)
+ UCL <- G3 - 1
+
+ return(list(p = p, CL = CL, UCL = UCL, LCL = LCL))
+}
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index be95ba3e..1c785a71 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -77,6 +77,18 @@ rareEventCharts <- function(jaspResults, dataset, options) {
# options[["dataTypeDatesFormatDate"]] <- "dmy"
# options[["dataTypeDatesFormatTime"]] <- "HM"
# ###########################
+
+#
+# # reproduce example
+# dataset <- read.csv("c:/Users/Jonee/Desktop/Temporary Files/specialControlCharts/gchart.csv")
+# options <- list()
+# variable <- "Date.of.infection"
+# options[["dataType"]] <- "dataTypeDates"
+# options[["dataTypeDatesStructure"]] <- "dateOnly"
+# options[["dataTypeDatesFormatDate"]] <- "md"
+#
+
+
if (ready) {
# If variable is date/time transform into day, hour and minute intervals
if (options[["dataType"]] == "dataTypeDates") {
@@ -87,13 +99,6 @@ rareEventCharts <- function(jaspResults, dataset, options) {
"timeDate" = paste(options[["dataTypeDatesFormatTime"]], options[["dataTypeDatesFormatDate"]]),
"dateOnly" = options[["dataTypeDatesFormatDate"]],
"timeOnly" = options[["dataTypeDatesFormatTime"]])
- print("debug2")
- print(timepoints)
- print(timeFormat)
- timepoints <- lubridate::parse_date_time(timepoints, orders = timeFormat) # returns all data in DMY HMS format
- print("debug1")
- print(timepoints)
- print(seq(1, length(timepoints) - 1))
timepointsLag1 <- c(NA, timepoints[seq(1, length(timepoints) - 1)]) # because of the NA, everything is converted to seconds
intervalsMinutes <- as.numeric(timepoints - timepointsLag1)/60
intervalsHours <- intervalsMinutes/60
@@ -133,19 +138,28 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
}
+ if (!identical(stages, "")) {
+ dataset <- data.frame(x1 = intervals, x2 = dataset[[stages]])
+ colnames(dataset) <- c(variable, stages)
+ } else {
+ dataset <- data.frame(x1 = intervals)
+ colnames(dataset) <- variable
+ }
+
# G chart
if (options[["gChart"]] && is.null(jaspResults[["gChart"]])) {
- jaspResults[["gChart"]] <- .gChart(intervals, stages, intervalType, options, ready)
+ jaspResults[["gChart"]] <- .gChart(dataset, variable, stages, intervalType, options, ready)
}
# T chart
if (options[["tChart"]] && is.null(jaspResults[["tChart"]])) {
- jaspResults[["tChart"]] <- .tChart(intervals, stages, intervalType, options, ready)
+ jaspResults[["tChart"]] <- .tChart(dataset, variable, stages, intervalType, options, ready)
}
}
-.gChart <- function(intervals,
+.gChart <- function(dataset,
+ variable,
stages = NULL,
intervalType = c("days", "hours", "minutes", "opportunities"),
options, ready) {
@@ -155,16 +169,16 @@ rareEventCharts <- function(jaspResults, dataset, options) {
if (!ready)
return(plot)
- plotObject <- .rareEventPlottingFunction(intervals = intervals,
- stages = stages,
- intervalType = intervalType,
- chartType = "g")
+ columnsToPass <- c(variable, stages)
+ columnsToPass <- columnsToPass[columnsToPass != ""]
+ plotObject <- .controlChart(dataset[columnsToPass], plotType = "g", stages = stages, gAndtUnit = intervalType)$plotObject
plot$plotObject <- plotObject
return(plot)
}
-.tChart <- function(intervals,
+.tChart <- function(dataset,
+ variable,
stages = NULL,
intervalType = c("days", "hours", "minutes", "opportunities"),
options, ready) {
@@ -173,22 +187,23 @@ rareEventCharts <- function(jaspResults, dataset, options) {
if (!ready)
return(plot)
-
- plotObject <- .rareEventPlottingFunction(intervals = intervals,
- stages = stages,
- intervalType = intervalType,
- chartType = "t",
- tChartDistribution = options[["tChartDistribution"]])
+#
+# plotObject <- .rareEventPlottingFunction(intervals = intervals,
+# stages = stages,
+# intervalType = intervalType,
+# chartType = "t",
+# tChartDistribution = options[["tChartDistribution"]])
plot$plotObject <- plotObject
return(plot)
}
-.rareEventPlottingFunction <- function(intervals,
- stages = NULL,
- intervalType = c("days", "hours", "minutes", "opportunities"),
- chartType = c("g", "t"),
- tChartDistribution = c("weibull", "exponential")) {
-
-}
+# .rareEventPlottingFunction <- function(intervals,
+# stages = NULL,
+# intervalType = c("days", "hours", "minutes", "opportunities"),
+# chartType = c("g", "t"),
+# tChartDistribution = c("weibull", "exponential")) {
+#
+#
+# }
From a3fe87b58ec694a047e550442c6826b46361f59f Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 21 Aug 2024 16:08:11 +0200
Subject: [PATCH 07/25] t chart functionality
---
R/commonQualityControl.R | 55 ++++++++++++++++++++++--
R/processCapabilityStudies.R | 37 +---------------
R/rareEventCharts.R | 83 ++++++++++++++++++++----------------
inst/qml/rareEventCharts.qml | 14 +++---
4 files changed, 107 insertions(+), 82 deletions(-)
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index fd081489..f99c95ef 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -672,9 +672,21 @@ KnownControlStats.RS <- function(N, sigma = 3) {
### Calculations for t chart
###
} else if (plotType == "t") {
-
-
-
+ plotStatistic <- unname(unlist(dataCurrentStage))
+ if (tChartDistribution == "weibull") {
+ weibullPars <- fitdistrplus::fitdist(plotStatistic[!is.na(plotStatistic)], "weibull", method = "mle",
+ control = list(maxit = 500, abstol = .Machine$double.eps, reltol = .Machine$double.eps))
+ shape <- unname(weibullPars[[1]][1])
+ scale <- unname(weibullPars[[1]][2])
+ } else if (tChartDistribution == "exponential") {
+ exponentialPars <- fitdistrplus::fitdist(plotStatistic[!is.na(plotStatistic)], "weibull", method = "mle", fix.arg = list("shape" = 1),
+ control = list(maxit = 500, abstol = .Machine$double.eps, reltol = .Machine$double.eps))
+ shape <- 1
+ scale <- unname(exponentialPars[[1]][1])
+ }
+ center <- qweibull(p = .5, shape = shape, scale = scale)
+ UCL <- qweibull(p = pnorm(3), shape = shape, scale = scale)
+ LCL <- qweibull(p = pnorm(-3), shape = shape, scale = scale)
}
if (i != 1) {
if (plotType == "cusum") {
@@ -1116,3 +1128,40 @@ return(ewmaPoints)
return(list(p = p, CL = CL, UCL = UCL, LCL = LCL))
}
+
+.distributionParameters <- function(data, distribution = c("lognormal", "weibull", "3ParameterLognormal", "3ParameterWeibull")){
+ if (distribution == "lognormal") {
+ fit_Lnorm <- try(EnvStats::elnorm(data))
+ if (jaspBase::isTryError(fit_Lnorm))
+ stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
+ beta <- fit_Lnorm$parameters[1]
+ theta <- fit_Lnorm$parameters[2]
+ } else if (distribution == "weibull") {
+ fit_Weibull <- try(fitdistrplus::fitdist(data, "weibull", method = "mle",
+ control = list(maxit = 500, abstol = .Machine$double.eps, reltol = .Machine$double.eps)))
+ if (jaspBase::isTryError(fit_Weibull))
+ stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
+ beta <- fit_Weibull$estimate[[1]]
+ theta <- fit_Weibull$estimate[[2]]
+ } else if(distribution == "3ParameterLognormal") {
+ temp <- try(EnvStats::elnorm3(data))
+ if (jaspBase::isTryError(temp))
+ stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
+ beta <- temp$parameters[[1]]
+ theta <- temp$parameters[[2]]
+ threshold <- temp$parameters[[3]]
+ } else if(distribution == "3ParameterWeibull") {
+ temp <- try(MASS::fitdistr(data, function(x, shape, scale, thres)
+ dweibull(x-thres, shape, scale), list(shape = 0.1, scale = 1, thres = 0)))
+ if (jaspBase::isTryError(temp))
+ stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
+ beta <- temp$estimate[1]
+ theta <- temp$estimate[2]
+ threshold <- temp$estimate[3]
+ }
+ list <- list(beta = beta,
+ theta = theta)
+ if(distribution == '3ParameterWeibull' | distribution == "3ParameterLognormal")
+ list['threshold'] <- threshold
+ return(list)
+}
diff --git a/R/processCapabilityStudies.R b/R/processCapabilityStudies.R
index a9b900c9..c6c7272d 100644
--- a/R/processCapabilityStudies.R
+++ b/R/processCapabilityStudies.R
@@ -2379,40 +2379,5 @@ processCapabilityStudies <- function(jaspResults, dataset, options) {
return(plotList)
}
-.distributionParameters <- function(data, distribution = c("lognormal", "weibull", "3ParameterLognormal", "3ParameterWeibull")){
- if (distribution == "lognormal") {
- fit_Lnorm <- try(EnvStats::elnorm(data))
- if (jaspBase::isTryError(fit_Lnorm))
- stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
- beta <- fit_Lnorm$parameters[1]
- theta <- fit_Lnorm$parameters[2]
- } else if (distribution == "weibull") {
- fit_Weibull <- try(fitdistrplus::fitdist(data, "weibull", method = "mle",
- control = list(maxit = 500, abstol = .Machine$double.eps, reltol = .Machine$double.eps)))
- if (jaspBase::isTryError(fit_Weibull))
- stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
- beta <- fit_Weibull$estimate[[1]]
- theta <- fit_Weibull$estimate[[2]]
- } else if(distribution == "3ParameterLognormal") {
- temp <- try(EnvStats::elnorm3(data))
- if (jaspBase::isTryError(temp))
- stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
- beta <- temp$parameters[[1]]
- theta <- temp$parameters[[2]]
- threshold <- temp$parameters[[3]]
- } else if(distribution == "3ParameterWeibull") {
- temp <- try(MASS::fitdistr(data, function(x, shape, scale, thres)
- dweibull(x-thres, shape, scale), list(shape = 0.1, scale = 1, thres = 0)))
- if (jaspBase::isTryError(temp))
- stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
- beta <- temp$estimate[1]
- theta <- temp$estimate[2]
- threshold <- temp$estimate[3]
- }
- list <- list(beta = beta,
- theta = theta)
- if(distribution == '3ParameterWeibull' | distribution == "3ParameterLognormal")
- list['threshold'] <- threshold
- return(list)
-}
+
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index 1c785a71..e6c183eb 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -78,15 +78,27 @@ rareEventCharts <- function(jaspResults, dataset, options) {
# options[["dataTypeDatesFormatTime"]] <- "HM"
# ###########################
-#
-# # reproduce example
-# dataset <- read.csv("c:/Users/Jonee/Desktop/Temporary Files/specialControlCharts/gchart.csv")
-# options <- list()
-# variable <- "Date.of.infection"
-# options[["dataType"]] <- "dataTypeDates"
-# options[["dataTypeDatesStructure"]] <- "dateOnly"
-# options[["dataTypeDatesFormatDate"]] <- "md"
-#
+ #
+ # # reproduce example g chart
+ # dataset <- read.csv("c:/Users/Jonee/Desktop/Temporary Files/specialControlCharts/gchart.csv")
+ # options <- list()
+ # variable <- "Date.of.infection"
+ # options[["dataType"]] <- "dataTypeDates"
+ # options[["dataTypeDatesStructure"]] <- "dateOnly"
+ # options[["dataTypeDatesFormatDate"]] <- "md"
+ #
+
+
+ # # reproduce example t chart
+ # dataset <- read.csv("c:/Users/Jonee/Desktop/Temporary Files/specialControlCharts/tchart.csv")
+ # options <- list()
+ # variable <- "Date.and.time.of.needlestick"
+ # options[["dataType"]] <- "dataTypeDates"
+ # options[["dataTypeDatesStructure"]] <- "dateTime"
+ # options[["dataTypeDatesFormatDate"]] <- "md"
+ # options[["dataTypeDatesFormatTime"]] <- "HM"
+
+
if (ready) {
@@ -99,6 +111,7 @@ rareEventCharts <- function(jaspResults, dataset, options) {
"timeDate" = paste(options[["dataTypeDatesFormatTime"]], options[["dataTypeDatesFormatDate"]]),
"dateOnly" = options[["dataTypeDatesFormatDate"]],
"timeOnly" = options[["dataTypeDatesFormatTime"]])
+ timepoints <- lubridate::parse_date_time(timepoints, orders = timeFormat) # returns all data in HMS format
timepointsLag1 <- c(NA, timepoints[seq(1, length(timepoints) - 1)]) # because of the NA, everything is converted to seconds
intervalsMinutes <- as.numeric(timepoints - timepointsLag1)/60
intervalsHours <- intervalsMinutes/60
@@ -111,17 +124,25 @@ rareEventCharts <- function(jaspResults, dataset, options) {
intervalsHours <- intervalsMinutes/60
}
+ # if intervals are all NA, throw error
+ if (all(is.na(timepoints))) {
+ errorPlot <- createJaspPlot(title = gettext("Rare event charts"), width = 1200, height = 500)
+ errorPlot$setError(gettext("Date/time conversion returned no valid values. Did you select the correct date/time format?"))
+ jaspResults[["errorPlot"]] <- errorPlot
+ return()
+ }
+
# Get the interval type, depending on the input type and, if applicable, the calculated intervals
- if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalTypeOpportunities"]]) {
+ if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "opportunities") {
intervals <- dataset[[variable]]
intervalType <- "opportunities"
- } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalTypeHours"]]) {
+ } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "hours") {
intervals <- dataset[[variable]]
intervalType <- "hours"
- } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalTypeDays"]]) {
+ } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "days") {
intervals <- dataset[[variable]]
intervalType <- "days"
- } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalTypeTime"]]) {
+ } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "time") {
intervals <- if(all(intervalsHours < 1, na.rm = TRUE) ) intervalsMinutes else intervalsHours
intervalType <- if(all(intervalsHours < 1, na.rm = TRUE)) "minutes" else "hours"
} else if (options[["dataType"]] == "dataTypeDates") {
@@ -136,14 +157,15 @@ rareEventCharts <- function(jaspResults, dataset, options) {
intervalType <- "days"
}
}
- }
- if (!identical(stages, "")) {
- dataset <- data.frame(x1 = intervals, x2 = dataset[[stages]])
- colnames(dataset) <- c(variable, stages)
- } else {
- dataset <- data.frame(x1 = intervals)
- colnames(dataset) <- variable
+ if (length(stages) == 1) {
+ dataset <- data.frame(x1 = intervals, x2 = dataset[[stages]])
+ colnames(dataset) <- c(variable, stages)
+ } else {
+ dataset <- data.frame(x1 = intervals)
+ colnames(dataset) <- variable
+ stages <- ""
+ }
}
# G chart
@@ -187,23 +209,12 @@ rareEventCharts <- function(jaspResults, dataset, options) {
if (!ready)
return(plot)
-#
-# plotObject <- .rareEventPlottingFunction(intervals = intervals,
-# stages = stages,
-# intervalType = intervalType,
-# chartType = "t",
-# tChartDistribution = options[["tChartDistribution"]])
+
+ columnsToPass <- c(variable, stages)
+ columnsToPass <- columnsToPass[columnsToPass != ""]
+ plotObject <- .controlChart(dataset[columnsToPass], plotType = "t", stages = stages, gAndtUnit = intervalType,
+ tChartDistribution = options[["tChartDistribution"]])$plotObject
plot$plotObject <- plotObject
return(plot)
}
-
-# .rareEventPlottingFunction <- function(intervals,
-# stages = NULL,
-# intervalType = c("days", "hours", "minutes", "opportunities"),
-# chartType = c("g", "t"),
-# tChartDistribution = c("weibull", "exponential")) {
-#
-#
-# }
-
diff --git a/inst/qml/rareEventCharts.qml b/inst/qml/rareEventCharts.qml
index 34906ac0..358c7dfc 100644
--- a/inst/qml/rareEventCharts.qml
+++ b/inst/qml/rareEventCharts.qml
@@ -20,7 +20,7 @@ Form
name: "variable"
title: qsTr("Variable")
id: variable
- allowedColumns: ["nominal"]
+ allowedColumns: dataType.value == "dataTypeInterval" & dataTypeIntervalType.value != "time" ? ["scale"] : ["nominal"]
singleVariable: true
}
@@ -109,10 +109,10 @@ Form
label: qsTr("Interval type")
values:
[
- { label: qsTr("Opportunities"), value: "dataTypeIntervalTypeOpportunities"},
- { label: qsTr("Time"), value: "dataTypeIntervalTypeTime"},
- { label: qsTr("Hours (decimal)"), value: "dataTypeIntervalTypeHours"},
- { label: qsTr("Days (decimal)"), value: "dataTypeIntervalTypeDays"}
+ { label: qsTr("Opportunities"), value: "opportunities"},
+ { label: qsTr("Time"), value: "time"},
+ { label: qsTr("Hours (decimal)"), value: "hours"},
+ { label: qsTr("Days (decimal)"), value: "days"}
]
indexDefaultValue: 0
}
@@ -183,8 +183,8 @@ Form
label: qsTr("Based on")
values:
[
- { label: qsTr("Weibull distribution"), value: "tChartDistributionWeibull"},
- { label: qsTr("Exponential distribution"), value: "tChartDistributionExponential"}
+ { label: qsTr("Weibull distribution"), value: "weibull"},
+ { label: qsTr("Exponential distribution"), value: "exponential"}
]
indexDefaultValue: 0
}
From 62b6a61aff071629d2ad796ac8695ea4b92003b4 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 21 Aug 2024 17:55:02 +0200
Subject: [PATCH 08/25] historical parameters and handling 0s in weibull
---
R/commonQualityControl.R | 96 +++++++++++++++++++++---------------
R/rareEventCharts.R | 28 ++++++-----
inst/qml/rareEventCharts.qml | 16 +++---
3 files changed, 82 insertions(+), 58 deletions(-)
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index f99c95ef..c92b7c30 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -414,7 +414,10 @@ KnownControlStats.RS <- function(N, sigma = 3) {
cusumTarget = 0,
ewmaLambda = 0.3,
gAndtUnit = c("days", "hours", "minutes", "opportunities"),
- tChartDistribution = c("weibull", "exponential")
+ phase2gChartProportion = 0.5,
+ tChartDistribution = c("weibull", "exponential"),
+ phase2tChartDistributionShape = 1,
+ phase2tChartDistributionScale = 3
) {
plotType <- match.arg(plotType)
@@ -425,7 +428,9 @@ KnownControlStats.RS <- function(N, sigma = 3) {
warningLimits = warningLimits, movingRangeLength = movingRangeLength,
stagesSeparateCalculation = stagesSeparateCalculation, unbiasingConstantUsed = unbiasingConstantUsed,
cusumShiftSize = cusumShiftSize, cusumTarget = cusumTarget, ewmaLambda = ewmaLambda,
- tChartDistribution = tChartDistribution)
+ tChartDistribution = tChartDistribution, phase2tChartDistributionShape = phase2tChartDistributionShape,
+ phase2tChartDistributionScale = phase2tChartDistributionScale,
+ phase2gChartProportion = phase2gChartProportion)
# This function turns the point violation list into a JASP table
@@ -443,22 +448,25 @@ KnownControlStats.RS <- function(N, sigma = 3) {
return(list(plotObject = plotObject, table = table, controlChartData = controlChartData))
}
-.controlChart_calculations <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma", "g", "t"),
- stages = "",
- xBarSdType = c("r", "s"),
- nSigmasControlLimits = 3,
- phase2 = FALSE,
- phase2Mu = "",
- phase2Sd = "",
- fixedSubgroupSize = "",
- warningLimits = FALSE,
- movingRangeLength = 2,
- stagesSeparateCalculation = TRUE,
- unbiasingConstantUsed = TRUE,
- cusumShiftSize = 0.5,
- cusumTarget = 0,
- ewmaLambda = 0.3,
- tChartDistribution = c("weibull", "exponential")
+.controlChart_calculations <- function(dataset, plotType = c("xBar", "R", "I", "MR", "MMR", "s", "cusum", "ewma", "g", "t"),
+ stages = "",
+ xBarSdType = c("r", "s"),
+ nSigmasControlLimits = 3,
+ phase2 = FALSE,
+ phase2Mu = "",
+ phase2Sd = "",
+ fixedSubgroupSize = "",
+ warningLimits = FALSE,
+ movingRangeLength = 2,
+ stagesSeparateCalculation = TRUE,
+ unbiasingConstantUsed = TRUE,
+ cusumShiftSize = 0.5,
+ cusumTarget = 0,
+ ewmaLambda = 0.3,
+ phase2gChartProportion = 0.5,
+ tChartDistribution = c("weibull", "exponential"),
+ phase2tChartDistributionShape = 1,
+ phase2tChartDistributionScale = 3
) {
plotType <- match.arg(plotType)
if (identical(stages, "")) {
@@ -658,31 +666,34 @@ KnownControlStats.RS <- function(N, sigma = 3) {
individualPointSigmas <- .ewmaPointSigmas(n = n, sigma = sigma, lambda = ewmaLambda)
UCL <- center + individualPointSigmas * nSigmasControlLimits
LCL <- center - individualPointSigmas * nSigmasControlLimits
- ###
- ### Calculations for g chart
- ###
+ ###
+ ### Calculations for g chart
+ ###
} else if (plotType == "g") {
plotStatistic <- unname(unlist(dataCurrentStage))
- gChartStatistics <- .gChartStatistics(intervals = plotStatistic)
+ gChartStatistics <- .gChartStatistics(intervals = plotStatistic, phase2Proportion = if(phase2) phase2gChartProportion else "")
center <- gChartStatistics$CL
UCL <- gChartStatistics$UCL
LCL <- gChartStatistics$LCL
p <- gChartStatistics$p
- ###
- ### Calculations for t chart
- ###
+ ###
+ ### Calculations for t chart
+ ###
} else if (plotType == "t") {
plotStatistic <- unname(unlist(dataCurrentStage))
- if (tChartDistribution == "weibull") {
- weibullPars <- fitdistrplus::fitdist(plotStatistic[!is.na(plotStatistic)], "weibull", method = "mle",
- control = list(maxit = 500, abstol = .Machine$double.eps, reltol = .Machine$double.eps))
- shape <- unname(weibullPars[[1]][1])
- scale <- unname(weibullPars[[1]][2])
- } else if (tChartDistribution == "exponential") {
- exponentialPars <- fitdistrplus::fitdist(plotStatistic[!is.na(plotStatistic)], "weibull", method = "mle", fix.arg = list("shape" = 1),
- control = list(maxit = 500, abstol = .Machine$double.eps, reltol = .Machine$double.eps))
- shape <- 1
- scale <- unname(exponentialPars[[1]][1])
+
+ if (any(plotStatistic == 0)) {
+ zeroCorrectionIndices <- which(plotStatistic == 0, arr.ind = TRUE)
+ plotStatistic[zeroCorrectionIndices] <- min(plotStatistic[plotStatistic > 0], na.rm = TRUE)/2
+ }
+
+ if (!phase2) {
+ distributionPars <- .distributionParameters(plotStatistic[!is.na(plotStatistic)], distribution = tChartDistribution)
+ shape <- distributionPars$beta
+ scale <- distributionPars$theta
+ } else {
+ shape <- if (tChartDistribution == "exponential") 1 else phase2tChartDistributionShape
+ scale <- phase2tChartDistributionScale
}
center <- qweibull(p = .5, shape = shape, scale = scale)
UCL <- qweibull(p = pnorm(3), shape = shape, scale = scale)
@@ -1072,7 +1083,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
ewmaPoint <- lambda * rowMeanVector[i] + (1 - lambda) * previousPoint
ewmaPoints[i] <- ewmaPoint
}
-return(ewmaPoints)
+ return(ewmaPoints)
}
.ewmaPointSigmas <- function(n = n, sigma = sigma, lambda = ewmaLambda) {
@@ -1089,10 +1100,10 @@ return(ewmaPoints)
return(ewmaPointSigmas)
}
-.gChartStatistics <- function(intervals) {
+.gChartStatistics <- function(intervals, phase2Proportion = "") {
intervalsMean <- mean(intervals, na.rm = TRUE)
n <- sum(!is.na(intervals))
- p <- ((n - 1) / n) / (intervalsMean + 1)
+ p <- if (identical(phase2Proportion, "")) ((n - 1) / n) / (intervalsMean + 1) else phase2Proportion
# calculate CL
p2a <- pgeom(qgeom(0.5, prob = p) - 1, prob = p, lower.tail = T) # p2a is the CDF at G2a
@@ -1129,7 +1140,7 @@ return(ewmaPoints)
return(list(p = p, CL = CL, UCL = UCL, LCL = LCL))
}
-.distributionParameters <- function(data, distribution = c("lognormal", "weibull", "3ParameterLognormal", "3ParameterWeibull")){
+.distributionParameters <- function(data, distribution = c("lognormal", "weibull", "3ParameterLognormal", "3ParameterWeibull", "exponential")){
if (distribution == "lognormal") {
fit_Lnorm <- try(EnvStats::elnorm(data))
if (jaspBase::isTryError(fit_Lnorm))
@@ -1158,6 +1169,13 @@ return(ewmaPoints)
beta <- temp$estimate[1]
theta <- temp$estimate[2]
threshold <- temp$estimate[3]
+ } else if (distribution == "exponential") {
+ fit_Weibull <- try(fitdistrplus::fitdist(data, "weibull", method = "mle", fix.arg = list("shape" = 1),
+ control = list(maxit = 500, abstol = .Machine$double.eps, reltol = .Machine$double.eps)))
+ if (jaspBase::isTryError(fit_Weibull))
+ stop(gettext("Parameter estimation failed. Values might be too extreme. Try a different distribution."), call. = FALSE)
+ beta <- 1
+ theta <- fit_Weibull$estimate[[1]]
}
list <- list(beta = beta,
theta = theta)
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index e6c183eb..ffc41580 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -78,15 +78,15 @@ rareEventCharts <- function(jaspResults, dataset, options) {
# options[["dataTypeDatesFormatTime"]] <- "HM"
# ###########################
- #
- # # reproduce example g chart
- # dataset <- read.csv("c:/Users/Jonee/Desktop/Temporary Files/specialControlCharts/gchart.csv")
- # options <- list()
- # variable <- "Date.of.infection"
- # options[["dataType"]] <- "dataTypeDates"
- # options[["dataTypeDatesStructure"]] <- "dateOnly"
- # options[["dataTypeDatesFormatDate"]] <- "md"
- #
+#
+# # reproduce example g chart
+# dataset <- read.csv("c:/Users/Jonee/Desktop/Temporary Files/specialControlCharts/gchart.csv")
+# options <- list()
+# variable <- "Date.of.infection"
+# options[["dataType"]] <- "dataTypeDates"
+# options[["dataTypeDatesStructure"]] <- "dateOnly"
+# options[["dataTypeDatesFormatDate"]] <- "md"
+
# # reproduce example t chart
@@ -193,7 +193,9 @@ rareEventCharts <- function(jaspResults, dataset, options) {
columnsToPass <- c(variable, stages)
columnsToPass <- columnsToPass[columnsToPass != ""]
- plotObject <- .controlChart(dataset[columnsToPass], plotType = "g", stages = stages, gAndtUnit = intervalType)$plotObject
+ phase2 <- options[["gChartProportionSource"]] == "historical"
+ plotObject <- .controlChart(dataset[columnsToPass], plotType = "g", stages = stages, gAndtUnit = intervalType,
+ phase2 = phase2, phase2gChartProportion = options[["gChartHistoricalProportion"]])$plotObject
plot$plotObject <- plotObject
return(plot)
@@ -212,8 +214,12 @@ rareEventCharts <- function(jaspResults, dataset, options) {
columnsToPass <- c(variable, stages)
columnsToPass <- columnsToPass[columnsToPass != ""]
+ phase2 <- options[["tChartDistributionParameterSource"]] == "historical"
plotObject <- .controlChart(dataset[columnsToPass], plotType = "t", stages = stages, gAndtUnit = intervalType,
- tChartDistribution = options[["tChartDistribution"]])$plotObject
+ tChartDistribution = options[["tChartDistribution"]],
+ phase2tChartDistributionShape = options[["tChartHistoricalParametersWeibullShape"]],
+ phase2tChartDistributionScale = options[["tChartHistoricalParametersScale"]],
+ phase2 = phase2)$plotObject
plot$plotObject <- plotObject
return(plot)
diff --git a/inst/qml/rareEventCharts.qml b/inst/qml/rareEventCharts.qml
index 358c7dfc..f49837fa 100644
--- a/inst/qml/rareEventCharts.qml
+++ b/inst/qml/rareEventCharts.qml
@@ -75,7 +75,7 @@ Form
{ label: qsTr("DM"), value: "dm"},
{ label: qsTr("MD"), value: "md"}
]
- indexDefaultValue: 0
+ indexDefaultValue: 3
}
DropDown
@@ -152,8 +152,8 @@ Form
label: qsTr("Proportion")
values:
[
- { label: qsTr("Estimated from data"), value: "gChartProportionSourceData"},
- { label: qsTr("Historical"), value: "gChartProportionSourceHistorical"}
+ { label: qsTr("Estimated from data"), value: "data"},
+ { label: qsTr("Historical"), value: "historical"}
]
indexDefaultValue: 0
}
@@ -165,7 +165,7 @@ Form
label: qsTr("Proportion value")
min: 0
max: 1
- visible: gChartProportionSource.value == "gChartProportionSourceHistorical"
+ visible: gChartProportionSource.value == "historical"
defaultValue: 0.5
}
}
@@ -196,8 +196,8 @@ Form
label: qsTr("Distribution parameters")
values:
[
- { label: qsTr("Estimated from data"), value: "tChartDistributionParameterSourceData"},
- { label: qsTr("Historical"), value: "tChartDistributionParameterSourceHistorical"}
+ { label: qsTr("Estimated from data"), value: "data"},
+ { label: qsTr("Historical"), value: "historical"}
]
indexDefaultValue: 0
}
@@ -209,7 +209,7 @@ Form
label: qsTr("Shape")
min: 0
inclusive: JASP.None
- visible: tChartDistributionParameterSource.value == "tChartDistributionParameterSourceHistorical" & tChartDistribution.value == "tChartDistributionWeibull"
+ visible: tChartDistributionParameterSource.value == "historical" & tChartDistribution.value == "weibull"
defaultValue: 2
}
@@ -221,7 +221,7 @@ Form
label: qsTr("Scale")
min: 0
inclusive: JASP.None
- visible: tChartDistributionParameterSource.value == "tChartDistributionParameterSourceHistorical"
+ visible: tChartDistributionParameterSource.value == "historical"
defaultValue: 2
}
}
From 1a0847aa4030383139fb81e870525597665c22a8 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 21 Aug 2024 18:32:31 +0200
Subject: [PATCH 09/25] helpfile attribute charts
---
inst/help/attributesCharts.md | 67 ++++++++++++++++++++++-------------
1 file changed, 42 insertions(+), 25 deletions(-)
diff --git a/inst/help/attributesCharts.md b/inst/help/attributesCharts.md
index adee68ea..c7e711b7 100644
--- a/inst/help/attributesCharts.md
+++ b/inst/help/attributesCharts.md
@@ -1,52 +1,69 @@
Attribute Charts
==========================
-Control charts are a set of tools used to model the variation of a process, thereby indicating its stability and establishing a state of statistical control.
-Attribute charts are used for discrete data and model the stability of the process based on the sample size collected and the count of defectives\defects.
+A Shewhart control chart is a graph used to study how a process changes over time. The obtained measurements can be either variables or attributes data, and subgroups are taken from the process at regular intervals. From each subgroup one or more statistical measures (such as average, dispersion, or proportion) are plotted in time order. Each chart always has a central line usually the average of the subgroup statistic or may be based on past experience, if the process is in a state of statistical control. The control chart has two statistically determined boundaries, one on either side of the central line, which are called the upper control limit (UCL) and the lower control limit (LCL). They are typically based on and placed at a distance of three times the standard deviation of the statistic being plotted. By comparing current data to these lines, conclusions can be drawn about whether the process variation is consistent (i.e., in control) or is unpredictable (i.e., out of control, and affected by special causes of variation). Control charts for variables data are always used in pairs. The top chart monitors the averages i.e., the centring of the data from the process. The bottom chart monitors the ranges i.e., the spread of the distribution. Control charts for attributes data consist of a single chart. Attributes data represent observations obtained by noting the presence or absence of some characteristic (attributes) in each of the items in the subgroup under consideration, then counting how many items do or do not possess the attribute, or how many such events occur in the item, group or area. Attributes data are generally rapid and inexpensive to obtain and often do not require specialised collection skills.
+
+The assumed distribution for attributes data has only one independent parameter, the average level. The p and np control charts are based on the binomial distribution (for defectives), while the u and c control charts are based on the Poisson distribution (for defects).There are many types of count based data that cannot be characterised by either a binomial (p and np) or a Poisson (u and c) distribution. When such data are placed on p, np, u, or c control charts the limits based on these models would be wrong. The Laney p′ (p prime) and u′ (u prime) charts are used to monitor attributes data if the sample sizes are variable and often very large. In such cases, it is common for the average proportion or rate to vary over the sampling period, a phenomenon known as overdispersion. Overdispersion means the sample-to-sample variation (i.e., the between sample variation) is much larger than the variation within the sample. Underdispersion is the opposite.
+
+Unlike the attributes control charts, the X-mR control chart makes no assumptions about the relationship between the location and the dispersion parameter. It directly measures the location with the average and the dispersion with the moving ranges. Thus, while the p, np, u, and c control charts use “theoretical” limits, the X-mR control chart uses “empirical” limits. X-mR control charts are used if the sample sizes are reasonable constant. Laney control charts are used if sample sizes vary; if the sample size is constant the Laney control chart is exactly the same as the X mR control chart.
+
## Assumptions
-------
-The assumptions for attribute charts are:
-- np/c chart: the sample size used for data collection is equal.
-- p/u chart: the sample size used for data collection is inequal.
-- Laney p'/u': the data are overdispersed or underdispersed.
+The assumptions for attributes control charts are:
+- p/np control chart are used if the observed data are approximately binomial distributed;
+- u/c control chart are used if the observed data are approximately Poisson distributed;
+- np/c control chart: the subgroup size used for data collection is constant;
+- p/u control chart: the subgroup size used for data collection is either variable or constant;
+- Laney p'/u': the observed data cannot be modelled by either a binomial or a Poisson distribution and the subgroup size is variable.
## Input
-------
### Assignment Box
-- Defectives\Defects: the observations collected from a process.
+- Defectives/Defects: the number of observations collected from a process that do or do not possess the attribute.
- Sample: sample size of each observation.
## Output
-------
### Charts
-Defectives charts: Defectives charts are used in products that are either defective or not defective (binary).
-- np chart: plots the count of non-conforming (defective) products.
-- p chart: displays changes in the proportion of non-conforming (defective) products, rejects or unacceptable outcomes.
-- Laney p' chart: plots the variation adjusted proportion of non-conforming (defective) products.
+Defectives charts: Defectives charts are used for products that are either defective or not defective (binary).
+ - p chart, which charts the proportion of non-conforming (defective) products, rejects or unacceptable outcomes, or conforming/accepted items in each subgroup.
+ - np chart, which charts the number of non-conforming (defective) products or only the conforming items in each subgroup.
+ - Laney p' chart, which charts the variation proportion of non-conforming (defective) products in each subgroup with adjusted control limits.
-Defects charts: In the case of defectives charts the product may have multiple defects per unit (non-binary).
-- c chart: plots the count of defects or non-conformities in a sample over time.
-- u chart: plots the proportion of defects or non-conformities in a sample over time.
-- Laney u' chart: plots the variation adjusted proportion of defects or non-conformities in products over time.
+Defects charts: Defects charts are used for products that have multiple defects per unit (the possible occurrences could be infinite).
+ - u chart, which charts the proportion of defects or non-conformities in each subgroup. Subgroup size is variable.
+ - chart, which charts the number of defects or non-conformities in each subgroup. Subgroup size is constant.
+ - Laney u' chart, which charts the variation proportion of defects or non-conformities in products in each subgroup with adjusted control limits.
+
+X-mR chart, which charts the process values (individuals) and moving range (mR) over time.
-X-mR chart: plots the process's values (Individual) and moving range (MR) over time.
### Out-of-control Signals
-------
-_Statistical process control handbook page 23:_
+ To indicate special cause variation the following unnatural patterns are used:
+
+- Signal 1: One point beyond the control limits (sporadic issue). One point more than three standard deviations from the central line equivalent to violation of UCL or LCL.
+- Signal 2: Seven consecutive points above or below the central line (mean shift). Seven points in a row on same side of centre line equivalent to a run above or below centre line.
+- Signal 3: A run up or down of seven consecutive points (trend). Seven points in a row all increasing or all decreasing equivalent to a run downward or upward.
+- Signal 4: Two out of three consecutive points beyond the warning (two sigma) limits (increasing variation).
+- Signal 5:Hugging the central line, this is indicated when 15 consecutive points are within the one sigma limits (reducing variation).
+- Signal 6: Eight consecutive points are beyond the one sigma limits, regardless of which side of the central line (bimodal distribution).
+
+The lack of control in both average and variation charts is generally found in the initial stages of setting up of control charts, sometimes called Phase 1 control charts. Using all six signals is only applicable for the average chart during Phase 1 when the control chart is used as an analysis tool. The first three signals are used always, for variables as well as attributes control charts.
+
+In the case that the data of the individual and moving Range chart (X-mR chart) violate the pre assumption (normality and independently distributed) only signal 1 is applied. Autocorrelation is an indication of that.
-- Test 1: One point beyond the control limits (sporadic issue).
-- Test 2: Seven consecutive points above or below the central line (mean shift).
-- Test 3: A run up or down of seven consecutive points (trend).
-- Test 4: Two out of three consecutive points beyond the warning (two sigma) limits (increasing variation).
-- Test 5:Hugging the central line, this is indicated when 15 consecutive points are within the one sigma limits (reducing variation).
-- Test 6: Eight consecutive points are beyond the one sigma limits, regardless of which side of the central line (bimodal distribution).
## 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.
+
+- Duncan, A.J. (1986), *Quality control and industrial statistics*, Richard D. Irwin, Inc.
+- Automotive Industry Action Group, *Statistical Process Control – Reference Manual* (July 2005, 2nd Edition)
+- SKF Quality Techniques, Klerx, R., Dodson, B., and Dumont, D., QT 1 – *Process capability studies* (PUB GQ/P9 10347/1 EN – December 2021)
+- SKF Quality Techniques, Dodson, B., Lynch, D., Weidenbacher, M., and Klerx, R., QT 2 – *Statistical process control* (PUB GQS/P9 18343 EN – April 2019)
+- International Organization for Standardization, *Control charts – Part 2: Shewhart control charts*, ISO 7870-2:2023 (E)
+
## R Packages
-------
From 89f06e998a3560b306e2174ea1ec4ff771e87bb6 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Thu, 22 Aug 2024 17:46:45 +0200
Subject: [PATCH 10/25] Report functionality time weighted and rare event
charts
---
R/TimeWeightedCharts.R | 57 ++++++++++-
R/commonQualityControl.R | 2 +-
R/rareEventCharts.R | 52 +++++++++-
inst/qml/rareEventCharts.qml | 163 ++++++++++++++++++++++++++++++++
inst/qml/timeWeightedCharts.qml | 162 +++++++++++++++++++++++++++++++
5 files changed, 428 insertions(+), 8 deletions(-)
diff --git a/R/TimeWeightedCharts.R b/R/TimeWeightedCharts.R
index 2636f3db..dedca043 100644
--- a/R/TimeWeightedCharts.R
+++ b/R/TimeWeightedCharts.R
@@ -96,14 +96,61 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
}
#Cusum chart
- if (options[["cumulativeSumChart"]] && is.null(jaspResults[["CusumPlot"]])) {
- jaspResults[["CusumPlot"]] <- .Cusumchart(dataset = dataset, measurements = measurements, stages = stages,
- axisLabels = axisLabels, options = options, ready = ready)
+ if (options[["cumulativeSumChart"]] && is.null(jaspResults[["CusumChart"]])) {
+ cusumChart <- .Cusumchart(dataset = dataset, measurements = measurements, stages = stages,
+ axisLabels = axisLabels, options = options, ready = ready)
}
#EWMA chart
if (options[["exponentiallyWeightedMovingAverageChart"]] && is.null(jaspResults[["EWMAPlot"]])) {
- jaspResults[["EWMAPlot"]] <- .EWMA(dataset = dataset, measurements = measurements, stages = stages,
- axisLabels = axisLabels, options = options, ready = ready)
+ ewmaPlot <- .EWMA(dataset = dataset, measurements = measurements, stages = stages,
+ axisLabels = axisLabels, options = options, ready = ready)
+ }
+
+
+ # Report
+ if (options[["report"]]) {
+ reportPlot <- createJaspPlot(title = gettext("Time weighted charts report"), width = 1250, height = 1000)
+ jaspResults[["report"]] <- reportPlot
+ jaspResults[["report"]]$dependOn(c(""))
+
+ # Plot meta data
+ if (options[["reportTitle"]] ) {
+ title <- if (options[["reportTitleText"]] == "") gettext("Time weighted charts report") else options[["reportTitleText"]]
+ } else {
+ title <- ""
+ }
+
+ if (options[["reportMetaData"]]) {
+ text <- c()
+ text <- if (options[["reportChartName"]]) c(text, gettextf("Chart name: %s", options[["reportChartNameText"]])) else text
+ text <- if (options[["reportSubtitle"]]) c(text, gettextf("Sub-title: %s", options[["reportSubtitleText"]])) else text
+ text <- if (options[["reportMeasurementName"]]) c(text, gettextf("Measurement name: %s", options[["reportMeasurementNameText"]])) else text
+ text <- if (options[["reportFootnote"]]) c(text, gettextf("Footnote: %s", options[["reportFootnoteText"]])) else text
+ text <- if (options[["reportLocation"]]) c(text, gettextf("Location: %s", options[["reportLocationText"]])) else text
+ text <- if (options[["reportDate"]]) c(text, gettextf("Date: %s", options[["reportDateText"]])) else text
+ text <- if (options[["reportPerformedBy"]]) c(text, gettextf("Performed by: %s", options[["reportPerformedByText"]])) else text
+ text <- if (options[["reportPrintDate"]]) c(text, gettextf("Print date: %s", options[["reportPrintDateText"]])) else text
+ } else {
+ text <- NULL
+ }
+
+ plots <- list()
+ if (options[["cumulativeSumChart"]])
+ plots[["cusum"]] <- cusumChart$plotObject
+ if (options[["exponentiallyWeightedMovingAverageChart"]])
+ plots[["ewma"]] <- ewmaPlot$plotObject
+ reportPlotObject <- .qcReport(text = text, plots = plots, textMaxRows = 8,
+ reportTitle = title)
+ reportPlot$plotObject <- reportPlotObject
+
+ ###
+ ### If not report mode
+ ###
+ } else {
+ if (options[["cumulativeSumChart"]])
+ jaspResults[["CusumChart"]] <- cusumChart
+ if (options[["exponentiallyWeightedMovingAverageChart"]])
+ jaspResults[["EWMAPlot"]] <- ewmaPlot
}
}
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index c92b7c30..9d31bda5 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -682,7 +682,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
} else if (plotType == "t") {
plotStatistic <- unname(unlist(dataCurrentStage))
- if (any(plotStatistic == 0)) {
+ if (any(plotStatistic[!is.na(plotStatistic)] == 0)) {
zeroCorrectionIndices <- which(plotStatistic == 0, arr.ind = TRUE)
plotStatistic[zeroCorrectionIndices] <- min(plotStatistic[plotStatistic > 0], na.rm = TRUE)/2
}
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index ffc41580..eed791e2 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -170,13 +170,61 @@ rareEventCharts <- function(jaspResults, dataset, options) {
# G chart
if (options[["gChart"]] && is.null(jaspResults[["gChart"]])) {
- jaspResults[["gChart"]] <- .gChart(dataset, variable, stages, intervalType, options, ready)
+ gChart <- .gChart(dataset, variable, stages, intervalType, options, ready)
}
# T chart
if (options[["tChart"]] && is.null(jaspResults[["tChart"]])) {
- jaspResults[["tChart"]] <- .tChart(dataset, variable, stages, intervalType, options, ready)
+ tChart <- .tChart(dataset, variable, stages, intervalType, options, ready)
}
+
+
+ # Report
+ if (options[["report"]]) {
+ reportPlot <- createJaspPlot(title = gettext("Rare event charts report"), width = 1250, height = 1000)
+ jaspResults[["report"]] <- reportPlot
+ jaspResults[["report"]]$dependOn(c(""))
+
+ # Plot meta data
+ if (options[["reportTitle"]] ) {
+ title <- if (options[["reportTitleText"]] == "") gettext("Rare event charts report") else options[["reportTitleText"]]
+ } else {
+ title <- ""
+ }
+
+ if (options[["reportMetaData"]]) {
+ text <- c()
+ text <- if (options[["reportChartName"]]) c(text, gettextf("Chart name: %s", options[["reportChartNameText"]])) else text
+ text <- if (options[["reportSubtitle"]]) c(text, gettextf("Sub-title: %s", options[["reportSubtitleText"]])) else text
+ text <- if (options[["reportMeasurementName"]]) c(text, gettextf("Measurement name: %s", options[["reportMeasurementNameText"]])) else text
+ text <- if (options[["reportFootnote"]]) c(text, gettextf("Footnote: %s", options[["reportFootnoteText"]])) else text
+ text <- if (options[["reportLocation"]]) c(text, gettextf("Location: %s", options[["reportLocationText"]])) else text
+ text <- if (options[["reportDate"]]) c(text, gettextf("Date: %s", options[["reportDateText"]])) else text
+ text <- if (options[["reportPerformedBy"]]) c(text, gettextf("Performed by: %s", options[["reportPerformedByText"]])) else text
+ text <- if (options[["reportPrintDate"]]) c(text, gettextf("Print date: %s", options[["reportPrintDateText"]])) else text
+ } else {
+ text <- NULL
+ }
+
+ plots <- list()
+ if (options[["gChart"]])
+ plots[["gChart"]] <- gChart$plotObject
+ if (options[["tChart"]])
+ plots[["tChart"]] <- tChart$plotObject
+ reportPlotObject <- .qcReport(text = text, plots = plots, textMaxRows = 8,
+ reportTitle = title)
+ reportPlot$plotObject <- reportPlotObject
+
+ ###
+ ### If not report mode
+ ###
+ } else {
+ if (options[["gChart"]])
+ jaspResults[["gChart"]] <- gChart
+ if (options[["tChart"]])
+ jaspResults[["tChart"]] <- tChart
+ }
+
}
diff --git a/inst/qml/rareEventCharts.qml b/inst/qml/rareEventCharts.qml
index f49837fa..97f99ba0 100644
--- a/inst/qml/rareEventCharts.qml
+++ b/inst/qml/rareEventCharts.qml
@@ -226,4 +226,167 @@ Form
}
}
}
+
+
+ Section
+ {
+ title: qsTr("Rare Event Charts Report")
+
+ CheckBox
+ {
+ name: "report"
+ label: qsTr("Show Report")
+ 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("Variable Charts for Subgroups Report")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportChartName"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportChartNameText"
+ label: qsTr("Chart name")
+ placeholderText: qsTr("Name of the chart")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportSubtitle"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportSubtitleText"
+ label: qsTr("Sub-title")
+ placeholderText: qsTr("Sub-title")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportMeasurementName"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportMeasurementNameText"
+ label: qsTr("Measurement name")
+ id: reportMeasurementNameText
+ placeholderText: qsTr("Name")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportFootnote"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportFootnoteText"
+ label: qsTr("Footnote")
+ id: reportFootnoteText
+ placeholderText: qsTr("Comment")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportLocation"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportLocationText"
+ label: qsTr("Location")
+ id: reportLocationText
+ placeholderText: qsTr("Location")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportDate"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportDateText"
+ label: qsTr("Date")
+ id: reportDateText
+ placeholderText: qsTr("Date")
+ 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: "reportPrintDate"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportPrintDateText"
+ label: qsTr("Date printed")
+ id: reportPrintDateText
+ placeholderText: qsTr("Today")
+ fieldWidth: 100
+ }
+ }
+ }
+ }
+ }
}
diff --git a/inst/qml/timeWeightedCharts.qml b/inst/qml/timeWeightedCharts.qml
index 6858d737..c0fe945e 100644
--- a/inst/qml/timeWeightedCharts.qml
+++ b/inst/qml/timeWeightedCharts.qml
@@ -308,4 +308,166 @@ Form
}
}
}
+
+ Section
+ {
+ title: qsTr("Time Weighted Charts Report")
+
+ CheckBox
+ {
+ name: "report"
+ label: qsTr("Show Report")
+ 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("Variable Charts for Subgroups Report")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportChartName"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportChartNameText"
+ label: qsTr("Chart name")
+ placeholderText: qsTr("Name of the chart")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportSubtitle"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportSubtitleText"
+ label: qsTr("Sub-title")
+ placeholderText: qsTr("Sub-title")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportMeasurementName"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportMeasurementNameText"
+ label: qsTr("Measurement name")
+ id: reportMeasurementNameText
+ placeholderText: qsTr("Name")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportFootnote"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportFootnoteText"
+ label: qsTr("Footnote")
+ id: reportFootnoteText
+ placeholderText: qsTr("Comment")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportLocation"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportLocationText"
+ label: qsTr("Location")
+ id: reportLocationText
+ placeholderText: qsTr("Location")
+ fieldWidth: 100
+ }
+ }
+
+ CheckBox
+ {
+ name: "reportDate"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportDateText"
+ label: qsTr("Date")
+ id: reportDateText
+ placeholderText: qsTr("Date")
+ 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: "reportPrintDate"
+ checked: true
+ childrenOnSameRow: true
+
+ TextField
+ {
+ name: "reportPrintDateText"
+ label: qsTr("Date printed")
+ id: reportPrintDateText
+ placeholderText: qsTr("Today")
+ fieldWidth: 100
+ }
+ }
+ }
+ }
+ }
}
From 70a2ff98b81210aaca89fd126e445356466f63ed Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Thu, 22 Aug 2024 18:24:47 +0200
Subject: [PATCH 11/25] Fix dependencies
---
R/TimeWeightedCharts.R | 33 ++++++++++++++++++++++++++++-----
R/rareEventCharts.R | 25 ++++++++++++++++++++-----
2 files changed, 48 insertions(+), 10 deletions(-)
diff --git a/R/TimeWeightedCharts.R b/R/TimeWeightedCharts.R
index dedca043..b9109695 100644
--- a/R/TimeWeightedCharts.R
+++ b/R/TimeWeightedCharts.R
@@ -96,12 +96,12 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
}
#Cusum chart
- if (options[["cumulativeSumChart"]] && is.null(jaspResults[["CusumChart"]])) {
+ if (options[["cumulativeSumChart"]]) {
cusumChart <- .Cusumchart(dataset = dataset, measurements = measurements, stages = stages,
axisLabels = axisLabels, options = options, ready = ready)
}
#EWMA chart
- if (options[["exponentiallyWeightedMovingAverageChart"]] && is.null(jaspResults[["EWMAPlot"]])) {
+ if (options[["exponentiallyWeightedMovingAverageChart"]]) {
ewmaPlot <- .EWMA(dataset = dataset, measurements = measurements, stages = stages,
axisLabels = axisLabels, options = options, ready = ready)
}
@@ -111,7 +111,19 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
if (options[["report"]]) {
reportPlot <- createJaspPlot(title = gettext("Time weighted charts report"), width = 1250, height = 1000)
jaspResults[["report"]] <- reportPlot
- jaspResults[["report"]]$dependOn(c(""))
+ jaspResults[["report"]]$dependOn(c("dataFormat", "measurementLongFormat", "subgroup", "stagesLongFormat", "measurementsWideFormat",
+ "axisLabels", "stagesWideFormat", "subgroupSizeType", "manualSubgroupSizeValue",
+ "groupingVariableMethod", "cumulativeSumChart", "cumulativeSumChartNumberSd",
+ "cumulativeSumChartShiftSize", "cumulativeSumChartTarget", "cumulativeSumChartSdSource",
+ "cumulativeSumChartSdMethod", "cumulativeSumChartSdValue", "cumulativeSumChartAverageMovingRangeLength",
+ "exponentiallyWeightedMovingAverageChart", "exponentiallyWeightedMovingAverageChartSigmaControlLimits",
+ "exponentiallyWeightedMovingAverageChartLambda", "exponentiallyWeightedMovingAverageChartSdSource",
+ "exponentiallyWeightedMovingAverageChartSdMethod", "exponentiallyWeightedMovingAverageChartSdValue",
+ "exponentiallyWeightedMovingAverageChartMovingRangeLength", "report", "reportMetaData",
+ "reportTitle", "reportTitleText", "reportChartName", "reportChartNameText", "reportSubtitle",
+ "reportSubtitleText", "reportMeasurementName", "reportMeasurementNameText", "reportFootnote",
+ "reportFootnoteText", "reportLocation", "reportLocationText", "reportDate", "reportDateText",
+ "reportPerformedBy", "reportPerformedByText", "reportPrintDate", "reportPrintDateText"))
# Plot meta data
if (options[["reportTitle"]] ) {
@@ -157,7 +169,12 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
.Cusumchart <- function(dataset, measurements, stages, axisLabels, options, ready) {
plot <- createJaspPlot(title = gettext("Cumulative sum chart"), width = 1200, height = 500)
- plot$dependOn(c("cumulativeSumChart", "measurements"))
+ plot$dependOn(c("dataFormat", "measurementLongFormat", "subgroup", "stagesLongFormat", "measurementsWideFormat",
+ "axisLabels", "stagesWideFormat", "subgroupSizeType", "manualSubgroupSizeValue",
+ "groupingVariableMethod", "cumulativeSumChart", "cumulativeSumChartNumberSd",
+ "cumulativeSumChartShiftSize", "cumulativeSumChartTarget", "cumulativeSumChartSdSource",
+ "cumulativeSumChartSdMethod", "cumulativeSumChartSdValue", "cumulativeSumChartAverageMovingRangeLength",
+ "report"))
if (!ready)
return(plot)
@@ -179,7 +196,13 @@ timeWeightedCharts <- function(jaspResults, dataset, options) {
.EWMA <- function(dataset, measurements, stages, axisLabels, options, ready) {
plot <- createJaspPlot(title = gettext("Exponentially weighted moving average chart"), width = 1200, height = 500)
- plot$dependOn(c(""))
+ plot$dependOn(c("dataFormat", "measurementLongFormat", "subgroup", "stagesLongFormat", "measurementsWideFormat",
+ "axisLabels", "stagesWideFormat", "subgroupSizeType", "manualSubgroupSizeValue",
+ "groupingVariableMethod", "exponentiallyWeightedMovingAverageChart",
+ "exponentiallyWeightedMovingAverageChartSigmaControlLimits", "exponentiallyWeightedMovingAverageChartLambda",
+ "exponentiallyWeightedMovingAverageChartSdSource", "exponentiallyWeightedMovingAverageChartSdMethod",
+ "exponentiallyWeightedMovingAverageChartSdValue", "exponentiallyWeightedMovingAverageChartMovingRangeLength",
+ "report"))
if (!ready)
return(plot)
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index eed791e2..baa0df70 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -127,6 +127,8 @@ rareEventCharts <- function(jaspResults, dataset, options) {
# if intervals are all NA, throw error
if (all(is.na(timepoints))) {
errorPlot <- createJaspPlot(title = gettext("Rare event charts"), width = 1200, height = 500)
+ errorPlot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
+ "dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat"))
errorPlot$setError(gettext("Date/time conversion returned no valid values. Did you select the correct date/time format?"))
jaspResults[["errorPlot"]] <- errorPlot
return()
@@ -169,12 +171,12 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
# G chart
- if (options[["gChart"]] && is.null(jaspResults[["gChart"]])) {
+ if (options[["gChart"]]) {
gChart <- .gChart(dataset, variable, stages, intervalType, options, ready)
}
# T chart
- if (options[["tChart"]] && is.null(jaspResults[["tChart"]])) {
+ if (options[["tChart"]]) {
tChart <- .tChart(dataset, variable, stages, intervalType, options, ready)
}
@@ -183,7 +185,15 @@ rareEventCharts <- function(jaspResults, dataset, options) {
if (options[["report"]]) {
reportPlot <- createJaspPlot(title = gettext("Rare event charts report"), width = 1250, height = 1000)
jaspResults[["report"]] <- reportPlot
- jaspResults[["report"]]$dependOn(c(""))
+ jaspResults[["report"]]$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
+ "dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat",
+ "gChart", "gChartProportionSource", "gChartHistoricalProportion", "tChart",
+ "tChartDistribution", "tChartDistributionParameterSource", "tChartHistoricalParametersWeibullShape",
+ "tChartHistoricalParametersScale", "report", "reportMetaData",
+ "reportTitle", "reportTitleText", "reportChartName", "reportChartNameText", "reportSubtitle",
+ "reportSubtitleText", "reportMeasurementName", "reportMeasurementNameText", "reportFootnote",
+ "reportFootnoteText", "reportLocation", "reportLocationText", "reportDate", "reportDateText",
+ "reportPerformedBy", "reportPerformedByText", "reportPrintDate", "reportPrintDateText"))
# Plot meta data
if (options[["reportTitle"]] ) {
@@ -234,7 +244,9 @@ rareEventCharts <- function(jaspResults, dataset, options) {
intervalType = c("days", "hours", "minutes", "opportunities"),
options, ready) {
plot <- createJaspPlot(title = gettext("G chart"), width = 1200, height = 500)
- plot$dependOn(c(""))
+ plot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
+ "dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat",
+ "gChart", "gChartProportionSource", "gChartHistoricalProportion", "report"))
if (!ready)
return(plot)
@@ -255,7 +267,10 @@ rareEventCharts <- function(jaspResults, dataset, options) {
intervalType = c("days", "hours", "minutes", "opportunities"),
options, ready) {
plot <- createJaspPlot(title = gettext("T chart"), width = 1200, height = 500)
- plot$dependOn(c(""))
+ plot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
+ "dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat", "tChart",
+ "tChartDistribution", "tChartDistributionParameterSource", "tChartHistoricalParametersWeibullShape",
+ "tChartHistoricalParametersScale", "report"))
if (!ready)
return(plot)
From a24931c0b6095d850829561b049ac866d1132eff Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Thu, 22 Aug 2024 18:49:05 +0200
Subject: [PATCH 12/25] Help file time weighted charts
---
inst/help/rareEventCharts.md | 73 +++++++++++++++++++++++++++++
inst/help/timeWeightedCharts.md | 83 +++++++++++++++++++++++++++++++++
2 files changed, 156 insertions(+)
create mode 100644 inst/help/rareEventCharts.md
create mode 100644 inst/help/timeWeightedCharts.md
diff --git a/inst/help/rareEventCharts.md b/inst/help/rareEventCharts.md
new file mode 100644
index 00000000..c7e711b7
--- /dev/null
+++ b/inst/help/rareEventCharts.md
@@ -0,0 +1,73 @@
+Attribute Charts
+==========================
+
+A Shewhart control chart is a graph used to study how a process changes over time. The obtained measurements can be either variables or attributes data, and subgroups are taken from the process at regular intervals. From each subgroup one or more statistical measures (such as average, dispersion, or proportion) are plotted in time order. Each chart always has a central line usually the average of the subgroup statistic or may be based on past experience, if the process is in a state of statistical control. The control chart has two statistically determined boundaries, one on either side of the central line, which are called the upper control limit (UCL) and the lower control limit (LCL). They are typically based on and placed at a distance of three times the standard deviation of the statistic being plotted. By comparing current data to these lines, conclusions can be drawn about whether the process variation is consistent (i.e., in control) or is unpredictable (i.e., out of control, and affected by special causes of variation). Control charts for variables data are always used in pairs. The top chart monitors the averages i.e., the centring of the data from the process. The bottom chart monitors the ranges i.e., the spread of the distribution. Control charts for attributes data consist of a single chart. Attributes data represent observations obtained by noting the presence or absence of some characteristic (attributes) in each of the items in the subgroup under consideration, then counting how many items do or do not possess the attribute, or how many such events occur in the item, group or area. Attributes data are generally rapid and inexpensive to obtain and often do not require specialised collection skills.
+
+The assumed distribution for attributes data has only one independent parameter, the average level. The p and np control charts are based on the binomial distribution (for defectives), while the u and c control charts are based on the Poisson distribution (for defects).There are many types of count based data that cannot be characterised by either a binomial (p and np) or a Poisson (u and c) distribution. When such data are placed on p, np, u, or c control charts the limits based on these models would be wrong. The Laney p′ (p prime) and u′ (u prime) charts are used to monitor attributes data if the sample sizes are variable and often very large. In such cases, it is common for the average proportion or rate to vary over the sampling period, a phenomenon known as overdispersion. Overdispersion means the sample-to-sample variation (i.e., the between sample variation) is much larger than the variation within the sample. Underdispersion is the opposite.
+
+Unlike the attributes control charts, the X-mR control chart makes no assumptions about the relationship between the location and the dispersion parameter. It directly measures the location with the average and the dispersion with the moving ranges. Thus, while the p, np, u, and c control charts use “theoretical” limits, the X-mR control chart uses “empirical” limits. X-mR control charts are used if the sample sizes are reasonable constant. Laney control charts are used if sample sizes vary; if the sample size is constant the Laney control chart is exactly the same as the X mR control chart.
+
+
+## Assumptions
+-------
+The assumptions for attributes control charts are:
+- p/np control chart are used if the observed data are approximately binomial distributed;
+- u/c control chart are used if the observed data are approximately Poisson distributed;
+- np/c control chart: the subgroup size used for data collection is constant;
+- p/u control chart: the subgroup size used for data collection is either variable or constant;
+- Laney p'/u': the observed data cannot be modelled by either a binomial or a Poisson distribution and the subgroup size is variable.
+
+## Input
+-------
+### Assignment Box
+- Defectives/Defects: the number of observations collected from a process that do or do not possess the attribute.
+- Sample: sample size of each observation.
+
+## Output
+-------
+### Charts
+Defectives charts: Defectives charts are used for products that are either defective or not defective (binary).
+ - p chart, which charts the proportion of non-conforming (defective) products, rejects or unacceptable outcomes, or conforming/accepted items in each subgroup.
+ - np chart, which charts the number of non-conforming (defective) products or only the conforming items in each subgroup.
+ - Laney p' chart, which charts the variation proportion of non-conforming (defective) products in each subgroup with adjusted control limits.
+
+Defects charts: Defects charts are used for products that have multiple defects per unit (the possible occurrences could be infinite).
+ - u chart, which charts the proportion of defects or non-conformities in each subgroup. Subgroup size is variable.
+ - chart, which charts the number of defects or non-conformities in each subgroup. Subgroup size is constant.
+ - Laney u' chart, which charts the variation proportion of defects or non-conformities in products in each subgroup with adjusted control limits.
+
+X-mR chart, which charts the process values (individuals) and moving range (mR) over time.
+
+
+### Out-of-control Signals
+-------
+ To indicate special cause variation the following unnatural patterns are used:
+
+- Signal 1: One point beyond the control limits (sporadic issue). One point more than three standard deviations from the central line equivalent to violation of UCL or LCL.
+- Signal 2: Seven consecutive points above or below the central line (mean shift). Seven points in a row on same side of centre line equivalent to a run above or below centre line.
+- Signal 3: A run up or down of seven consecutive points (trend). Seven points in a row all increasing or all decreasing equivalent to a run downward or upward.
+- Signal 4: Two out of three consecutive points beyond the warning (two sigma) limits (increasing variation).
+- Signal 5:Hugging the central line, this is indicated when 15 consecutive points are within the one sigma limits (reducing variation).
+- Signal 6: Eight consecutive points are beyond the one sigma limits, regardless of which side of the central line (bimodal distribution).
+
+The lack of control in both average and variation charts is generally found in the initial stages of setting up of control charts, sometimes called Phase 1 control charts. Using all six signals is only applicable for the average chart during Phase 1 when the control chart is used as an analysis tool. The first three signals are used always, for variables as well as attributes control charts.
+
+In the case that the data of the individual and moving Range chart (X-mR chart) violate the pre assumption (normality and independently distributed) only signal 1 is applied. Autocorrelation is an indication of that.
+
+
+## References
+-------
+
+- Duncan, A.J. (1986), *Quality control and industrial statistics*, Richard D. Irwin, Inc.
+- Automotive Industry Action Group, *Statistical Process Control – Reference Manual* (July 2005, 2nd Edition)
+- SKF Quality Techniques, Klerx, R., Dodson, B., and Dumont, D., QT 1 – *Process capability studies* (PUB GQ/P9 10347/1 EN – December 2021)
+- SKF Quality Techniques, Dodson, B., Lynch, D., Weidenbacher, M., and Klerx, R., QT 2 – *Statistical process control* (PUB GQS/P9 18343 EN – April 2019)
+- International Organization for Standardization, *Control charts – Part 2: Shewhart control charts*, ISO 7870-2:2023 (E)
+
+
+## R Packages
+-------
+- ggplot2
+- qcc
+- jaspGraphs
+- ggrepel
diff --git a/inst/help/timeWeightedCharts.md b/inst/help/timeWeightedCharts.md
new file mode 100644
index 00000000..d8837193
--- /dev/null
+++ b/inst/help/timeWeightedCharts.md
@@ -0,0 +1,83 @@
+Time Weighted Charts
+==========================
+Two very effective alternatives to the Shewhart control chart may be used when small process shifts are of interest: the cumulative sum (CUSUM) control chart, and the exponentially weighted moving average (EWMA) control chart. CUSUM and EWMA control charts are excellent alternatives to the Shewhart control chart for phase II process monitoring situations. Collectively, the CUSUM and EWMA control chart are sometimes called time-weighted control charts.
+
+The cumulative sum chart and the exponentially weighted moving average (EWMA) charts are also monitors the mean of the process, but the basic difference is unlike X-bar charts they consider the previous value means at each point. Moreover, these charts are considered as a reliable estimate when correct standard deviation exists.
+
+## CUSUM control chart
+--------
+### Features of cumulative sum (CUSUM) control charts
+--------
+A CUSUM control chart is essentially a running total of deviations from some preselected reference value. The mean of any group of consecutive values is represented visually by the current slope of the graph. The basic advantage of a CUSUM chart is that it is more sensitive to small shifts of the process mean when compared to the Shewhart control charts.
+
+### When to use
+--------
+- The false alarm rate of a Shewhart control chart is too high.
+- The process rate is so high that false alarms are hardly acceptable.
+- Small process changes (less than one sigma) must be detected quickly.
+- Automation is available to update the chart in real time.
+
+In general, the underlying distribution is supposed to be normal, but CUSUM control charts can be used as well for binomial and Poisson distributions for modelling nonconformities and fraction nonconforming.
+
+### Assumptions
+--------
+The basic assumptions for a CUSUM control chart are:
+
+1. the measurements must be sequential or time sequenced;
+2. the measurements are independent of each other – one data point does not determine or impact the next data point;
+3. the measurements are approximately normally distributed, or the sample size of each plotted point is large enough so the average yields an approximate normal distribution.
+
+## Input
+--------
+
+### Assignment box
+--------
+- Measurements: the observations collected from a process.
+- Subgroups ("Column" option): the subgroup that each observation is assigned to, if all observations are in the same column.
+- Timestamp ("Row" option): optinal subgroup names for each row of observations, that are used as x-axis labels.
+- Stages: a column to split the analysis into multiple parts by assigning a stage to each subgroup. In "row" format, only one stage per subgroup is possible. In "column" format, only the first specified stage for each subgroup is considered.
+
+### Specifying subgroups in "Column" format
+-------
+- Through grouping variable: a single-column subgroup variable is specified that assigns each observation to a subgroup.
+ - Grouping method: if identical values of the subgroup variable are not adjacent in the dataset (top to bottom), there are two methods to handle this. If the grouping method is "Subgroup value change", only series of identical and adjacent subgroup values form a group. If the grouping method is "Same subgroup value", all identical subgroup values form a group, regardless of their adjacency. For instance, if the values of the subgroup variable are [A, A, B, B, A], the method "Subgroup value change" would yield three groups: [A, A], [B, B] and [A]. The method "Same subgroup value" would yield two groups, [A, A, A] and [B, B].
+- Subgroup size: the observations are assigned in the order of appearence (from top to bottom) to subgroups of the specified size. If the number of observations cannot be equally divided into subgroups of the specified size, the last subgroup has the size of the remaining observations.
+
+### Chart options
+--------
+- Target: Value to use as a target
+
+- Average run length (ARL): The number of plotted points until special cause variation is signalled is the average run length (ARL). It is a function of the process mean shift.
+
+- Number of standard deviations (*h*): Standardised decision interval
+
+- Shift size (*k*): *k* is usually called the reference value (or the allowance, or the slack value), and it is often chosen about halfway between the target (µ0) and the out‑of‑control value of the mean (µ1) that we are interested in detecting quickly.
+
+The proper selection of these two parameters (*h* and *k*) is quite important, as it has substantial impact on the performance of the CUSUM. Calculate the reference value or allowable slack, since CUSUM chart is used to monitor the small shifts, generally 0.5 to 1 σ will be considered. *k* = 0.5 σ. Compute decision interval *h*, generally ± 4 σ will be considered (some place ± 5 σ also be used).
+
+## Recommendations for CUSUM design
+--------
+The tabular CUSUM is designed by choosing values for the reference value *k* and the decision interval *h*. It is usually recommended that these parameters be selected to provide good average run length performance. There have been many analytical studies of CUSUM ARL performance. Based on these studies, we may give some general recommendations for selecting *h* and *k*. Define H = *h* σ and K = *k* σ, where σ is the standard deviation of the sample variable used in forming the CUSUM. Using *h* = 4 or *h* = 5 and *k* = ½ will generally provide a CUSUM that has good ARL properties against a shift of about 1 σ in the process mean.
+
+## Output
+--------
+### Charts
+--------
+CUSUM statistics are cumulative deviations from the target, or nominal.
+
+Graphical display for the tabular CUSUM. These charts are sometimes called CUSUM status charts. They are constructed by plotting C+i and C−i versus the sample number.
+
+## References
+--------
+- Page, E.S. (1954), *Continuous inspection schemes*, Biometrika, Vol. 41, No. 1-2, pp. 100-115
+- Roberts, S.W. (1959), *Control chart tests based on geometric moving averages*, Technometrics, Vol. 1, No. 3, pp. 239-250
+- SKF Quality Techniques, Dodson, B., Lynch, D., Weidenbacher, M., and Klerx, R., *QT 2 – Statistical process control* (PUB GQS/P9 18343 EN – April 2019)
+- International Organization for Standardization, *Control charts – Part 4: Cumulative sum charts*, ISO 7870-4:2021 (E)
+- Montgomery D. C. (2013), *Introduction to statistical quality control (7th Ed.)*, John Wiley & Sons, Inc , Hoboken (NJ)
+
+## R Packages
+-------
+- ggplot2
+- qcc
+- jaspGraphs
+- ggrepel
From 0a4bc6fae235961fc9c373637ffb3f720f1b7883 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Fri, 23 Aug 2024 15:34:51 +0200
Subject: [PATCH 13/25] Rare event charts help file
---
inst/help/rareEventCharts.md | 92 +++++++++++++++---------------------
inst/qml/rareEventCharts.qml | 2 +-
2 files changed, 39 insertions(+), 55 deletions(-)
diff --git a/inst/help/rareEventCharts.md b/inst/help/rareEventCharts.md
index c7e711b7..337355fe 100644
--- a/inst/help/rareEventCharts.md
+++ b/inst/help/rareEventCharts.md
@@ -1,69 +1,53 @@
-Attribute Charts
+Rare Event Charts
==========================
+Two very effective alternatives to the Shewhart control chart may be used when monitoring rare events or when small process shifts are of interest: the g chart and the t chart. These charts are particularly useful for situations where events occur infrequently and traditional Shewhart control charts may not be as effective. The g and t charts belong to the broader category of rare event control charts and are designed to handle scenarios where monitoring time between events or the number of opportunities between events is more meaningful than tracking continuous data points.
-A Shewhart control chart is a graph used to study how a process changes over time. The obtained measurements can be either variables or attributes data, and subgroups are taken from the process at regular intervals. From each subgroup one or more statistical measures (such as average, dispersion, or proportion) are plotted in time order. Each chart always has a central line usually the average of the subgroup statistic or may be based on past experience, if the process is in a state of statistical control. The control chart has two statistically determined boundaries, one on either side of the central line, which are called the upper control limit (UCL) and the lower control limit (LCL). They are typically based on and placed at a distance of three times the standard deviation of the statistic being plotted. By comparing current data to these lines, conclusions can be drawn about whether the process variation is consistent (i.e., in control) or is unpredictable (i.e., out of control, and affected by special causes of variation). Control charts for variables data are always used in pairs. The top chart monitors the averages i.e., the centring of the data from the process. The bottom chart monitors the ranges i.e., the spread of the distribution. Control charts for attributes data consist of a single chart. Attributes data represent observations obtained by noting the presence or absence of some characteristic (attributes) in each of the items in the subgroup under consideration, then counting how many items do or do not possess the attribute, or how many such events occur in the item, group or area. Attributes data are generally rapid and inexpensive to obtain and often do not require specialised collection skills.
+- **G Chart**: Used to monitor the number of opportunities (such as units produced or time intervals) between rare events. It is particularly effective in processes where defects are infrequent and the main interest is in the distance between these occurrences.
+
+- **T Chart**: Used to monitor the time between rare events. This chart is suitable for processes where time intervals are of interest, such as monitoring the time between machine breakdowns, customer complaints, or other rare events.
-The assumed distribution for attributes data has only one independent parameter, the average level. The p and np control charts are based on the binomial distribution (for defectives), while the u and c control charts are based on the Poisson distribution (for defects).There are many types of count based data that cannot be characterised by either a binomial (p and np) or a Poisson (u and c) distribution. When such data are placed on p, np, u, or c control charts the limits based on these models would be wrong. The Laney p′ (p prime) and u′ (u prime) charts are used to monitor attributes data if the sample sizes are variable and often very large. In such cases, it is common for the average proportion or rate to vary over the sampling period, a phenomenon known as overdispersion. Overdispersion means the sample-to-sample variation (i.e., the between sample variation) is much larger than the variation within the sample. Underdispersion is the opposite.
-
-Unlike the attributes control charts, the X-mR control chart makes no assumptions about the relationship between the location and the dispersion parameter. It directly measures the location with the average and the dispersion with the moving ranges. Thus, while the p, np, u, and c control charts use “theoretical” limits, the X-mR control chart uses “empirical” limits. X-mR control charts are used if the sample sizes are reasonable constant. Laney control charts are used if sample sizes vary; if the sample size is constant the Laney control chart is exactly the same as the X mR control chart.
+The g and t charts are essential tools in Statistical Quality Control (SQC) when dealing with rare events, providing a more sensitive approach to detect shifts in processes where events do not occur frequently enough for traditional methods to be effective.
+## Input
+--------
-## Assumptions
--------
-The assumptions for attributes control charts are:
-- p/np control chart are used if the observed data are approximately binomial distributed;
-- u/c control chart are used if the observed data are approximately Poisson distributed;
-- np/c control chart: the subgroup size used for data collection is constant;
-- p/u control chart: the subgroup size used for data collection is either variable or constant;
-- Laney p'/u': the observed data cannot be modelled by either a binomial or a Poisson distribution and the subgroup size is variable.
+### Assignment box
+--------
+- Variable: either the timepoint when the event took place or the intervals beetween events.
+- Stages: a column to split the analysis into multiple parts by assigning a stage to each subgroup.
-## Input
+### Data type
-------
-### Assignment Box
-- Defectives/Defects: the number of observations collected from a process that do or do not possess the attribute.
-- Sample: sample size of each observation.
+- Date/time: if your data specify a timepoint at which the event took place.
+ - Structure: the structure of your timepoints, either only dates (e.g., 01/12), only time (e.g., 12:30), date and time (e.g., 01/12 12:30), or time and date (e.g., 12:30 01/12).
+ - Date format: the date format in your data, where D = day, M = month, Y = year, thus, DMY = Day Month Year, for example 30/12/2024. The symbol used as separator does not matter.
+ - Time format: the time format in your data, where H = hour, M = minute, S = second, thus, HMS = Hour Minute Second, for example 01:02:03. The symbol used as separator does not matter. Ip and IpM refer to integer hours and integer hours with minutes, for example, 12pm or 12:30pm.
+- Interval between events: if your data specify the time or number of opportunities between events.
+ - Interval type: the unit in which your interval is expressed. Opportunities, hours (decimal) and days (decimal) are read as is, where times are treated as decimal, so 1.25 hours = 1 hour 15 minutes. If you select time as interval type, you will need to specify the time format, as explained above.
+
+### Chart options
+--------
+- G chart: select to display a G chart.
+ - Proportion estimated from data: the proportion is calculated from the data and used for all other calculations of the G chart.
+ - Proportion historical: a historical proportion value is used for all other calculations of the G chart.
+
+- T chart: select to display a T chart.
+ - Based on Weibull/exponential distribution: the distribution function that used to calculate the control limits in the T chart.
+ - Distribution parameters estimed from data: the distribution parameters for the Weibull/exponentital distribution are calculated from the data (best fit) and used for all other calculations of the T chart.
+ - Distribution parameters historical: historical distribution parameters for the Weibull/exponentital distribution are provided and used for all other calculations of the T chart.
## Output
--------
+--------
### Charts
-Defectives charts: Defectives charts are used for products that are either defective or not defective (binary).
- - p chart, which charts the proportion of non-conforming (defective) products, rejects or unacceptable outcomes, or conforming/accepted items in each subgroup.
- - np chart, which charts the number of non-conforming (defective) products or only the conforming items in each subgroup.
- - Laney p' chart, which charts the variation proportion of non-conforming (defective) products in each subgroup with adjusted control limits.
-
-Defects charts: Defects charts are used for products that have multiple defects per unit (the possible occurrences could be infinite).
- - u chart, which charts the proportion of defects or non-conformities in each subgroup. Subgroup size is variable.
- - chart, which charts the number of defects or non-conformities in each subgroup. Subgroup size is constant.
- - Laney u' chart, which charts the variation proportion of defects or non-conformities in products in each subgroup with adjusted control limits.
-
-X-mR chart, which charts the process values (individuals) and moving range (mR) over time.
-
-
-### Out-of-control Signals
--------
- To indicate special cause variation the following unnatural patterns are used:
-
-- Signal 1: One point beyond the control limits (sporadic issue). One point more than three standard deviations from the central line equivalent to violation of UCL or LCL.
-- Signal 2: Seven consecutive points above or below the central line (mean shift). Seven points in a row on same side of centre line equivalent to a run above or below centre line.
-- Signal 3: A run up or down of seven consecutive points (trend). Seven points in a row all increasing or all decreasing equivalent to a run downward or upward.
-- Signal 4: Two out of three consecutive points beyond the warning (two sigma) limits (increasing variation).
-- Signal 5:Hugging the central line, this is indicated when 15 consecutive points are within the one sigma limits (reducing variation).
-- Signal 6: Eight consecutive points are beyond the one sigma limits, regardless of which side of the central line (bimodal distribution).
-
-The lack of control in both average and variation charts is generally found in the initial stages of setting up of control charts, sometimes called Phase 1 control charts. Using all six signals is only applicable for the average chart during Phase 1 when the control chart is used as an analysis tool. The first three signals are used always, for variables as well as attributes control charts.
-
-In the case that the data of the individual and moving Range chart (X-mR chart) violate the pre assumption (normality and independently distributed) only signal 1 is applied. Autocorrelation is an indication of that.
-
-
-## References
--------
+--------
+- G chart: A graphical representation showing the number of time units or opportunities between rare events, highlighting any deviations from expected intervals that might indicate a process shift.
+
+- T chart: A graphical representation showing the time intervals between rare events, allowing for easy identification of shifts in the process that could signify increased risk or process degradation.
-- Duncan, A.J. (1986), *Quality control and industrial statistics*, Richard D. Irwin, Inc.
-- Automotive Industry Action Group, *Statistical Process Control – Reference Manual* (July 2005, 2nd Edition)
-- SKF Quality Techniques, Klerx, R., Dodson, B., and Dumont, D., QT 1 – *Process capability studies* (PUB GQ/P9 10347/1 EN – December 2021)
-- SKF Quality Techniques, Dodson, B., Lynch, D., Weidenbacher, M., and Klerx, R., QT 2 – *Statistical process control* (PUB GQS/P9 18343 EN – April 2019)
-- International Organization for Standardization, *Control charts – Part 2: Shewhart control charts*, ISO 7870-2:2023 (E)
+## References
+--------
+- Montgomery, D. C. (2009). *Introduction to Statistical Quality Control*. John Wiley & Sons.
## R Packages
-------
diff --git a/inst/qml/rareEventCharts.qml b/inst/qml/rareEventCharts.qml
index 97f99ba0..261bf74a 100644
--- a/inst/qml/rareEventCharts.qml
+++ b/inst/qml/rareEventCharts.qml
@@ -122,7 +122,7 @@ Form
name: "dataTypeIntervalTimeFormat"
id: dataTypeIntervalTimeFormat
label: qsTr("Time format")
- visible: dataTypeIntervalType.value == "dataTypeIntervalTypeTime"
+ visible: dataTypeIntervalType.value == "time"
values:
[
{ label: qsTr("H"), value: "H"},
From d3b7f769aaa9b8d76b0a6383c4f403673efaad8b Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Fri, 23 Aug 2024 16:41:58 +0200
Subject: [PATCH 14/25] Setup for time weighted and rare event chart unit tests
---
.../rareEventCharts/rareEventCharts.csv | 38 ++++++
.../timeWeightedCharts/cumsumChartLong.csv | 126 ++++++++++++++++++
.../timeWeightedCharts/cumsumChartWide.csv | 20 +++
.../timeWeightedCharts/ewmaChartLong.csv | 36 +++++
tests/testthat/test-rareEventCharts.R | 2 +
tests/testthat/test-timeWeightedCharts.R | 2 +
6 files changed, 224 insertions(+)
create mode 100644 tests/testthat/datasets/rareEventCharts/rareEventCharts.csv
create mode 100644 tests/testthat/datasets/timeWeightedCharts/cumsumChartLong.csv
create mode 100644 tests/testthat/datasets/timeWeightedCharts/cumsumChartWide.csv
create mode 100644 tests/testthat/datasets/timeWeightedCharts/ewmaChartLong.csv
create mode 100644 tests/testthat/test-rareEventCharts.R
create mode 100644 tests/testthat/test-timeWeightedCharts.R
diff --git a/tests/testthat/datasets/rareEventCharts/rareEventCharts.csv b/tests/testthat/datasets/rareEventCharts/rareEventCharts.csv
new file mode 100644
index 00000000..6cf54f68
--- /dev/null
+++ b/tests/testthat/datasets/rareEventCharts/rareEventCharts.csv
@@ -0,0 +1,38 @@
+"","MD","MDHM","DM","DMY","MDY","YMD","opportunities","decimalTime","decimalDays","stages"
+"1","2/3","1/2 12:00","23/02","23/02/21","02/23/21","21/02/23",94,6.63308813469484,4.02573342202231,1
+"2","2/17","1/10 3:10","24/02","24/02/23","02/24/23","23/02/24",6,12.3823835584335,8.80246541230008,1
+"3","2/28","1/17 11:33","20/08","20/08/21","08/20/21","21/08/20",72,7.97060060547665,3.64091864787042,1
+"4","4/5","1/21 4:02","13/07","13/07/23","07/13/23","23/07/13",86,18.8991916039959,2.88239280693233,1
+"5","4/13","1/21 9:00","05/10","05/10/23","10/05/23","23/10/05",86,5.51485472358763,1.70645235106349,1
+"6","4/26","1/29 14:59","07/03","07/03/20","03/07/20","20/03/07",39,25.9093233430758,1.72171746380627,1
+"7","4/29","2/4 7:01","10/02","10/02/22","02/10/22","22/02/10",31,22.3970401240513,4.8204260552302,1
+"8","5/22","2/6 8:17","26/07","26/07/23","07/26/23","23/07/26",81,20.048539491836,2.52964928513393,1
+"9","5/26","2/7 20:06","16/03","16/03/22","03/16/22","22/03/16",50,18.5405361978337,2.1625478961505,1
+"10","6/3","2/9 4:58","28/10","28/10/21","10/28/21","21/10/28",34,11.1671418067999,6.74376388080418,1
+"11","6/26","2/9 22:53","28/10","28/10/23","10/28/23","23/10/28",4,15.8950705756433,0.476636274252087,1
+"12","7/10","2/11 3:26","23/10","23/10/21","10/23/21","21/10/23",13,26.2404702859931,7.00853087473661,1
+"13","7/15","2/14 0:44","16/09","16/09/22","09/16/22","22/09/16",69,17.4525029934011,3.51888638455421,1
+"14","7/16","2/14 12:20","16/04","16/04/22","04/16/22","22/04/16",25,25.1930329436436,4.08943997928873,2
+"15","7/23","2/19 8:31","30/05","30/05/20","05/30/20","20/05/30",52,9.3734449474141,8.20951323956251,2
+"16","7/31","2/19 11:18","06/08","06/08/23","08/06/23","23/08/06",22,21.2487096665427,9.18857348151505,2
+"17","8/6","2/20 3:30","25/12","25/12/20","12/25/20","20/12/25",89,7.95053418260068,2.82528330106288,2
+"18","8/7","2/21 22:27","02/03","02/03/20","03/02/20","20/03/02",32,17.8302958211862,9.61104793706909,2
+"19","8/25","2/25 17:52","23/04","23/04/21","04/23/21","21/04/23",25,14.4386940146796,7.28394428268075,2
+"20","8/27","2/28 14:32","25/10","25/10/23","10/25/23","23/10/25",87,7.9509819438681,6.86375082004815,2
+"21","9/7","3/5 11:39","22/07","22/07/23","07/22/23","23/07/22",35,16.9377130432986,0.528439427725971,2
+"22","9/11","3/6 9:16","08/10","08/10/22","10/08/22","22/10/08",40,27.3956466908567,3.95220134640113,2
+"23","9/23","3/9 6:13","24/07","24/07/22","07/24/22","22/07/24",30,27.0562316849828,4.77845379849896,2
+"24","9/28","3/10 16:43","22/12","22/12/23","12/22/23","23/12/22",12,8.22499864501879,5.6025326368399,2
+"25","10/4","3/21 10:23","15/08","15/08/22","08/15/22","22/08/15",31,9.64448269223794,6.98261594865471,2
+"26","10/14","3/23 14:07","31/10","31/10/22","10/31/22","22/10/31",30,29.5692265313119,9.15683538420126,2
+"27","10/26","3/28 18:31","05/03","05/03/22","03/05/22","22/03/05",64,18.5997993056662,6.18351227371022,3
+"28","10/26","3/29 8:43","17/05","17/05/22","05/17/22","22/05/17",99,28.1194226746447,4.28421508753672,3
+"29","10/26","4/10 3:27","26/02","26/02/21","02/26/21","21/02/26",14,13.9959810697474,5.4208036721684,3
+"30","10/26","4/11 23:21","02/08","02/08/20","08/02/20","20/08/02",93,12.20497779781,0.58478488586843,3
+"31","10/26","4/23 20:30","07/11","07/11/23","11/07/23","23/11/07",96,19.7769097262062,2.60856857057661,3
+"32","10/28","4/29 16:24","10/08","10/08/23","08/10/23","23/08/10",71,4.57039850531146,3.97151953307912,3
+"33","11/5","5/4 4:16","05/10","05/10/22","10/05/22","22/10/05",67,17.1860117465258,1.97744736680761,3
+"34","11/11","5/11 15:15","07/03","07/03/23","03/07/23","23/03/07",23,7.161780805327,8.3192756283097,3
+"35","11/17","5/21 17:34","05/02","05/02/20","02/05/20","20/02/05",79,28.8707680930384,1.52887222822756,3
+"36","11/30","6/4 1:36","28/11","28/11/21","11/28/21","21/11/28",85,18.0409717792645,8.03418542025611,3
+"37","12/16","6/10 8:59","12/01","12/01/23","01/12/23","23/01/12",37,15.4508918174542,5.46826156554744,3
diff --git a/tests/testthat/datasets/timeWeightedCharts/cumsumChartLong.csv b/tests/testthat/datasets/timeWeightedCharts/cumsumChartLong.csv
new file mode 100644
index 00000000..9786d037
--- /dev/null
+++ b/tests/testthat/datasets/timeWeightedCharts/cumsumChartLong.csv
@@ -0,0 +1,126 @@
+Measurement,Date,Stage
+-0.44025,Sep/28,1
+5.90038,Sep/28,1
+2.08965,Sep/28,1
+0.09998,Sep/28,1
+2.01594,Sep/28,1
+4.83012,Sep/29,1
+3.78732,Sep/29,1
+4.99821,Sep/29,1
+6.91169,Sep/29,1
+1.93847,Sep/29,1
+-3.09907,Sep/30,1
+-3.18827,Sep/30,1
+5.28978,Sep/30,1
+0.56182,Sep/30,1
+-3.1896,Sep/30,1
+7.93177,10/Apr,1
+3.72692,10/Apr,1
+3.83152,10/Apr,1
+-2.17454,10/Apr,1
+2.81598,10/Apr,1
+4.52023,10/May,1
+3.95372,10/May,1
+7.99326,10/May,1
+4.98677,10/May,1
+-2.03427,10/May,1
+3.89134,10/Jun,1
+1.99825,10/Jun,1
+0.01028,10/Jun,1
+-0.24542,10/Jun,1
+2.08175,10/Jun,1
+-4.86937,10/Jul,1
+-2.69206,10/Jul,1
+-3.02947,10/Jul,1
+2.99932,10/Jul,1
+3.50123,10/Jul,1
+-1.99506,10/Aug,1
+-1.62939,10/Aug,1
+2.14395,10/Aug,1
+-1.90688,10/Aug,1
+8.02322,10/Aug,1
+4.75466,10/Nov,1
+1.1424,10/Nov,1
+0.9379,10/Nov,1
+-7.30286,10/Nov,1
+-5.22516,10/Nov,1
+-4.06527,10/Dec,1
+-1.91314,10/Dec,1
+2.0459,10/Dec,1
+4.93029,10/Dec,1
+0.03095,10/Dec,1
+-2.80363,Oct/13,2
+-3.12681,Oct/13,2
+-4.57793,Oct/13,2
+-3.17924,Oct/13,2
+-2.44537,Oct/13,2
+1.36225,Oct/14,2
+0.92825,Oct/14,2
+-0.24151,Oct/14,2
+-0.83762,Oct/14,2
+-1.99674,Oct/14,2
+4.90024,Oct/15,2
+1.28079,Oct/15,2
+2.87917,Oct/15,2
+1.83867,Oct/15,2
+-0.75614,Oct/15,2
+3.72977,Oct/18,2
+3.77141,Oct/18,2
+-4.04994,Oct/18,2
+3.89824,Oct/18,2
+1.76868,Oct/18,2
+2.2731,Oct/18,2
+-3.82297,Oct/18,2
+-2.26821,Oct/18,2
+-2.07973,Oct/18,2
+0.01739,Oct/18,2
+3.71309,Oct/19,2
+1.72573,Oct/19,2
+3.07264,Oct/19,2
+0.15676,Oct/19,2
+-0.05666,Oct/19,2
+3.81341,Oct/19,2
+-3.78952,Oct/19,2
+-3.81635,Oct/19,2
+-4.8882,Oct/19,2
+-3.24534,Oct/19,2
+-0.27272,Oct/20,3
+-4.33095,Oct/20,3
+-1.83547,Oct/20,3
+-3.98876,Oct/20,3
+-4.97431,Oct/20,3
+-5.1405,Oct/20,3
+-0.10379,Oct/20,3
+2.21033,Oct/20,3
+5.13041,Oct/20,3
+-1.89455,Oct/20,3
+0.95119,Oct/21,3
+-5.15414,Oct/21,3
+4.82794,Oct/21,3
+0.13001,Oct/21,3
+-0.09911,Oct/21,3
+-1.15453,Oct/21,3
+2.29868,Oct/21,3
+5.15847,Oct/21,3
+0.08558,Oct/21,3
+-3.09574,Oct/21,3
+5.16744,Oct/22,3
+0.29748,Oct/22,3
+-4.66858,Oct/22,3
+-2.13787,Oct/22,3
+-0.0045,Oct/22,3
+0.18096,Oct/22,3
+4.30247,Oct/22,3
+-2.21708,Oct/22,3
+7.17603,Oct/22,3
+5.86525,Oct/22,3
+0.95699,Oct/25,3
+-4.03441,Oct/25,3
+-2.05086,Oct/25,3
+-3.10319,Oct/25,3
+-1.83001,Oct/25,3
+5.03945,Oct/25,3
+1.96583,Oct/25,3
+-0.21026,Oct/25,3
+0.27517,Oct/25,3
+-5.32797,Oct/25,3
diff --git a/tests/testthat/datasets/timeWeightedCharts/cumsumChartWide.csv b/tests/testthat/datasets/timeWeightedCharts/cumsumChartWide.csv
new file mode 100644
index 00000000..93ac9a78
--- /dev/null
+++ b/tests/testthat/datasets/timeWeightedCharts/cumsumChartWide.csv
@@ -0,0 +1,20 @@
+"","Date","Stage","1","2","3","4","5","6","7","8","9","10"
+"1","Sep/28",1,-0.44025,5.90038,2.08965,0.09998,2.01594,NA,NA,NA,NA,NA
+"2","Sep/29",1,4.83012,3.78732,4.99821,6.91169,1.93847,NA,NA,NA,NA,NA
+"3","Sep/30",1,-3.09907,-3.18827,5.28978,0.56182,-3.1896,NA,NA,NA,NA,NA
+"4","10/Apr",1,7.93177,3.72692,3.83152,-2.17454,2.81598,NA,NA,NA,NA,NA
+"5","10/May",1,4.52023,3.95372,7.99326,4.98677,-2.03427,NA,NA,NA,NA,NA
+"6","10/Jun",1,3.89134,1.99825,0.01028,-0.24542,2.08175,NA,NA,NA,NA,NA
+"7","10/Jul",1,-4.86937,-2.69206,-3.02947,2.99932,3.50123,NA,NA,NA,NA,NA
+"8","10/Aug",1,-1.99506,-1.62939,2.14395,-1.90688,8.02322,NA,NA,NA,NA,NA
+"9","10/Nov",1,4.75466,1.1424,0.9379,-7.30286,-5.22516,NA,NA,NA,NA,NA
+"10","10/Dec",1,-4.06527,-1.91314,2.0459,4.93029,0.03095,NA,NA,NA,NA,NA
+"11","Oct/13",2,-2.80363,-3.12681,-4.57793,-3.17924,-2.44537,NA,NA,NA,NA,NA
+"12","Oct/14",2,1.36225,0.92825,-0.24151,-0.83762,-1.99674,NA,NA,NA,NA,NA
+"13","Oct/15",2,4.90024,1.28079,2.87917,1.83867,-0.75614,NA,NA,NA,NA,NA
+"14","Oct/18",2,3.72977,3.77141,-4.04994,3.89824,1.76868,2.2731,-3.82297,-2.26821,-2.07973,0.01739
+"15","Oct/19",2,3.71309,1.72573,3.07264,0.15676,-0.05666,3.81341,-3.78952,-3.81635,-4.8882,-3.24534
+"16","Oct/20",3,-0.27272,-4.33095,-1.83547,-3.98876,-4.97431,-5.1405,-0.10379,2.21033,5.13041,-1.89455
+"17","Oct/21",3,0.95119,-5.15414,4.82794,0.13001,-0.09911,-1.15453,2.29868,5.15847,0.08558,-3.09574
+"18","Oct/22",3,5.16744,0.29748,-4.66858,-2.13787,-0.0045,0.18096,4.30247,-2.21708,7.17603,5.86525
+"19","Oct/25",3,0.95699,-4.03441,-2.05086,-3.10319,-1.83001,5.03945,1.96583,-0.21026,0.27517,-5.32797
diff --git a/tests/testthat/datasets/timeWeightedCharts/ewmaChartLong.csv b/tests/testthat/datasets/timeWeightedCharts/ewmaChartLong.csv
new file mode 100644
index 00000000..b6d43776
--- /dev/null
+++ b/tests/testthat/datasets/timeWeightedCharts/ewmaChartLong.csv
@@ -0,0 +1,36 @@
+Subgroup,Measurement,Stage
+1,9.687765221,1
+2,9.376965607,1
+3,10.82535018,1
+4,9.636838422,1
+5,10.40493918,1
+6,9.210301838,1
+7,10.7450633,1
+8,10.35468689,2
+9,10.09609676,2
+10,9.625591714,2
+11,10.31463762,2
+12,10.40390853,2
+13,11.01761469,2
+14,9.852254111,2
+15,9.748415565,2
+16,10.71510003,2
+17,9.781192369,2
+18,10.04083362,2
+19,9.485813674,3
+20,8.715005153,3
+21,9.907705807,3
+22,8.306911464,3
+23,10.49958488,3
+24,9.616518597,3
+25,9.542703852,3
+26,14.10973827,3
+27,10.28420997,3
+28,12.48279229,3
+29,10.874,3
+30,12.73937432,3
+31,11.28508093,3
+32,10.86900005,3
+33,11.32264938,3
+34,10.865,3
+35,10.992612,3
diff --git a/tests/testthat/test-rareEventCharts.R b/tests/testthat/test-rareEventCharts.R
new file mode 100644
index 00000000..5ceaea0c
--- /dev/null
+++ b/tests/testthat/test-rareEventCharts.R
@@ -0,0 +1,2 @@
+context("[Quality Control] Rare Event Charts")
+.numDecimals <- 2
diff --git a/tests/testthat/test-timeWeightedCharts.R b/tests/testthat/test-timeWeightedCharts.R
new file mode 100644
index 00000000..76712916
--- /dev/null
+++ b/tests/testthat/test-timeWeightedCharts.R
@@ -0,0 +1,2 @@
+context("[Quality Control] Time Weighted Charts")
+.numDecimals <- 2
From dd327f66a49d9c579cb19444cfc99e8ac3e2de32 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 4 Sep 2024 16:46:13 +0200
Subject: [PATCH 15/25] Start unit tests
---
inst/Description.qml | 2 +-
tests/testthat/test-timeWeightedCharts.R | 84 ++++++++++++++++++++++++
2 files changed, 85 insertions(+), 1 deletion(-)
diff --git a/inst/Description.qml b/inst/Description.qml
index 0d278304..7babc83f 100644
--- a/inst/Description.qml
+++ b/inst/Description.qml
@@ -26,7 +26,7 @@ Description
}
Analysis
{
- title: qsTr("Type 2 Gauge r&R Study")
+ title: qsTr("Type 2 and 3 Gauge r&R Study")
func: "msaGaugeRR"
}
Analysis
diff --git a/tests/testthat/test-timeWeightedCharts.R b/tests/testthat/test-timeWeightedCharts.R
index 76712916..b3df1ad6 100644
--- a/tests/testthat/test-timeWeightedCharts.R
+++ b/tests/testthat/test-timeWeightedCharts.R
@@ -1,2 +1,86 @@
context("[Quality Control] Time Weighted Charts")
.numDecimals <- 2
+
+# Long Format ####
+
+## Without Stages ####
+
+### CUSUM ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options, makeTests = T)
+
+### EWMA ####
+
+
+## With Stages ####
+
+### CUSUM ####
+
+### EWMA ####
+
+## Subgrouping Mechanisms ####
+
+### Grouping Variable ####
+
+#### Value Change ####
+
+##### CUSUM ####
+
+##### EWMA ####
+
+#### Same Value ####
+
+##### CUSUM ####
+
+##### EWMA ####
+
+### No Subgroups ####
+
+#### CUSUM ####
+
+#### EWMA ####
+
+## Plotting Options ####
+
+### Historical values ####
+
+#### CUSUM ####
+
+#### EWMA ####
+
+### Alternative SD Estimation ####
+
+#### CUSUM ####
+
+#### EWMA ####
+
+## Report ####
+
+# Wide Format ####
+
+## Without Stages ####
+
+### CUSUM ####
+
+## With Stages ####
+
+### CUSUM ####
+
+## Plotting Options ####
+
+### Historical values ####
+
+#### CUSUM ####
+
+### Alternative SD Estimation ####
+
+#### CUSUM ####
+
+
+## Report ####
From 429323718c989a7849a6a72bc5136694f7ea5ba8 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Fri, 6 Sep 2024 14:21:27 +0200
Subject: [PATCH 16/25] Fix for issue 2895
---
R/processCapabilityStudies.R | 7 +++++++
inst/qml/processCapabilityStudies.qml | 1 -
2 files changed, 7 insertions(+), 1 deletion(-)
diff --git a/R/processCapabilityStudies.R b/R/processCapabilityStudies.R
index c6c7272d..ba7c3e22 100644
--- a/R/processCapabilityStudies.R
+++ b/R/processCapabilityStudies.R
@@ -655,6 +655,13 @@ processCapabilityStudies <- function(jaspResults, dataset, options) {
xBreaks <- jaspGraphs::getPrettyAxisBreaks(c(plotData[["x"]], min(plotData[["x"]]) - 1 * sdo, max(plotData[["x"]]) + 1 * sdo), min.n = 4)
xLimits <- range(xBreaks)
+ if (options[["lowerSpecificationLimit"]] && options[["processCapabilityPlotSpecificationLimits"]])
+ xLimits <- range(xLimits, options[["lowerSpecificationLimitValue"]])
+ if (options[["upperSpecificationLimit"]] && options[["processCapabilityPlotSpecificationLimits"]])
+ xLimits <- range(xLimits, options[["upperSpecificationLimitValue"]])
+ if (options[["target"]] && options[["processCapabilityPlotSpecificationLimits"]])
+ xLimits <- range(xLimits, options[["target"]])
+
nBins <- options[["processCapabilityPlotBinNumber"]]
h <- hist(allData, plot = FALSE, breaks = nBins)
binWidth <- (h$breaks[2] - h$breaks[1])
diff --git a/inst/qml/processCapabilityStudies.qml b/inst/qml/processCapabilityStudies.qml
index 4f438d28..205a167b 100644
--- a/inst/qml/processCapabilityStudies.qml
+++ b/inst/qml/processCapabilityStudies.qml
@@ -21,7 +21,6 @@ Form
{
columns: 2
-
DropDown
{
name: "dataFormat"
From d61c332c635ba3eff9ad0a76c6532ad19b53fc40 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Fri, 6 Sep 2024 17:33:00 +0200
Subject: [PATCH 17/25] Time weighted charts unit tests LF
---
R/commonQualityControl.R | 2 +-
.../capability-of-the-process20-subplot-2.svg | 79 +++--
...capability-of-the-processw10-subplot-3.svg | 79 +++--
.../cumulative-sum-chart-lf1.svg | 126 +++++++
.../cumulative-sum-chartlf2.svg | 151 ++++++++
.../cumulative-sum-chartlf3.svg | 110 ++++++
.../cumulative-sum-chartlf4.svg | 334 ++++++++++++++++++
.../cumulative-sum-chartlf5.svg | 126 +++++++
.../cumulative-sum-chartlf6.svg | 124 +++++++
...entially-weighted-moving-average-chart.svg | 139 ++++++++
...ially-weighted-moving-average-chartlf1.svg | 86 +++++
...ially-weighted-moving-average-chartlf3.svg | 116 ++++++
...ially-weighted-moving-average-chartlf4.svg | 116 ++++++
...ially-weighted-moving-average-chartlf5.svg | 90 +++++
...ially-weighted-moving-average-chartlf6.svg | 86 +++++
...me-weighted-charts-report7-2-subplot-1.svg | 33 ++
...me-weighted-charts-report7-2-subplot-2.svg | 86 +++++
...me-weighted-charts-report7-2-subplot-3.svg | 34 ++
...me-weighted-charts-report7-2-subplot-4.svg | 41 +++
...-weighted-charts-reportlf7-1-subplot-1.svg | 33 ++
...-weighted-charts-reportlf7-1-subplot-2.svg | 126 +++++++
...-weighted-charts-reportlf7-1-subplot-3.svg | 34 ++
...-weighted-charts-reportlf7-1-subplot-4.svg | 41 +++
...me-weighted-charts-reportlf7-subplot-1.svg | 33 ++
...me-weighted-charts-reportlf7-subplot-2.svg | 126 +++++++
...me-weighted-charts-reportlf7-subplot-3.svg | 34 ++
...me-weighted-charts-reportlf7-subplot-4.svg | 41 +++
tests/testthat/test-timeWeightedCharts.R | 253 +++++++++++--
28 files changed, 2578 insertions(+), 101 deletions(-)
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-lf1.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf2.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf3.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf4.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf5.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf6.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf1.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf3.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf4.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf5.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf6.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-1.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-2.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-3.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-4.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-1.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-2.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-3.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-4.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-1.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-2.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-3.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-4.svg
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index 9d31bda5..dec8f601 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -1088,7 +1088,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
.ewmaPointSigmas <- function(n = n, sigma = sigma, lambda = ewmaLambda) {
ewmaPointSigmas <- c()
- initialPoint <- (lambda * sigma) / n[1]
+ initialPoint <- (lambda * sigma) / sqrt(n[1])
ewmaPointSigmas[1] <- initialPoint
for (i in seq(2, length(n))) {
nVector <- n[seq(i-1, 1)]
diff --git a/tests/testthat/_snaps/processCapabilityStudies/capability-of-the-process20-subplot-2.svg b/tests/testthat/_snaps/processCapabilityStudies/capability-of-the-process20-subplot-2.svg
index af496e1f..1b2955c5 100644
--- a/tests/testthat/_snaps/processCapabilityStudies/capability-of-the-process20-subplot-2.svg
+++ b/tests/testthat/_snaps/processCapabilityStudies/capability-of-the-process20-subplot-2.svg
@@ -27,52 +27,59 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-Target
+
+Target
+
+LSL
USL
-
+
-
-
-
-
-
+
+
+
+
+
-2
-4
-6
-8
-10
+2
+4
+6
+8
+10
12
Measurement
Density
diff --git a/tests/testthat/_snaps/processCapabilityStudies/capability-of-the-processw10-subplot-3.svg b/tests/testthat/_snaps/processCapabilityStudies/capability-of-the-processw10-subplot-3.svg
index 376e811f..e97f6fdb 100644
--- a/tests/testthat/_snaps/processCapabilityStudies/capability-of-the-processw10-subplot-3.svg
+++ b/tests/testthat/_snaps/processCapabilityStudies/capability-of-the-processw10-subplot-3.svg
@@ -27,52 +27,59 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-Target
+
+Target
+
+LSL
USL
-
+
-
-
-
-
-
+
+
+
+
+
-2
-4
-6
-8
-10
+2
+4
+6
+8
+10
12
Measurement
Density
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-lf1.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-lf1.svg
new file mode 100644
index 00000000..c9469196
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-lf1.svg
@@ -0,0 +1,126 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf2.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf2.svg
new file mode 100644
index 00000000..724be4ed
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf2.svg
@@ -0,0 +1,151 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf3.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf3.svg
new file mode 100644
index 00000000..efec5098
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf3.svg
@@ -0,0 +1,110 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf4.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf4.svg
new file mode 100644
index 00000000..ce936f48
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf4.svg
@@ -0,0 +1,334 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf5.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf5.svg
new file mode 100644
index 00000000..66df60ca
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf5.svg
@@ -0,0 +1,126 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf6.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf6.svg
new file mode 100644
index 00000000..09da6dc6
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chartlf6.svg
@@ -0,0 +1,124 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart.svg
new file mode 100644
index 00000000..41e9b4e7
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart.svg
@@ -0,0 +1,139 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf1.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf1.svg
new file mode 100644
index 00000000..f959f99c
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf1.svg
@@ -0,0 +1,86 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf3.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf3.svg
new file mode 100644
index 00000000..de8b5851
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf3.svg
@@ -0,0 +1,116 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf4.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf4.svg
new file mode 100644
index 00000000..6534d725
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf4.svg
@@ -0,0 +1,116 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf5.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf5.svg
new file mode 100644
index 00000000..0e4b7c39
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf5.svg
@@ -0,0 +1,90 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf6.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf6.svg
new file mode 100644
index 00000000..d4bdcc98
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chartlf6.svg
@@ -0,0 +1,86 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-1.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-1.svg
new file mode 100644
index 00000000..f3fe2ee4
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-1.svg
@@ -0,0 +1,33 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-2.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-2.svg
new file mode 100644
index 00000000..e9f6e4ab
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-2.svg
@@ -0,0 +1,86 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-3.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-3.svg
new file mode 100644
index 00000000..566116be
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-3.svg
@@ -0,0 +1,34 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-4.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-4.svg
new file mode 100644
index 00000000..a44ef157
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report7-2-subplot-4.svg
@@ -0,0 +1,41 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-1.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-1.svg
new file mode 100644
index 00000000..b4318ee7
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-1.svg
@@ -0,0 +1,33 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-2.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-2.svg
new file mode 100644
index 00000000..e386b017
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-2.svg
@@ -0,0 +1,126 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-3.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-3.svg
new file mode 100644
index 00000000..2cfdc4c4
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-3.svg
@@ -0,0 +1,34 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-4.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-4.svg
new file mode 100644
index 00000000..c5600b3b
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-1-subplot-4.svg
@@ -0,0 +1,41 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-1.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-1.svg
new file mode 100644
index 00000000..72611623
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-1.svg
@@ -0,0 +1,33 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-2.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-2.svg
new file mode 100644
index 00000000..ad4f9caf
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-2.svg
@@ -0,0 +1,126 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-3.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-3.svg
new file mode 100644
index 00000000..32869d35
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-3.svg
@@ -0,0 +1,34 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-4.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-4.svg
new file mode 100644
index 00000000..7f91c7cb
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-4.svg
@@ -0,0 +1,41 @@
+
+
diff --git a/tests/testthat/test-timeWeightedCharts.R b/tests/testthat/test-timeWeightedCharts.R
index b3df1ad6..b1cff85a 100644
--- a/tests/testthat/test-timeWeightedCharts.R
+++ b/tests/testthat/test-timeWeightedCharts.R
@@ -5,7 +5,7 @@ context("[Quality Control] Time Weighted Charts")
## Without Stages ####
-### CUSUM ####
+### CUSUM (verified with Minitab) ####
options <- analysisOptions("timeWeightedCharts")
options$measurementLongFormat <- "Measurement"
options$subgroupSizeType <- "manual"
@@ -13,74 +13,271 @@ options$manualSubgroupSizeValue <- 5
options$cumulativeSumChart <- TRUE
options$cumulativeSumChartSdSource <- "data"
options$cumulativeSumChartSdMethod <- "s"
-results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options, makeTests = T)
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options)
-### EWMA ####
+test_that("LF1.1 Basic test of Cumulative sum chart", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chart_LF1")
+})
+### EWMA (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$cumulativeSumChart <- FALSE
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/ewmaChartLong.csv", options)
+
+test_that("LF1.2 Basic test of Exponentially weighted moving average chart", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chartLF1")
+})
## With Stages ####
-### CUSUM ####
+### CUSUM (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$stagesLongFormat <- "Stage"
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options)
+
+test_that("LF2.1 Basic test of Cumulative sum chart with stages", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chartLF2")
+})
-### EWMA ####
+### EWMA (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "individual"
+options$stagesLongFormat <- "Stage"
+options$cumulativeSumChart <- FALSE
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/ewmaChartLong.csv", options)
+
+test_that("LF2.2 Basic test of Exponentially weighted moving average chart with stages", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chart")
+})
## Subgrouping Mechanisms ####
### Grouping Variable ####
-#### Value Change ####
-
-##### CUSUM ####
-
-##### EWMA ####
-
-#### Same Value ####
+#### CUSUM (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "groupingVariable"
+options$subgroup <- "Date"
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options)
-##### CUSUM ####
+test_that("LF3.1 Test of Cumulative sum chart with subgroup variable", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chartLF3")
+})
-##### EWMA ####
+#### EWMA (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "groupingVariable"
+options$subgroup <- "Subgroup"
+options$cumulativeSumChart <- FALSE
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/ewmaChartLong.csv", options)
+
+test_that("LF3.2 Test of Exponentially weighted moving average chart with subgroup variable", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chartLF3")
+})
### No Subgroups ####
-#### CUSUM ####
+#### CUSUM (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "individual"
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options)
+
+test_that("LF4.1 Test of Cumulative sum chart without subgroups", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chartLF4")
+})
-#### EWMA ####
+#### EWMA (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "individual"
+options$cumulativeSumChart <- FALSE
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/ewmaChartLong.csv", options)
+
+test_that("LF4.2 Test of Exponentially weighted moving average chart without subgroups", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chartLF4")
+})
## Plotting Options ####
### Historical values ####
-#### CUSUM ####
+#### CUSUM (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "historical"
+options$cumulativeSumChartSdValue <- 3
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options)
-#### EWMA ####
+test_that("LF5.1 Test of Cumulative sum chart with historical std. dev.", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chartLF5")
+})
+
+#### EWMA (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$cumulativeSumChart <- FALSE
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "historical"
+options$exponentiallyWeightedMovingAverageChartSdValue <- 3
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/ewmaChartLong.csv", options)
+
+test_that("LF5.2 Test of Exponentially weighted moving average chart with historical std. dev.", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chartLF5")
+})
### Alternative SD Estimation ####
-#### CUSUM ####
+#### CUSUM (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "r"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options)
+
+test_that("LF6.1 Test of Cumulative sum chart with r-bar std. dev.", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chartLF6")
+})
+
+#### EWMA (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$cumulativeSumChart <- FALSE
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "r"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/ewmaChartLong.csv", options)
+
+test_that("LF6.2 Test of Exponentially weighted moving average chart with r-bar std. dev.", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chartLF6")
+})
-#### EWMA ####
## Report ####
+### CUSUM (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "s"
+options$report <- TRUE
+options$reportMeasurementName <- TRUE
+options$reportMeasurementNameText <- "Test Name"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartLong.csv", options)
+
+test_that("LF7.1 Test of Cumulative sum chart report", {
+ plotName <- results[["results"]][["report"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "time-weighted-charts-reportLF7_1")
+})
+
+### EWMA (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$measurementLongFormat <- "Measurement"
+options$subgroupSizeType <- "manual"
+options$manualSubgroupSizeValue <- 5
+options$cumulativeSumChart <- FALSE
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+options$report <- TRUE
+options$reportMeasurementName <- TRUE
+options$reportMeasurementNameText <- "Test Name"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/ewmaChartLong.csv", options)
+
+test_that("LF7.2 Test of Exponentially weighted moving average chart report", {
+ plotName <- results[["results"]][["report"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "time-weighted-charts-report7_2")
+})
+
# Wide Format ####
## Without Stages ####
-
-### CUSUM ####
+# options <- analysisOptions("timeWeightedCharts")
+# options$measurementsWideFormat <- c("X1", "X2", "X3", "X4", "X5", "X6", "X7", "X8", "X9", "X10")
+# options$cumulativeSumChart <- TRUE
+# options$cumulativeSumChartSdSource <- "data"
+# options$cumulativeSumChartSdMethod <- "s"
+# options$exponentiallyWeightedMovingAverageChart <- TRUE
+# options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+# options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+# results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartWide.csv", options, makeTests = T)
## With Stages ####
-### CUSUM ####
## Plotting Options ####
### Historical values ####
-#### CUSUM ####
-
### Alternative SD Estimation ####
-#### CUSUM ####
-
-
## Report ####
From 07453d4f55f8878833a3c73839f3e1f837107571 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 11 Sep 2024 15:02:17 +0200
Subject: [PATCH 18/25] Unit tests time weighted charts wide format
---
inst/qml/timeWeightedCharts.qml | 2 +-
.../cumulative-sum-chart-wf1.svg | 110 ++++++++++++++
.../cumulative-sum-chart-wf2.svg | 137 ++++++++++++++++++
.../cumulative-sum-chart-wf3.svg | 112 ++++++++++++++
.../cumulative-sum-chart-wf4.svg | 112 ++++++++++++++
...ally-weighted-moving-average-chart-wf1.svg | 92 ++++++++++++
...ally-weighted-moving-average-chart-wf2.svg | 119 +++++++++++++++
...ally-weighted-moving-average-chart-wf3.svg | 92 ++++++++++++
...ally-weighted-moving-average-chart-wf4.svg | 92 ++++++++++++
...e-weighted-charts-report-wf5-subplot-1.svg | 33 +++++
...e-weighted-charts-report-wf5-subplot-2.svg | 110 ++++++++++++++
...e-weighted-charts-report-wf5-subplot-3.svg | 92 ++++++++++++
...e-weighted-charts-report-wf5-subplot-4.svg | 34 +++++
...e-weighted-charts-report-wf5-subplot-5.svg | 41 ++++++
...e-weighted-charts-report-wf5-subplot-6.svg | 32 ++++
tests/testthat/test-timeWeightedCharts.R | 126 ++++++++++++++--
16 files changed, 1321 insertions(+), 15 deletions(-)
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf1.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf2.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf3.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf4.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf1.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf2.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf3.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf4.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-1.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-2.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-3.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-4.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-5.svg
create mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-6.svg
diff --git a/inst/qml/timeWeightedCharts.qml b/inst/qml/timeWeightedCharts.qml
index c0fe945e..9a108c39 100644
--- a/inst/qml/timeWeightedCharts.qml
+++ b/inst/qml/timeWeightedCharts.qml
@@ -204,7 +204,7 @@ Form
visible: cumulativeSumChartSdSource.currentValue == "data"
label: qsTr("Std. dev. estimation method")
id: cumulativeSumChartSdMethod
- values: subgroupSizeType.value == "individual" ?
+ values: (subgroupSizeType.value == "individual" & dataFormat.currentValue == "longFormat") ?
[
{ label: qsTr("X-mR"), value: "averageMovingRange"}
] :
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf1.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf1.svg
new file mode 100644
index 00000000..9f41d93f
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf1.svg
@@ -0,0 +1,110 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf2.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf2.svg
new file mode 100644
index 00000000..503588bc
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf2.svg
@@ -0,0 +1,137 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf3.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf3.svg
new file mode 100644
index 00000000..27392f60
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf3.svg
@@ -0,0 +1,112 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf4.svg b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf4.svg
new file mode 100644
index 00000000..c3659a4f
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/cumulative-sum-chart-wf4.svg
@@ -0,0 +1,112 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf1.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf1.svg
new file mode 100644
index 00000000..0b7be7ea
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf1.svg
@@ -0,0 +1,92 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf2.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf2.svg
new file mode 100644
index 00000000..c1d76a6e
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf2.svg
@@ -0,0 +1,119 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf3.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf3.svg
new file mode 100644
index 00000000..4880ac77
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf3.svg
@@ -0,0 +1,92 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf4.svg b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf4.svg
new file mode 100644
index 00000000..f360c3df
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/exponentially-weighted-moving-average-chart-wf4.svg
@@ -0,0 +1,92 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-1.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-1.svg
new file mode 100644
index 00000000..21dd5689
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-1.svg
@@ -0,0 +1,33 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-2.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-2.svg
new file mode 100644
index 00000000..57215b2e
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-2.svg
@@ -0,0 +1,110 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-3.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-3.svg
new file mode 100644
index 00000000..119dfa6c
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-3.svg
@@ -0,0 +1,92 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-4.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-4.svg
new file mode 100644
index 00000000..548ec914
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-4.svg
@@ -0,0 +1,34 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-5.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-5.svg
new file mode 100644
index 00000000..effb994e
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-5.svg
@@ -0,0 +1,41 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-6.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-6.svg
new file mode 100644
index 00000000..705720fa
--- /dev/null
+++ b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-report-wf5-subplot-6.svg
@@ -0,0 +1,32 @@
+
+
diff --git a/tests/testthat/test-timeWeightedCharts.R b/tests/testthat/test-timeWeightedCharts.R
index b1cff85a..f66b04a1 100644
--- a/tests/testthat/test-timeWeightedCharts.R
+++ b/tests/testthat/test-timeWeightedCharts.R
@@ -260,24 +260,122 @@ test_that("LF7.2 Test of Exponentially weighted moving average chart report", {
# Wide Format ####
-## Without Stages ####
-# options <- analysisOptions("timeWeightedCharts")
-# options$measurementsWideFormat <- c("X1", "X2", "X3", "X4", "X5", "X6", "X7", "X8", "X9", "X10")
-# options$cumulativeSumChart <- TRUE
-# options$cumulativeSumChartSdSource <- "data"
-# options$cumulativeSumChartSdMethod <- "s"
-# options$exponentiallyWeightedMovingAverageChart <- TRUE
-# options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
-# options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
-# results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartWide.csv", options, makeTests = T)
+## Without Stages (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$dataFormat <- "wideFormat"
+options$measurementsWideFormat <- c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10")
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "s"
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartWide.csv", options)
-## With Stages ####
+test_that("WF1.1 Basic test of Cumulative sum chart", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chart_WF1")
+})
+test_that("WF1.2 Basic test of Exponentially weighted moving average chart", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chart_WF1")
+})
-## Plotting Options ####
+## With Stages (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$dataFormat <- "wideFormat"
+options$measurementsWideFormat <- c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10")
+options$stagesWideFormat <- "Stage"
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "s"
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartWide.csv", options)
+
+test_that("WF2.1 Basic test of Cumulative sum chart with stages", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chart_WF2")
+})
+
+test_that("WF2.2 Basic test of Exponentially weighted moving average chart with stages", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chart_WF2")
+})
+
+## Plotting Options (verified with Minitab) ####
### Historical values ####
+options <- analysisOptions("timeWeightedCharts")
+options$dataFormat <- "wideFormat"
+options$measurementsWideFormat <- c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10")
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "historical"
+options$cumulativeSumChartSdValue <- 3
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "historical"
+options$exponentiallyWeightedMovingAverageChartSdValue <- 3
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartWide.csv", options)
-### Alternative SD Estimation ####
+test_that("WF3.1 Test of Cumulative sum chart with historical std. dev.", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chart_WF3")
+})
-## Report ####
+test_that("WF3.2 Test of Exponentially weighted moving average chart with historical std. dev.", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chart_WF3")
+})
+
+### Alternative SD Estimation (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$dataFormat <- "wideFormat"
+options$measurementsWideFormat <- c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10")
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "r"
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "r"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartWide.csv", options)
+
+test_that("WF4.1 Test of Cumulative sum chart with r-bar std. dev.", {
+ plotName <- results[["results"]][["CusumChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "cumulative-sum-chart_WF4")
+})
+
+test_that("WF4.2 Test of Exponentially weighted moving average chart with historical std. dev.", {
+ plotName <- results[["results"]][["EWMAPlot"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "exponentially-weighted-moving-average-chart_WF4")
+})
+
+## Report (verified with Minitab) ####
+options <- analysisOptions("timeWeightedCharts")
+options$dataFormat <- "wideFormat"
+options$measurementsWideFormat <- c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10")
+options$cumulativeSumChart <- TRUE
+options$cumulativeSumChartSdSource <- "data"
+options$cumulativeSumChartSdMethod <- "s"
+options$exponentiallyWeightedMovingAverageChart <- TRUE
+options$exponentiallyWeightedMovingAverageChartSdSource <- "data"
+options$exponentiallyWeightedMovingAverageChartSdMethod <- "s"
+options$report <- TRUE
+options$reportMeasurementName <- TRUE
+options$reportMeasurementNameText <- "Test Name"
+results <- runAnalysis("timeWeightedCharts", "datasets/timeWeightedCharts/cumsumChartWide.csv", options)
+
+test_that("WF5 Test of Time weighted charts report", {
+ plotName <- results[["results"]][["report"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "time-weighted-charts-report_WF5")
+})
From c5d5831e7ce9ef1342eb24d661497ddabdcf5ff2 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 11 Sep 2024 15:46:38 +0200
Subject: [PATCH 19/25] Start unit tests for rare event charts
---
tests/testthat/test-rareEventCharts.R | 82 +++++++++++++++++++++++++++
1 file changed, 82 insertions(+)
diff --git a/tests/testthat/test-rareEventCharts.R b/tests/testthat/test-rareEventCharts.R
index 5ceaea0c..89880499 100644
--- a/tests/testthat/test-rareEventCharts.R
+++ b/tests/testthat/test-rareEventCharts.R
@@ -1,2 +1,84 @@
context("[Quality Control] Rare Event Charts")
.numDecimals <- 2
+
+# Date input ####
+
+## MD (g chart verified with Minitab, T chart differs because of zero handling) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "MD"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "md"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("1.1 Test of G chart with MD date format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart1")
+})
+
+test_that("1.2 Test of T chart with MD date format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart1")
+})
+
+## MDHM (t chart verified with Minitab, g chart not possible in Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "MDHM"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateTime"
+options$dataTypeDatesFormatDate <- "md"
+options$dataTypeDatesFormatTime <- "HM"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("2.1 Test of G chart with MDHM date format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart2")
+})
+
+test_that("2.2 Test of T chart with MDHM date format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart2")
+})
+
+
+## DM ####
+# options <- analysisOptions("rareEventCharts")
+# options$variable <- "DM"
+# options$dataType <- "dataTypeDates"
+# options$dataTypeDatesStructure <- "dateOnly"
+# options$dataTypeDatesFormatDate <- "dm"
+# options$gChart <- TRUE
+# options$tChart <- TRUE
+# results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options, makeTests = T)
+
+
+
+## DMY ####
+
+## MDY ####
+
+## YMD ####
+
+# Time input ####
+
+## Decimal Hours ####
+
+## Decimal Days ####
+
+# Opportunities input ####
+
+# Stages ####
+
+# Historical options ####
+
+# Distribution options ####
+
+# Report ####
From f4adba25b301ee259bb5b54e73da7c5912e56f2b Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Fri, 13 Sep 2024 16:53:33 +0200
Subject: [PATCH 20/25] Rare event charts unit tests continued
---
R/commonQualityControl.R | 1 -
R/rareEventCharts.R | 45 +++--
.../_snaps/rareEventCharts/g-chart1.svg | 113 +++++++++++
.../_snaps/rareEventCharts/g-chart2.svg | 113 +++++++++++
.../_snaps/rareEventCharts/t-chart1.svg | 109 +++++++++++
.../_snaps/rareEventCharts/t-chart2.svg | 109 +++++++++++
.../rareEventCharts/rareEventCharts.csv | 76 ++++----
tests/testthat/test-rareEventCharts.R | 184 ++++++++++++++++--
8 files changed, 677 insertions(+), 73 deletions(-)
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart1.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart2.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart1.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart2.svg
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index dec8f601..e4dc5a1c 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -681,7 +681,6 @@ KnownControlStats.RS <- function(N, sigma = 3) {
###
} else if (plotType == "t") {
plotStatistic <- unname(unlist(dataCurrentStage))
-
if (any(plotStatistic[!is.na(plotStatistic)] == 0)) {
zeroCorrectionIndices <- which(plotStatistic == 0, arr.ind = TRUE)
plotStatistic[zeroCorrectionIndices] <- min(plotStatistic[plotStatistic > 0], na.rm = TRUE)/2
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index baa0df70..2a101ea4 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -22,13 +22,19 @@ rareEventCharts <- function(jaspResults, dataset, options) {
stages <- unlist(options[["stage"]])
variable <- variable[variable != ""]
stages <- stages[stages != ""]
- factorVariables <- c(variable, stages)
- ready <- length(variable) == 1
+ if (options[["dataType"]] == "dataTypeDates" | options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "dataTypeIntervalTypeTime") {
+ numericVariables <- NULL
+ factorVariables <- c(variable, stages)
+ } else {
+ numericVariables <- variable
+ factorVariables <- stages
+ }
+ ready <- length(variable) == 1
if (is.null(dataset)) {
- dataset <- .readDataSetToEnd(columns.as.factor = factorVariables)
+ dataset <- .readDataSetToEnd(columns.as.factor = factorVariables, columns.as.numeric = numericVariables)
}
@@ -58,15 +64,15 @@ rareEventCharts <- function(jaspResults, dataset, options) {
# options[["dataTypeDatesStructure"]] <- "timeDate"
# options[["dataTypeDatesFormatDate"]] <- "dmy"
# options[["dataTypeDatesFormatTime"]] <- "HM"
- # # date only
- # timepoints <- c("01.04.2024", "04.04.2024", "09.04.2024", "15.04.2024", " 30.04.2024")
- # dataset <- list()
- # dataset[["variable"]] <- timepoints
- # options <- list()
- # options[["dataType"]] <- "dataTypeDates"
- # options[["dataTypeDatesStructure"]] <- "dateOnly"
- # options[["dataTypeDatesFormatDate"]] <- "dmy"
- # options[["dataTypeDatesFormatTime"]] <- "HM"
+ # # date only
+ # timepoints <- c("01.04.2024", "04.04.2024", "09.04.2024", "15.04.2024", " 30.04.2024")
+ # dataset <- list()
+ # dataset[["variable"]] <- timepoints
+ # options <- list()
+ # options[["dataType"]] <- "dataTypeDates"
+ # options[["dataTypeDatesStructure"]] <- "dateOnly"
+ # options[["dataTypeDatesFormatDate"]] <- "dmy"
+ # options[["dataTypeDatesFormatTime"]] <- "HM"
# # time only
# timepoints <- c("1:32", "3:24", "5:17", "9:22", "12:21")
# dataset <- list()
@@ -99,8 +105,6 @@ rareEventCharts <- function(jaspResults, dataset, options) {
# options[["dataTypeDatesFormatTime"]] <- "HM"
-
-
if (ready) {
# If variable is date/time transform into day, hour and minute intervals
if (options[["dataType"]] == "dataTypeDates") {
@@ -113,6 +117,10 @@ rareEventCharts <- function(jaspResults, dataset, options) {
"timeOnly" = options[["dataTypeDatesFormatTime"]])
timepoints <- lubridate::parse_date_time(timepoints, orders = timeFormat) # returns all data in HMS format
timepointsLag1 <- c(NA, timepoints[seq(1, length(timepoints) - 1)]) # because of the NA, everything is converted to seconds
+ if (length(stages) == 1) { # remove the first value of each stage, as it is a new beginning
+ stageSwitchPositions <- which(diff(as.numeric(dataset[[stages]])) != 0) + 1
+ timepointsLag1[stageSwitchPositions] <- NA
+ }
intervalsMinutes <- as.numeric(timepoints - timepointsLag1)/60
intervalsHours <- intervalsMinutes/60
intervalsDays <- intervalsHours/24
@@ -125,7 +133,8 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
# if intervals are all NA, throw error
- if (all(is.na(timepoints))) {
+ if ((options[["dataType"]] == "dataTypeDates" | options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "dataTypeIntervalTypeTime") &&
+ all(is.na(timepoints))) {
errorPlot <- createJaspPlot(title = gettext("Rare event charts"), width = 1200, height = 500)
errorPlot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
"dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat"))
@@ -136,13 +145,13 @@ rareEventCharts <- function(jaspResults, dataset, options) {
# Get the interval type, depending on the input type and, if applicable, the calculated intervals
if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "opportunities") {
- intervals <- dataset[[variable]]
+ intervals <- as.numeric(dataset[[variable]])
intervalType <- "opportunities"
} else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "hours") {
- intervals <- dataset[[variable]]
+ intervals <- as.numeric(dataset[[variable]])
intervalType <- "hours"
} else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "days") {
- intervals <- dataset[[variable]]
+ intervals <- as.numeric(dataset[[variable]])
intervalType <- "days"
} else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "time") {
intervals <- if(all(intervalsHours < 1, na.rm = TRUE) ) intervalsMinutes else intervalsHours
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart1.svg b/tests/testthat/_snaps/rareEventCharts/g-chart1.svg
new file mode 100644
index 00000000..6897bc01
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart1.svg
@@ -0,0 +1,113 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart2.svg b/tests/testthat/_snaps/rareEventCharts/g-chart2.svg
new file mode 100644
index 00000000..dde333d0
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart2.svg
@@ -0,0 +1,113 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart1.svg b/tests/testthat/_snaps/rareEventCharts/t-chart1.svg
new file mode 100644
index 00000000..a8ad8c4f
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart1.svg
@@ -0,0 +1,109 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart2.svg b/tests/testthat/_snaps/rareEventCharts/t-chart2.svg
new file mode 100644
index 00000000..55bc4356
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart2.svg
@@ -0,0 +1,109 @@
+
+
diff --git a/tests/testthat/datasets/rareEventCharts/rareEventCharts.csv b/tests/testthat/datasets/rareEventCharts/rareEventCharts.csv
index 6cf54f68..ff749754 100644
--- a/tests/testthat/datasets/rareEventCharts/rareEventCharts.csv
+++ b/tests/testthat/datasets/rareEventCharts/rareEventCharts.csv
@@ -1,38 +1,38 @@
-"","MD","MDHM","DM","DMY","MDY","YMD","opportunities","decimalTime","decimalDays","stages"
-"1","2/3","1/2 12:00","23/02","23/02/21","02/23/21","21/02/23",94,6.63308813469484,4.02573342202231,1
-"2","2/17","1/10 3:10","24/02","24/02/23","02/24/23","23/02/24",6,12.3823835584335,8.80246541230008,1
-"3","2/28","1/17 11:33","20/08","20/08/21","08/20/21","21/08/20",72,7.97060060547665,3.64091864787042,1
-"4","4/5","1/21 4:02","13/07","13/07/23","07/13/23","23/07/13",86,18.8991916039959,2.88239280693233,1
-"5","4/13","1/21 9:00","05/10","05/10/23","10/05/23","23/10/05",86,5.51485472358763,1.70645235106349,1
-"6","4/26","1/29 14:59","07/03","07/03/20","03/07/20","20/03/07",39,25.9093233430758,1.72171746380627,1
-"7","4/29","2/4 7:01","10/02","10/02/22","02/10/22","22/02/10",31,22.3970401240513,4.8204260552302,1
-"8","5/22","2/6 8:17","26/07","26/07/23","07/26/23","23/07/26",81,20.048539491836,2.52964928513393,1
-"9","5/26","2/7 20:06","16/03","16/03/22","03/16/22","22/03/16",50,18.5405361978337,2.1625478961505,1
-"10","6/3","2/9 4:58","28/10","28/10/21","10/28/21","21/10/28",34,11.1671418067999,6.74376388080418,1
-"11","6/26","2/9 22:53","28/10","28/10/23","10/28/23","23/10/28",4,15.8950705756433,0.476636274252087,1
-"12","7/10","2/11 3:26","23/10","23/10/21","10/23/21","21/10/23",13,26.2404702859931,7.00853087473661,1
-"13","7/15","2/14 0:44","16/09","16/09/22","09/16/22","22/09/16",69,17.4525029934011,3.51888638455421,1
-"14","7/16","2/14 12:20","16/04","16/04/22","04/16/22","22/04/16",25,25.1930329436436,4.08943997928873,2
-"15","7/23","2/19 8:31","30/05","30/05/20","05/30/20","20/05/30",52,9.3734449474141,8.20951323956251,2
-"16","7/31","2/19 11:18","06/08","06/08/23","08/06/23","23/08/06",22,21.2487096665427,9.18857348151505,2
-"17","8/6","2/20 3:30","25/12","25/12/20","12/25/20","20/12/25",89,7.95053418260068,2.82528330106288,2
-"18","8/7","2/21 22:27","02/03","02/03/20","03/02/20","20/03/02",32,17.8302958211862,9.61104793706909,2
-"19","8/25","2/25 17:52","23/04","23/04/21","04/23/21","21/04/23",25,14.4386940146796,7.28394428268075,2
-"20","8/27","2/28 14:32","25/10","25/10/23","10/25/23","23/10/25",87,7.9509819438681,6.86375082004815,2
-"21","9/7","3/5 11:39","22/07","22/07/23","07/22/23","23/07/22",35,16.9377130432986,0.528439427725971,2
-"22","9/11","3/6 9:16","08/10","08/10/22","10/08/22","22/10/08",40,27.3956466908567,3.95220134640113,2
-"23","9/23","3/9 6:13","24/07","24/07/22","07/24/22","22/07/24",30,27.0562316849828,4.77845379849896,2
-"24","9/28","3/10 16:43","22/12","22/12/23","12/22/23","23/12/22",12,8.22499864501879,5.6025326368399,2
-"25","10/4","3/21 10:23","15/08","15/08/22","08/15/22","22/08/15",31,9.64448269223794,6.98261594865471,2
-"26","10/14","3/23 14:07","31/10","31/10/22","10/31/22","22/10/31",30,29.5692265313119,9.15683538420126,2
-"27","10/26","3/28 18:31","05/03","05/03/22","03/05/22","22/03/05",64,18.5997993056662,6.18351227371022,3
-"28","10/26","3/29 8:43","17/05","17/05/22","05/17/22","22/05/17",99,28.1194226746447,4.28421508753672,3
-"29","10/26","4/10 3:27","26/02","26/02/21","02/26/21","21/02/26",14,13.9959810697474,5.4208036721684,3
-"30","10/26","4/11 23:21","02/08","02/08/20","08/02/20","20/08/02",93,12.20497779781,0.58478488586843,3
-"31","10/26","4/23 20:30","07/11","07/11/23","11/07/23","23/11/07",96,19.7769097262062,2.60856857057661,3
-"32","10/28","4/29 16:24","10/08","10/08/23","08/10/23","23/08/10",71,4.57039850531146,3.97151953307912,3
-"33","11/5","5/4 4:16","05/10","05/10/22","10/05/22","22/10/05",67,17.1860117465258,1.97744736680761,3
-"34","11/11","5/11 15:15","07/03","07/03/23","03/07/23","23/03/07",23,7.161780805327,8.3192756283097,3
-"35","11/17","5/21 17:34","05/02","05/02/20","02/05/20","20/02/05",79,28.8707680930384,1.52887222822756,3
-"36","11/30","6/4 1:36","28/11","28/11/21","11/28/21","21/11/28",85,18.0409717792645,8.03418542025611,3
-"37","12/16","6/10 8:59","12/01","12/01/23","01/12/23","23/01/12",37,15.4508918174542,5.46826156554744,3
+"","X","MD","MDHM","DM","DMY","MDY","YMD","opportunities","decimalTime","decimalDays","stages"
+"1",1,"2/3","1/2 12:00","07-01","07-01-2024","01-07-2024","2024-01-07",94,6.63308813469484,4.02573342202231,1
+"2",2,"2/17","1/10 3:10","14-01","14-01-2024","01-14-2024","2024-01-14",6,12.3823835584335,8.80246541230008,1
+"3",3,"2/28","1/17 11:33","23-01","23-01-2024","01-23-2024","2024-01-23",72,7.97060060547665,3.64091864787042,1
+"4",4,"4/5","1/21 4:02","26-01","26-01-2024","01-26-2024","2024-01-26",86,18.8991916039959,2.88239280693233,1
+"5",5,"4/13","1/21 9:00","01-02","01-02-2024","02-01-2024","2024-02-01",86,5.51485472358763,1.70645235106349,1
+"6",6,"4/26","1/29 14:59","12-02","12-02-2024","02-12-2024","2024-02-12",39,25.9093233430758,1.72171746380627,1
+"7",7,"4/29","2/4 7:01","18-03","18-03-2024","03-18-2024","2024-03-18",31,22.3970401240513,4.8204260552302,1
+"8",8,"5/22","2/6 8:17","21-03","21-03-2024","03-21-2024","2024-03-21",81,20.048539491836,2.52964928513393,1
+"9",9,"5/26","2/7 20:06","30-03","30-03-2024","03-30-2024","2024-03-30",50,18.5405361978337,2.1625478961505,1
+"10",10,"6/3","2/9 4:58","31-03","31-03-2024","03-31-2024","2024-03-31",34,11.1671418067999,6.74376388080418,1
+"11",11,"6/26","2/9 22:53","18-04","18-04-2024","04-18-2024","2024-04-18",4,15.8950705756433,0.476636274252087,1
+"12",12,"7/10","2/11 3:26","27-04","27-04-2024","04-27-2024","2024-04-27",13,26.2404702859931,7.00853087473661,1
+"13",13,"7/15","2/14 0:44","14-05","14-05-2024","05-14-2024","2024-05-14",69,17.4525029934011,3.51888638455421,1
+"14",14,"7/16","2/14 12:20","16-05","16-05-2024","05-16-2024","2024-05-16",25,25.1930329436436,4.08943997928873,2
+"15",15,"7/23","2/19 8:31","22-05","22-05-2024","05-22-2024","2024-05-22",52,9.3734449474141,8.20951323956251,2
+"16",16,"7/31","2/19 11:18","01-06","01-06-2024","06-01-2024","2024-06-01",22,21.2487096665427,9.18857348151505,2
+"17",17,"8/6","2/20 3:30","27-06","27-06-2024","06-27-2024","2024-06-27",89,7.95053418260068,2.82528330106288,2
+"18",18,"8/7","2/21 22:27","13-07","13-07-2024","07-13-2024","2024-07-13",32,17.8302958211862,9.61104793706909,2
+"19",19,"8/25","2/25 17:52","15-07","15-07-2024","07-15-2024","2024-07-15",25,14.4386940146796,7.28394428268075,2
+"20",20,"8/27","2/28 14:32","29-07","29-07-2024","07-29-2024","2024-07-29",87,7.9509819438681,6.86375082004815,2
+"21",21,"9/7","3/5 11:39","11-08","11-08-2024","08-11-2024","2024-08-11",35,16.9377130432986,0.528439427725971,2
+"22",22,"9/11","3/6 9:16","16-08","16-08-2024","08-16-2024","2024-08-16",40,27.3956466908567,3.95220134640113,2
+"23",23,"9/23","3/9 6:13","31-08","31-08-2024","08-31-2024","2024-08-31",30,27.0562316849828,4.77845379849896,2
+"24",24,"9/28","3/10 16:43","10-09","10-09-2024","09-10-2024","2024-09-10",12,8.22499864501879,5.6025326368399,2
+"25",25,"10/4","3/21 10:23","12-09","12-09-2024","09-12-2024","2024-09-12",31,9.64448269223794,6.98261594865471,2
+"26",26,"10/14","3/23 14:07","19-09","19-09-2024","09-19-2024","2024-09-19",30,29.5692265313119,9.15683538420126,2
+"27",27,"10/26","3/28 18:31","25-10","25-10-2024","10-25-2024","2024-10-25",64,18.5997993056662,6.18351227371022,3
+"28",28,"10/26","3/29 8:43","01-11","01-11-2024","11-01-2024","2024-11-01",99,28.1194226746447,4.28421508753672,3
+"29",29,"10/26","4/10 3:27","04-11","04-11-2024","11-04-2024","2024-11-04",14,13.9959810697474,5.4208036721684,3
+"30",30,"10/26","4/11 23:21","23-11","23-11-2024","11-23-2024","2024-11-23",93,12.20497779781,0.58478488586843,3
+"31",31,"10/26","4/23 20:30","25-11","25-11-2024","11-25-2024","2024-11-25",96,19.7769097262062,2.60856857057661,3
+"32",32,"10/28","4/29 16:24","27-11","27-11-2024","11-27-2024","2024-11-27",71,4.57039850531146,3.97151953307912,3
+"33",33,"11/5","5/4 4:16","28-11","28-11-2024","11-28-2024","2024-11-28",67,17.1860117465258,1.97744736680761,3
+"34",34,"11/11","5/11 15:15","13-12","13-12-2024","12-13-2024","2024-12-13",23,7.161780805327,8.3192756283097,3
+"35",35,"11/17","5/21 17:34","15-12","15-12-2024","12-15-2024","2024-12-15",79,28.8707680930384,1.52887222822756,3
+"36",36,"11/30","6/4 1:36","20-12","20-12-2024","12-20-2024","2024-12-20",85,18.0409717792645,8.03418542025611,3
+"37",37,"12/16","6/10 8:59","30-12","30-12-2024","12-30-2024","2024-12-30",37,15.4508918174542,5.46826156554744,3
diff --git a/tests/testthat/test-rareEventCharts.R b/tests/testthat/test-rareEventCharts.R
index 89880499..ae8443eb 100644
--- a/tests/testthat/test-rareEventCharts.R
+++ b/tests/testthat/test-rareEventCharts.R
@@ -25,7 +25,7 @@ test_that("1.2 Test of T chart with MD date format", {
jaspTools::expect_equal_plots(testPlot, "t-chart1")
})
-## MDHM (t chart verified with Minitab, g chart not possible in Minitab) ####
+## MDHM (t chart verified with Minitab, g chart not possible with this format in Minitab) ####
options <- analysisOptions("rareEventCharts")
options$variable <- "MDHM"
options$dataType <- "dataTypeDates"
@@ -49,34 +49,186 @@ test_that("2.2 Test of T chart with MDHM date format", {
})
-## DM ####
-# options <- analysisOptions("rareEventCharts")
-# options$variable <- "DM"
-# options$dataType <- "dataTypeDates"
-# options$dataTypeDatesStructure <- "dateOnly"
-# options$dataTypeDatesFormatDate <- "dm"
-# options$gChart <- TRUE
-# options$tChart <- TRUE
-# results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options, makeTests = T)
+## DM (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "DM"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "dm"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+test_that("3.1 Test of G chart with DM date format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart3")
+})
+test_that("3.2 Test of T chart with DM date format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart3")
+})
-## DMY ####
+## DMY (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "DMY"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "dmy"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
-## MDY ####
+test_that("4.1 Test of G chart with DMY date format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart4")
+})
-## YMD ####
+test_that("4.2 Test of T chart with DMY date format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart4")
+})
+
+## MDY (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "MDY"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "mdy"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv")
+
+test_that("5.1 Test of G chart with MDY date format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart5")
+})
+
+test_that("5.2 Test of T chart with MDY date format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart5")
+})
+
+## YMD (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "YMD"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "ymd"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("6.1 Test of G chart with YMD date format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart6")
+})
+
+test_that("6.2 Test of T chart with YMD date format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart6")
+})
# Time input ####
-## Decimal Hours ####
+## Decimal Hours (t chart verified with Minitab, g chart not possible with this format in Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "decimalTime"
+options$dataType <- "dataTypeInterval"
+options$dataTypeIntervalType <- "hours"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("7.1 Test of G chart with decimal hour format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart7")
+})
+
+test_that("7.2 Test of T chart with decimal hour format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart7")
+})
+
+## Decimal Days (t chart verified with Minitab, g chart not possible with this format in Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "decimalDays"
+options$dataType <- "dataTypeInterval"
+options$dataTypeIntervalType <- "days"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("8.1 Test of G chart with decimal day format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart8")
+})
+
+test_that("8.2 Test of T chart with decimal day format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart8")
+})
+
+# Opportunities input (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "opportunities"
+options$dataType <- "dataTypeInterval"
+options$dataTypeIntervalType <- "opportunities"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
-## Decimal Days ####
+test_that("9.1 Test of G chart with opportunities format", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart9")
+})
-# Opportunities input ####
+test_that("9.2 Test of T chart with opportunities format", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart9")
+})
# Stages ####
+## Date format ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "DM"
+options$stage <- "stages"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "dm"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("10.1 Test of G chart with DM format and stages", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart10")
+})
+
+test_that("10.2 Test of T chart with DM format and stages", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart10")
+})
+
+## Interval format ####
+
# Historical options ####
# Distribution options ####
From 32d805c3afbfcb76f9df2b719bd9674cbe68b39f Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 18 Sep 2024 14:50:57 +0200
Subject: [PATCH 21/25] Finalize rare event chart unit tests
---
.../_snaps/rareEventCharts/g-chart10.svg | 130 +++++++++++++++++
.../_snaps/rareEventCharts/g-chart11.svg | 135 ++++++++++++++++++
.../_snaps/rareEventCharts/g-chart12.svg | 107 ++++++++++++++
.../_snaps/rareEventCharts/g-chart3.svg | 107 ++++++++++++++
.../_snaps/rareEventCharts/g-chart4.svg | 107 ++++++++++++++
.../_snaps/rareEventCharts/g-chart5.svg | 107 ++++++++++++++
.../_snaps/rareEventCharts/g-chart6.svg | 107 ++++++++++++++
.../_snaps/rareEventCharts/g-chart7.svg | 112 +++++++++++++++
.../_snaps/rareEventCharts/g-chart8.svg | 114 +++++++++++++++
.../_snaps/rareEventCharts/g-chart9.svg | 108 ++++++++++++++
.../rare-event-charts-report1-subplot-1.svg} | 2 +-
.../rare-event-charts-report1-subplot-2.svg | 107 ++++++++++++++
.../rare-event-charts-report1-subplot-3.svg | 111 ++++++++++++++
.../rare-event-charts-report1-subplot-4.svg} | 4 +-
.../rare-event-charts-report1-subplot-5.svg} | 2 +-
.../rare-event-charts-report1-subplot-6.svg | 32 +++++
.../_snaps/rareEventCharts/t-chart10.svg | 134 +++++++++++++++++
.../_snaps/rareEventCharts/t-chart11.svg | 133 +++++++++++++++++
.../_snaps/rareEventCharts/t-chart12.svg | 107 ++++++++++++++
.../_snaps/rareEventCharts/t-chart13.svg | 113 +++++++++++++++
.../_snaps/rareEventCharts/t-chart3.svg | 111 ++++++++++++++
.../_snaps/rareEventCharts/t-chart4.svg | 111 ++++++++++++++
.../_snaps/rareEventCharts/t-chart5.svg | 111 ++++++++++++++
.../_snaps/rareEventCharts/t-chart6.svg | 111 ++++++++++++++
.../_snaps/rareEventCharts/t-chart7.svg | 110 ++++++++++++++
.../_snaps/rareEventCharts/t-chart8.svg | 108 ++++++++++++++
.../_snaps/rareEventCharts/t-chart9.svg | 108 ++++++++++++++
...me-weighted-charts-reportlf7-subplot-2.svg | 126 ----------------
tests/testthat/test-rareEventCharts.R | 89 +++++++++++-
29 files changed, 2728 insertions(+), 136 deletions(-)
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart10.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart11.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart12.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart3.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart4.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart5.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart6.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart7.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart8.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/g-chart9.svg
rename tests/testthat/_snaps/{timeWeightedCharts/time-weighted-charts-reportlf7-subplot-1.svg => rareEventCharts/rare-event-charts-report1-subplot-1.svg} (91%)
create mode 100644 tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-2.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-3.svg
rename tests/testthat/_snaps/{timeWeightedCharts/time-weighted-charts-reportlf7-subplot-3.svg => rareEventCharts/rare-event-charts-report1-subplot-4.svg} (85%)
rename tests/testthat/_snaps/{timeWeightedCharts/time-weighted-charts-reportlf7-subplot-4.svg => rareEventCharts/rare-event-charts-report1-subplot-5.svg} (95%)
create mode 100644 tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-6.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart10.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart11.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart12.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart13.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart3.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart4.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart5.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart6.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart7.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart8.svg
create mode 100644 tests/testthat/_snaps/rareEventCharts/t-chart9.svg
delete mode 100644 tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-2.svg
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart10.svg b/tests/testthat/_snaps/rareEventCharts/g-chart10.svg
new file mode 100644
index 00000000..0b551a3f
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart10.svg
@@ -0,0 +1,130 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart11.svg b/tests/testthat/_snaps/rareEventCharts/g-chart11.svg
new file mode 100644
index 00000000..73d16d54
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart11.svg
@@ -0,0 +1,135 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart12.svg b/tests/testthat/_snaps/rareEventCharts/g-chart12.svg
new file mode 100644
index 00000000..9e8d84c6
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart12.svg
@@ -0,0 +1,107 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart3.svg b/tests/testthat/_snaps/rareEventCharts/g-chart3.svg
new file mode 100644
index 00000000..8ad891df
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart3.svg
@@ -0,0 +1,107 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart4.svg b/tests/testthat/_snaps/rareEventCharts/g-chart4.svg
new file mode 100644
index 00000000..7e0b466c
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart4.svg
@@ -0,0 +1,107 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart5.svg b/tests/testthat/_snaps/rareEventCharts/g-chart5.svg
new file mode 100644
index 00000000..b63adb3e
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart5.svg
@@ -0,0 +1,107 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart6.svg b/tests/testthat/_snaps/rareEventCharts/g-chart6.svg
new file mode 100644
index 00000000..ca801ab7
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart6.svg
@@ -0,0 +1,107 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart7.svg b/tests/testthat/_snaps/rareEventCharts/g-chart7.svg
new file mode 100644
index 00000000..0153a219
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart7.svg
@@ -0,0 +1,112 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart8.svg b/tests/testthat/_snaps/rareEventCharts/g-chart8.svg
new file mode 100644
index 00000000..321543d1
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart8.svg
@@ -0,0 +1,114 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/g-chart9.svg b/tests/testthat/_snaps/rareEventCharts/g-chart9.svg
new file mode 100644
index 00000000..a806d30e
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/g-chart9.svg
@@ -0,0 +1,108 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-1.svg b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-1.svg
similarity index 91%
rename from tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-1.svg
rename to tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-1.svg
index 72611623..978b6dba 100644
--- a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-1.svg
+++ b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-1.svg
@@ -28,6 +28,6 @@
-time-weighted-charts-reportLF7-subplot-1
+rare-event-charts-report1-subplot-1
diff --git a/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-2.svg b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-2.svg
new file mode 100644
index 00000000..3a4d2927
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-2.svg
@@ -0,0 +1,107 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-3.svg b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-3.svg
new file mode 100644
index 00000000..e1d8250a
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-3.svg
@@ -0,0 +1,111 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-3.svg b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-4.svg
similarity index 85%
rename from tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-3.svg
rename to tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-4.svg
index 32869d35..6f060ae9 100644
--- a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-3.svg
+++ b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-4.svg
@@ -26,9 +26,9 @@
-Time weighted charts report
+Rare event charts report
-time-weighted-charts-reportLF7-subplot-3
+rare-event-charts-report1-subplot-4
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-4.svg b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-5.svg
similarity index 95%
rename from tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-4.svg
rename to tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-5.svg
index 7f91c7cb..a0bf8f6c 100644
--- a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-4.svg
+++ b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-5.svg
@@ -36,6 +36,6 @@
Print date:
-time-weighted-charts-reportLF7-subplot-4
+rare-event-charts-report1-subplot-5
diff --git a/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-6.svg b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-6.svg
new file mode 100644
index 00000000..c2b764a6
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/rare-event-charts-report1-subplot-6.svg
@@ -0,0 +1,32 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart10.svg b/tests/testthat/_snaps/rareEventCharts/t-chart10.svg
new file mode 100644
index 00000000..7c76e6d0
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart10.svg
@@ -0,0 +1,134 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart11.svg b/tests/testthat/_snaps/rareEventCharts/t-chart11.svg
new file mode 100644
index 00000000..064ad489
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart11.svg
@@ -0,0 +1,133 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart12.svg b/tests/testthat/_snaps/rareEventCharts/t-chart12.svg
new file mode 100644
index 00000000..2856f2a4
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart12.svg
@@ -0,0 +1,107 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart13.svg b/tests/testthat/_snaps/rareEventCharts/t-chart13.svg
new file mode 100644
index 00000000..79daac33
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart13.svg
@@ -0,0 +1,113 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart3.svg b/tests/testthat/_snaps/rareEventCharts/t-chart3.svg
new file mode 100644
index 00000000..0a681a4b
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart3.svg
@@ -0,0 +1,111 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart4.svg b/tests/testthat/_snaps/rareEventCharts/t-chart4.svg
new file mode 100644
index 00000000..75b36eb9
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart4.svg
@@ -0,0 +1,111 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart5.svg b/tests/testthat/_snaps/rareEventCharts/t-chart5.svg
new file mode 100644
index 00000000..e5219842
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart5.svg
@@ -0,0 +1,111 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart6.svg b/tests/testthat/_snaps/rareEventCharts/t-chart6.svg
new file mode 100644
index 00000000..6c18f44e
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart6.svg
@@ -0,0 +1,111 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart7.svg b/tests/testthat/_snaps/rareEventCharts/t-chart7.svg
new file mode 100644
index 00000000..e4ece3b2
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart7.svg
@@ -0,0 +1,110 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart8.svg b/tests/testthat/_snaps/rareEventCharts/t-chart8.svg
new file mode 100644
index 00000000..f7f46be6
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart8.svg
@@ -0,0 +1,108 @@
+
+
diff --git a/tests/testthat/_snaps/rareEventCharts/t-chart9.svg b/tests/testthat/_snaps/rareEventCharts/t-chart9.svg
new file mode 100644
index 00000000..f63216a5
--- /dev/null
+++ b/tests/testthat/_snaps/rareEventCharts/t-chart9.svg
@@ -0,0 +1,108 @@
+
+
diff --git a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-2.svg b/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-2.svg
deleted file mode 100644
index ad4f9caf..00000000
--- a/tests/testthat/_snaps/timeWeightedCharts/time-weighted-charts-reportlf7-subplot-2.svg
+++ /dev/null
@@ -1,126 +0,0 @@
-
-
diff --git a/tests/testthat/test-rareEventCharts.R b/tests/testthat/test-rareEventCharts.R
index ae8443eb..04a01c20 100644
--- a/tests/testthat/test-rareEventCharts.R
+++ b/tests/testthat/test-rareEventCharts.R
@@ -101,7 +101,7 @@ options$dataTypeDatesStructure <- "dateOnly"
options$dataTypeDatesFormatDate <- "mdy"
options$gChart <- TRUE
options$tChart <- TRUE
-results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv")
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
test_that("5.1 Test of G chart with MDY date format", {
plotName <- results[["results"]][["gChart"]][["data"]]
@@ -204,7 +204,7 @@ test_that("9.2 Test of T chart with opportunities format", {
# Stages ####
-## Date format ####
+## Date format (verified with Minitab) ####
options <- analysisOptions("rareEventCharts")
options$variable <- "DM"
options$stage <- "stages"
@@ -227,10 +227,87 @@ test_that("10.2 Test of T chart with DM format and stages", {
jaspTools::expect_equal_plots(testPlot, "t-chart10")
})
-## Interval format ####
+## Interval format (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "opportunities"
+options$stage <- "stages"
+options$dataType <- "dataTypeInterval"
+options$dataTypeIntervalType <- "opportunities"
+options$gChart <- TRUE
+options$tChart <- TRUE
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("11.1 Test of G chart with interval format and stages", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart11")
+})
+
+test_that("11.2 Test of G chart with interval format and stages", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart11")
+})
-# Historical options ####
+# Historical options (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "DM"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "dm"
+options$gChart <- TRUE
+options$tChart <- TRUE
+options$gChartProportionSource <- "historical"
+options$gChartHistoricalProportion <- 0.5
+options$tChartDistributionParameterSource <- "historical"
+options$tChartHistoricalParametersScale <- 2
+options$tChartHistoricalParametersWeibullShape <- 2
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
-# Distribution options ####
+test_that("12.1 Test of G chart with DM date format and historical parameters", {
+ plotName <- results[["results"]][["gChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "g-chart12")
+})
-# Report ####
+test_that("12.2 Test of T chart with DM date format and historical parameters", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart12")
+})
+
+# Distribution options (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "DM"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "dm"
+options$gChart <- FALSE
+options$tChart <- TRUE
+options$tChartDistribution <- "exponential"
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("13 Test of T chart with DM date format and exponential distribution", {
+ plotName <- results[["results"]][["tChart"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "t-chart13")
+})
+
+# Report (verified with Minitab) ####
+options <- analysisOptions("rareEventCharts")
+options$variable <- "DM"
+options$dataType <- "dataTypeDates"
+options$dataTypeDatesStructure <- "dateOnly"
+options$dataTypeDatesFormatDate <- "dm"
+options$gChart <- TRUE
+options$tChart <- TRUE
+options$report <- TRUE
+options$reportMeasurementName <- TRUE
+options$reportMeasurementNameText <- "Test Name"
+results <- runAnalysis("rareEventCharts", "datasets/rareEventCharts/rareEventCharts.csv", options)
+
+test_that("14 Test of g and t chart report", {
+ plotName <- results[["results"]][["report"]][["data"]]
+ testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ jaspTools::expect_equal_plots(testPlot, "rare-event-charts-report1")
+})
From 13d2f05c072ff46ed7af66fc9db378ae84b12f88 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 18 Sep 2024 15:32:20 +0200
Subject: [PATCH 22/25] Error handling negative values
---
R/rareEventCharts.R | 80 ++++++++-------------------------------------
1 file changed, 14 insertions(+), 66 deletions(-)
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index 2a101ea4..f180f67c 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -43,68 +43,6 @@ rareEventCharts <- function(jaspResults, dataset, options) {
infinity.target = c(options$variable),
exitAnalysisIfErrors = TRUE)
-
- #
- # ### TESTING #####
- # # date and time
- # timepoints <- c("01.04.2024, 9:11", "04.04.2024, 11:11", "09.04.2024, 3:11", "15.04.2024, 18:11", "30.04.2024, 1:11")
- # dataset <- list()
- # dataset[["variable"]] <- timepoints
- # options <- list()
- # options[["dataType"]] <- "dataTypeDates"
- # options[["dataTypeDatesStructure"]] <- "dateTime"
- # options[["dataTypeDatesFormatDate"]] <- "dmy"
- # options[["dataTypeDatesFormatTime"]] <- "HM"
- # # time and date
- # timepoints <- c("9:11 01.04.2024", "11:11 04.04.2024", "3:11 09.04.2024", " 18:11: 15.04.2024", " 1:11 30.04.2024")
- # dataset <- list()
- # dataset[["variable"]] <- timepoints
- # options <- list()
- # options[["dataType"]] <- "dataTypeDates"
- # options[["dataTypeDatesStructure"]] <- "timeDate"
- # options[["dataTypeDatesFormatDate"]] <- "dmy"
- # options[["dataTypeDatesFormatTime"]] <- "HM"
- # # date only
- # timepoints <- c("01.04.2024", "04.04.2024", "09.04.2024", "15.04.2024", " 30.04.2024")
- # dataset <- list()
- # dataset[["variable"]] <- timepoints
- # options <- list()
- # options[["dataType"]] <- "dataTypeDates"
- # options[["dataTypeDatesStructure"]] <- "dateOnly"
- # options[["dataTypeDatesFormatDate"]] <- "dmy"
- # options[["dataTypeDatesFormatTime"]] <- "HM"
- # # time only
- # timepoints <- c("1:32", "3:24", "5:17", "9:22", "12:21")
- # dataset <- list()
- # dataset[["variable"]] <- timepoints
- # options <- list()
- # options[["dataType"]] <- "dataTypeDates"
- # options[["dataTypeDatesStructure"]] <- "timeOnly"
- # options[["dataTypeDatesFormatDate"]] <- "dmy"
- # options[["dataTypeDatesFormatTime"]] <- "HM"
- # ###########################
-
-#
-# # reproduce example g chart
-# dataset <- read.csv("c:/Users/Jonee/Desktop/Temporary Files/specialControlCharts/gchart.csv")
-# options <- list()
-# variable <- "Date.of.infection"
-# options[["dataType"]] <- "dataTypeDates"
-# options[["dataTypeDatesStructure"]] <- "dateOnly"
-# options[["dataTypeDatesFormatDate"]] <- "md"
-
-
-
- # # reproduce example t chart
- # dataset <- read.csv("c:/Users/Jonee/Desktop/Temporary Files/specialControlCharts/tchart.csv")
- # options <- list()
- # variable <- "Date.and.time.of.needlestick"
- # options[["dataType"]] <- "dataTypeDates"
- # options[["dataTypeDatesStructure"]] <- "dateTime"
- # options[["dataTypeDatesFormatDate"]] <- "md"
- # options[["dataTypeDatesFormatTime"]] <- "HM"
-
-
if (ready) {
# If variable is date/time transform into day, hour and minute intervals
if (options[["dataType"]] == "dataTypeDates") {
@@ -124,7 +62,7 @@ rareEventCharts <- function(jaspResults, dataset, options) {
intervalsMinutes <- as.numeric(timepoints - timepointsLag1)/60
intervalsHours <- intervalsMinutes/60
intervalsDays <- intervalsHours/24
- } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "dataTypeIntervalTypeTime") {
+ } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "time") {
timepoints <- dataset[[variable]]
timeFormat <- options[["dataTypeIntervalTimeFormat"]]
timepoints <- lubridate::parse_date_time(timepoints, orders = timeFormat) # returns all data in HMS format
@@ -133,7 +71,7 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
# if intervals are all NA, throw error
- if ((options[["dataType"]] == "dataTypeDates" | options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "dataTypeIntervalTypeTime") &&
+ if ((options[["dataType"]] == "dataTypeDates" | options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "time") &&
all(is.na(timepoints))) {
errorPlot <- createJaspPlot(title = gettext("Rare event charts"), width = 1200, height = 500)
errorPlot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
@@ -154,8 +92,8 @@ rareEventCharts <- function(jaspResults, dataset, options) {
intervals <- as.numeric(dataset[[variable]])
intervalType <- "days"
} else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "time") {
- intervals <- if(all(intervalsHours < 1, na.rm = TRUE) ) intervalsMinutes else intervalsHours
- intervalType <- if(all(intervalsHours < 1, na.rm = TRUE)) "minutes" else "hours"
+ intervals <- if (all(intervalsHours < 1, na.rm = TRUE)) intervalsMinutes else intervalsHours
+ intervalType <- if (all(intervalsHours < 1, na.rm = TRUE)) "minutes" else "hours"
} else if (options[["dataType"]] == "dataTypeDates") {
if (all(intervalsDays < 1, na.rm = TRUE) && all(intervalsHours < 1, na.rm = TRUE)) {
intervals <- intervalsMinutes
@@ -169,6 +107,16 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
}
+ # if intervals contains any negative values, throw error
+ if (any(intervals < 0)) {
+ errorPlot <- createJaspPlot(title = gettext("Rare event charts"), width = 1200, height = 500)
+ errorPlot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
+ "dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat"))
+ errorPlot$setError(gettext("Negative values for time/intervals detected, calculation is not possible."))
+ jaspResults[["errorPlot"]] <- errorPlot
+ return()
+ }
+
if (length(stages) == 1) {
dataset <- data.frame(x1 = intervals, x2 = dataset[[stages]])
colnames(dataset) <- c(variable, stages)
From 73fd355bdb67dbb2c45ed0ba6055e3c39d393b02 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 18 Sep 2024 15:58:10 +0200
Subject: [PATCH 23/25] fix unit tests
---
R/rareEventCharts.R | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index f180f67c..7df78121 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -108,7 +108,7 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
# if intervals contains any negative values, throw error
- if (any(intervals < 0)) {
+ if (any(intervals < 0, na.rm = TRUE)) {
errorPlot <- createJaspPlot(title = gettext("Rare event charts"), width = 1200, height = 500)
errorPlot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
"dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat"))
From 94d6eec48592019c8dbdabf8d619e14dcd38f8de Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Wed, 18 Sep 2024 16:15:42 +0200
Subject: [PATCH 24/25] Skip test that fails only on Mac
---
tests/testthat/test-rareEventCharts.R | 1 +
1 file changed, 1 insertion(+)
diff --git a/tests/testthat/test-rareEventCharts.R b/tests/testthat/test-rareEventCharts.R
index 04a01c20..2c68513e 100644
--- a/tests/testthat/test-rareEventCharts.R
+++ b/tests/testthat/test-rareEventCharts.R
@@ -246,6 +246,7 @@ test_that("11.1 Test of G chart with interval format and stages", {
test_that("11.2 Test of G chart with interval format and stages", {
plotName <- results[["results"]][["tChart"]][["data"]]
testPlot <- results[["state"]][["figures"]][[plotName]][["obj"]]
+ testthat::skip_on_os("mac")
jaspTools::expect_equal_plots(testPlot, "t-chart11")
})
From fe48740abb139ee63bab8faf214746dc2d8c6138 Mon Sep 17 00:00:00 2001
From: JTPetter <61797391+JTPetter@users.noreply.github.com>
Date: Thu, 3 Oct 2024 10:46:32 +0200
Subject: [PATCH 25/25] Feedback Don
---
R/commonQualityControl.R | 28 +++++++++++++++-------------
R/rareEventCharts.R | 30 ++++++++++++++++--------------
2 files changed, 31 insertions(+), 27 deletions(-)
diff --git a/R/commonQualityControl.R b/R/commonQualityControl.R
index e4dc5a1c..04225272 100644
--- a/R/commonQualityControl.R
+++ b/R/commonQualityControl.R
@@ -318,6 +318,8 @@ NelsonLaws <- function(data, allsix = FALSE, chart = "i", xLabels = NULL) {
KnownControlStats.RS <- function(N, sigma = 3) {
+ # d2 and d3 are unbiasing constants as reported in D. J. Wheeler and D. S. Chambers. (1992). Understanding Statistical Process Control, Second Edition, SPC Press, Inc.
+
Data.d3 <- data.frame(
n = 0:25,
d3 = c(NA, NA, 0.8525 ,0.8884, 0.8798, 0.8641, 0.8480, 0.8332, 0.8198, 0.8078, 0.7971, 0.7873, 0.7785, 0.7704, 0.7630,
@@ -535,7 +537,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
### Calculations for R chart
###
} else if (plotType == "R") {
- n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
+ n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else rowSums(!is.na(dataCurrentStage)) # returns the number of non NA values per row
# manually calculate mean and sd as the package gives wrong results with NAs
if(phase2) {
sigma <- phase2Sd
@@ -575,7 +577,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
qccObject <- qcc::qcc(dataCurrentStage, type ='xbar', plot = FALSE, center = mu, sizes = ncol(dataCurrentStage), std.dev = sigma, nsigmas = nSigmasControlLimits)
plotStatistic <- qccObject$statistics
- n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
+ n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else rowSums(!is.na(dataCurrentStage)) # returns the number of non NA values per row
limits <- .controlLimits(mu, sigma, n = n, type = "xbar", k = nSigmasControlLimits)
center <- mu
UCL <- limits$UCL
@@ -602,7 +604,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
}
qccObject <- qcc::qcc(dataCurrentStage, type ='S', plot = FALSE, center = sigma, sizes = ncol(dataCurrentStage), nsigmas = nSigmasControlLimits)
plotStatistic <- qccObject$statistics
- n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
+ n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else rowSums(!is.na(dataCurrentStage)) # returns the number of non NA values per row
limits <- .controlLimits(sigma = sigma, n = n, type = "s", unbiasingConstantUsed = unbiasingConstantUsed, k = nSigmasControlLimits)
if (unbiasingConstantUsed) {
c4s <- sapply(n, function(x) return(KnownControlStats.RS(x, 0)$constants[3]))
@@ -616,7 +618,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
### Calculations for cusum chart
###
} else if (plotType == "cusum") {
- n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
+ n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else rowSums(!is.na(dataCurrentStage)) # returns the number of non NA values per row
# sigma for subgroup size = 1 is calculated as the average moving range sd
if (phase2) {
sigma <- as.numeric(phase2Sd)
@@ -644,7 +646,7 @@ KnownControlStats.RS <- function(N, sigma = 3) {
### Calculations for ewma chart
###
} else if (plotType == "ewma") {
- n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else apply(dataCurrentStage, 1, function(x) return(sum(!is.na(x)))) # returns the number of non NA values per row
+ n <- if (!identical(fixedSubgroupSize, "")) fixedSubgroupSize else rowSums(!is.na(dataCurrentStage)) # returns the number of non NA values per row
if (phase2) {
sigma <- as.numeric(phase2Sd)
} else if (all(n == 1)) {
@@ -917,14 +919,14 @@ KnownControlStats.RS <- function(N, sigma = 3) {
yTitle <- gettextf("%1$s between events", unitString)
} else {
yTitle <- switch (plotType,
- "xBar" = "Sample average",
- "R" = "Sample range",
- "I" = "Individual value",
- "MR" = "Moving range",
- "MMR" = "Moving range of subgroup mean",
- "s" = "Sample std. dev.",
- "cusum" = "Cumulative sum",
- "ewma" = "Exponentially weighted moving average")
+ "xBar" = gettext("Sample average"),
+ "R" = gettext("Sample range"),
+ "I" = gettext("Individual value"),
+ "MR" = gettext("Moving range"),
+ "MMR" = gettext("Moving range of subgroup mean"),
+ "s" = gettext("Sample std. dev."),
+ "cusum" = gettext("Cumulative sum"),
+ "ewma" = gettext("Exponentially weighted moving average"))
}
lineType <- if (phase2) "solid" else "dashed"
# Create plot
diff --git a/R/rareEventCharts.R b/R/rareEventCharts.R
index 7df78121..dcd1224e 100644
--- a/R/rareEventCharts.R
+++ b/R/rareEventCharts.R
@@ -23,7 +23,7 @@ rareEventCharts <- function(jaspResults, dataset, options) {
variable <- variable[variable != ""]
stages <- stages[stages != ""]
- if (options[["dataType"]] == "dataTypeDates" | options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "dataTypeIntervalTypeTime") {
+ if (options[["dataType"]] == "dataTypeDates" || options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "dataTypeIntervalTypeTime") {
numericVariables <- NULL
factorVariables <- c(variable, stages)
} else {
@@ -71,7 +71,7 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
# if intervals are all NA, throw error
- if ((options[["dataType"]] == "dataTypeDates" | options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "time") &&
+ if ((options[["dataType"]] == "dataTypeDates" || options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "time") &&
all(is.na(timepoints))) {
errorPlot <- createJaspPlot(title = gettext("Rare event charts"), width = 1200, height = 500)
errorPlot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
@@ -82,18 +82,20 @@ rareEventCharts <- function(jaspResults, dataset, options) {
}
# Get the interval type, depending on the input type and, if applicable, the calculated intervals
- if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "opportunities") {
- intervals <- as.numeric(dataset[[variable]])
- intervalType <- "opportunities"
- } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "hours") {
- intervals <- as.numeric(dataset[[variable]])
- intervalType <- "hours"
- } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "days") {
- intervals <- as.numeric(dataset[[variable]])
- intervalType <- "days"
- } else if (options[["dataType"]] == "dataTypeInterval" && options[["dataTypeIntervalType"]] == "time") {
- intervals <- if (all(intervalsHours < 1, na.rm = TRUE)) intervalsMinutes else intervalsHours
- intervalType <- if (all(intervalsHours < 1, na.rm = TRUE)) "minutes" else "hours"
+ if (options[["dataType"]] == "dataTypeInterval") {
+ if (options[["dataTypeIntervalType"]] == "opportunities") {
+ intervals <- as.numeric(dataset[[variable]])
+ intervalType <- "opportunities"
+ } else if (options[["dataTypeIntervalType"]] == "hours") {
+ intervals <- as.numeric(dataset[[variable]])
+ intervalType <- "hours"
+ } else if (options[["dataTypeIntervalType"]] == "days") {
+ intervals <- as.numeric(dataset[[variable]])
+ intervalType <- "days"
+ } else if (options[["dataTypeIntervalType"]] == "time") {
+ intervals <- if (all(intervalsHours < 1, na.rm = TRUE)) intervalsMinutes else intervalsHours
+ intervalType <- if (all(intervalsHours < 1, na.rm = TRUE)) "minutes" else "hours"
+ }
} else if (options[["dataType"]] == "dataTypeDates") {
if (all(intervalsDays < 1, na.rm = TRUE) && all(intervalsHours < 1, na.rm = TRUE)) {
intervals <- intervalsMinutes