Special control charts

DESCRIPTION

@@ -27,6 +27,7 @@ Imports:
   jaspBase,
   jaspDescriptives,
   jaspGraphs,
+  lubridate,
   mle.tools,
   psych,
   qcc,

NAMESPACE

@@ -13,6 +13,7 @@ export(msaType1Gauge)
 export(probabilityOfDetection)
 export(processCapabilityStudies)
 export(timeWeightedCharts)
+export(rareEventCharts)
 export(variablesChartsIndividuals)
 export(variablesChartsSubgroups)
 importFrom(jaspBase,.extractErrorMessage)

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])
@@ -2379,40 +2386,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)
-}
+
 

R/rareEventCharts.R

@@ -0,0 +1,248 @@
+#
+# 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 <http://www.gnu.org/licenses/>.
+#
+
+#' @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 != ""]
+
+  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, columns.as.numeric = numericVariables)
+  }
+
+
+  # Checking for errors in the dataset
+  .hasErrors(dataset, type = c('infinity'),
+             infinity.target = c(options$variable),
+             exitAnalysisIfErrors = TRUE)
+
+  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"]])
+      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
+    } 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
+      intervalsMinutes <- as.numeric(timepoints - lubridate::as_datetime("0000-01-01 UTC")) # transform to minutes
+      intervalsHours <- intervalsMinutes/60
+    }
+
+    # if intervals are all NA, throw error
+    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",
+                           "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()
+    }
+
+    # Get the interval type, depending on the input type and, if applicable, the calculated intervals
+    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
+        intervalType <- "minutes"
+      } else if (all(intervalsDays < 1, na.rm = TRUE)) {
+        intervals <- intervalsHours
+        intervalType <- "hours"
+      } else {
+        intervals <- intervalsDays
+        intervalType <- "days"
+      }
+    }
+
+    # if intervals contains any negative values, throw error
+    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"))
+      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)
+    } else {
+      dataset <- data.frame(x1 = intervals)
+      colnames(dataset) <- variable
+      stages <- ""
+    }
+  }
+
+  # G chart
+  if (options[["gChart"]]) {
+    gChart <- .gChart(dataset, variable, stages, intervalType, options, ready)
+  }
+
+  # T chart
+  if (options[["tChart"]]) {
+    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("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"]] ) {
+      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
+  }
+
+}
+
+
+.gChart <- function(dataset,
+                    variable,
+                    stages = NULL,
+                    intervalType = c("days", "hours", "minutes", "opportunities"),
+                    options, ready) {
+  plot <-  createJaspPlot(title = gettext("G chart"), width = 1200, height = 500)
+  plot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
+                  "dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat",
+                  "gChart", "gChartProportionSource", "gChartHistoricalProportion", "report"))
+
+  if (!ready)
+    return(plot)
+
+  columnsToPass <- c(variable, stages)
+  columnsToPass <- columnsToPass[columnsToPass != ""]
+  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)
+}
+
+.tChart <- function(dataset,
+                    variable,
+                    stages = NULL,
+                    intervalType = c("days", "hours", "minutes", "opportunities"),
+                    options, ready) {
+  plot <-  createJaspPlot(title = gettext("T chart"), width = 1200, height = 500)
+  plot$dependOn(c("variable", "stage", "dataType", "dataTypeDatesStructure", "dataTypeDatesFormatDate",
+                  "dataTypeDatesFormatTime", "dataTypeIntervalType", "dataTypeIntervalTimeFormat", "tChart",
+                  "tChartDistribution", "tChartDistributionParameterSource", "tChartHistoricalParametersWeibullShape",
+                  "tChartHistoricalParametersScale", "report"))
+
+  if (!ready)
+    return(plot)
+
+  columnsToPass <- c(variable, stages)
+  columnsToPass <- columnsToPass[columnsToPass != ""]
+  phase2 <- options[["tChartDistributionParameterSource"]] == "historical"
+  plotObject <- .controlChart(dataset[columnsToPass], plotType = "t", stages = stages, gAndtUnit = intervalType,
+                              tChartDistribution = options[["tChartDistribution"]],
+                              phase2tChartDistributionShape = options[["tChartHistoricalParametersWeibullShape"]],
+                              phase2tChartDistributionScale = options[["tChartHistoricalParametersScale"]],
+                              phase2 = phase2)$plotObject
+  plot$plotObject <- plotObject
+
+  return(plot)
+}

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
@@ -82,6 +82,12 @@ Description
 		func:			"timeWeightedCharts"
 	}
 
+	Analysis
+	{
+		title:			qsTr("Rare Event Charts")
+		func:			"rareEventCharts"
+	}
+
 	GroupTitle
 	{
 		title:			qsTr("Capability Analysis")