Skip to content

Commit

Permalink
Feedback Don
Browse files Browse the repository at this point in the history
  • Loading branch information
@JTPetter
JTPetter committed Oct 3, 2024
1 parent 94d6eec commit fe48740
Show file tree
Hide file tree
Showing 2 changed files with 31 additions and 27 deletions.
28 changes: 15 additions & 13 deletions R/commonQualityControl.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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]))
Expand All @@ -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)
Expand Down Expand Up @@ -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)) {
Expand Down Expand Up @@ -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
Expand Down
30 changes: 16 additions & 14 deletions R/rareEventCharts.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 {
Expand Down Expand Up @@ -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",
Expand All @@ -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
Expand Down

0 comments on commit fe48740

Please sign in to comment.