├── .gitignore
├── LICENSE.txt
├── README.md
├── setupFunctionVariables.R
└── qcc.plot.R


/.gitignore:
--------------------------------------------------------------------------------
1 | .Rproj.user
2 | .Rhistory
3 | .RData
4 | .Rproj
5 | .html
6 | qcc/


--------------------------------------------------------------------------------
/LICENSE.txt:
--------------------------------------------------------------------------------
 1 | The MIT License (MIT)
 2 | 
 3 | Copyright (c) 2014 Thomas J Hopper
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | qcc_ggplot
 2 | ==========
 3 | Rewrite of `plot.qcc()` from the _qcc_ package using _ggplot2_ and _grid_. After sourcing this file, when calling `qcc()` with `plot = TRUE` (the default), this version of `plot.qcc()` will automatically be used.
 4 | 
 5 | Provides a complete, seamless replacement for qcc's plot function. Nearly all of qcc's original plotting functionality has been implemented through ggplot2 and grid rather than base graphics.
 6 | 
 7 | Usage
 8 | ---------
 9 | Load library qcc with `library(qcc)` or `require(qcc)`, then `source()` the file qcc.plot.R. The qcc-native plotting function will be replaced in memory, and any future calls during the current session to `plot()` with a qcc object will utilize this function, including those calls from within `qcc()`. The resulting object can be re-used and modified within grid graphics.
10 | 
11 | `plot.qcc()` will require that the libraries _ggplot2_, _grid_ and _gtable_ be installed and available.
12 | 
13 | To Do
14 | --------
15 | * Add back in the ability to control axis text orientation, using <code>axes.las</code>.
16 | * Clean up the layout of the stats panel, especially when resizing to larger plot dimensions.
17 | * Clean up x-axis tick labels to avoid overplotting.
18 | * Add back in the ability to plot user-defined x-axis tick labels, instead of the default index number.
19 | 
20 | History
21 | --------
22 | #### v 1.0    2014-03-03 
23 | 
24 | First release.
25 | 
26 | #### v 1.0.1  2016-01-12 
27 | 
28 | * Update for ggplot2 v2.0 compatibility. May now break on older versions of ggplot2
29 | 
30 | #### v 1.0.2  2016-01-18 
31 | 
32 | * Bug fix: add in ability to specify x-axis labels (allowed in qcc; previously unsupported in qcc_ggplot)
33 | 
34 | #### v 1.0.3  2016-08-26 
35 | 
36 | * Backend cleanup. Assignment of df.indices in data frame was scoped incorrectly, 
37 | 
38 | #### v 1.0.5  2016-11-12 
39 | 
40 | * Fixed problem with adding new data; qcc() calls with newdata= argument set should work correctly. 
41 | * Fixed backwards compatibility problem with label.limits. Will now accept any text or numeric labels for UCL and LCL labels.
42 | * Added argument label.cl to allow manual setting of center line label
43 | * Fixed incorrect UCL, LCL and CL labels showing in plot info box when label.limits or label.cl was set; not correctly shows the actual calculated values.
44 | 
45 | #### v 1.0.6 2017-12-28
46 | 
47 | * Fixed problem with added labels causing an error in ggplot2 code.


--------------------------------------------------------------------------------
/setupFunctionVariables.R:
--------------------------------------------------------------------------------
 1 | library(qcc)
 2 | 
 3 | #' XmR
 4 | my.xmr.raw <- c(5045,4350,4350,3975,4290,4430,4485,4285,3980,3925,3645,3760,3300,3685,3463,5200)
 5 | my.xmr.new <- round(c(runif(5, 3500, 4000)))
 6 | x <- qcc(my.xmr.raw, type = "xbar.one", title = "Individuals Chart\nfor Wheeler sample data")
 7 | x <- qcc(my.xmr.raw, type = "xbar.one", newdata = my.xmr.new, plot = TRUE)
 8 | x <- qcc(matrix(cbind(my.xmr.raw[1:length(my.xmr.raw)-1], my.xmr.raw[2:length(my.xmr.raw)]), ncol = 2), type = "R", title = "Moving Range Chart\nfor Wheeler sample data")
 9 | my_labels <- c("alpha","beta","gamma","delta","epsilon","zeta","eta","theta","iota","kappa","lambda","mu","nu","xi","omicron","pi")
10 | x <- qcc(my.xmr.raw, type = "xbar.one", title = "Individuals Chart\nfor Wheeler sample data", labels = my_labels)
11 | 
12 | #' xbar-R
13 | my.xbr.raw <- c(45,46,43,44,
14 |                 56,53,51,52,
15 |                 45,46,42,45,
16 |                 52,53,51,54,
17 |                 46,44,44,46,
18 |                 55,56,43,56)
19 | my.xbr.raw <- matrix(data=my.xbr.raw, ncol = 4, byrow = TRUE)
20 | x <- qcc(my.xbr.raw, type = "xbar")
21 | x <- qcc(my.xbr.raw, type = "R")
22 | x <- qcc(my.xbr.raw, type = "xbar", label.limits = c(100, 200))
23 | x <- qcc(my.xbr.raw, type = "xbar", label.limits = c("LCL", "UCL"))
24 | x <- qcc(my.xbr.raw, type = "xbar", label.limits = c("LCL", "UCL"), label.cl = "CL")
25 | x <- qcc(my.xbr.raw, type = "xbar", label.limits = c("LCL", "UCL"), label.cl = 500)
26 | x <- qcc(my.xbr.raw, type = "xbar", label.limits = c(100, 200), label.cl = 500)
27 | 
28 | 
29 | #' variable limits
30 | data(pistonrings)
31 | attach(pistonrings)
32 | out <- c(9, 10, 30, 35, 45, 64, 65, 74, 75, 85, 99, 100)
33 | diameter <- qcc.groups(pistonrings$diameter[-out], pistonrings$sample[-out])
34 | x <- qcc(diameter[1:25,], type="xbar", plot = TRUE)
35 | x <- qcc(diameter[1:25,], type="R", plot = TRUE)
36 | x <- qcc(diameter[1:25,], type="S", plot = TRUE)
37 | x <- qcc(diameter[1:25,], type="xbar", newdata=diameter[26:40,], plot = TRUE)
38 | x <- qcc(diameter[1:25,], type="R", newdata=diameter[26:40,], plot = TRUE)
39 | x <- qcc(diameter[1:25,], type="S", newdata=diameter[26:40,], plot = TRUE)
40 | detach(pistonrings)
41 | 
42 | data(circuit)
43 | attach(circuit)
44 | qcc(circuit$x[circuit$trial], sizes=circuit$size[circuit$trial], type="c")
45 | # remove out-of-control points (see help(circuit) for the reasons)
46 | inc <- setdiff(which(circuit$trial), c(6,20))
47 | qcc(circuit$x[inc], sizes=circuit$size[inc], type="c", labels=inc)
48 | qcc(circuit$x[inc], sizes=circuit$size[inc], type="c", labels=inc, 
49 |     newdata=circuit$x[!circuit$trial], newsizes=circuit$size[!circuit$trial], newlabels=which(!circuit$trial))
50 | qcc(circuit$x[inc], sizes=circuit$size[inc], type="u", labels=inc, 
51 |     newdata=circuit$x[!circuit$trial], newsizes=circuit$size[!circuit$trial], newlabels=which(!circuit$trial))
52 | detach(circuit)
53 | 
54 | data(pcmanufact)
55 | attach(pcmanufact)
56 | qcc(pcmanufact$x, sizes=pcmanufact$size, type="u")
57 | detach(pcmanufact)
58 | 
59 | data(dyedcloth)
60 | attach(dyedcloth)
61 | qcc(dyedcloth$x, sizes=dyedcloth$size, type="u")
62 | # standardized control chart
63 | detach(dyedcloth)
64 | 
65 | data(orangejuice)
66 | attach(orangejuice)
67 | qcc(orangejuice$D[orangejuice$trial], sizes=orangejuice$size[orangejuice$trial], type="p")
68 | 
69 | # remove out-of-control points (see help(orangejuice) for the reasons)
70 | inc <- setdiff(which(orangejuice$trial), c(15,23))
71 | q1 <- qcc(orangejuice$D[inc], sizes=orangejuice$size[inc], type="p")
72 | qcc(orangejuice$D[inc], sizes=orangejuice$size[inc], type="p", newdata=orangejuice$D[!orangejuice$trial], newsizes=orangejuice$size[!orangejuice$trial]) 
73 | detach(orangejuice)
74 | 
75 | data(orangejuice2)
76 | attach(orangejuice2)
77 | names(orangejuice$D) <- orangejuice$sample
78 | qcc(orangejuice$D[orangejuice$trial], sizes=orangejuice$size[orangejuice$trial], type="p")
79 | q2 <- qcc(orangejuice$D[orangejuice$trial], sizes=orangejuice$size[orangejuice$trial], type="p", newdata=orangejuice$D[!orangejuice$trial], newsizes=orangejuice$size[!orangejuice$trial])
80 | detach(orangejuice2)
81 | 


--------------------------------------------------------------------------------
/qcc.plot.R:
--------------------------------------------------------------------------------
  1 | if(require(ggplot2) == FALSE)  # Used for plotting
  2 |   stop("Could not load library ggplot2. Please install ggplot2 and then source() this file.")
  3 | if(require(grid) == FALSE)     # Used to create plot title and statistics regions
  4 |   stop("Could not load library grid. Please install grid and then source() this file.")
  5 | if(require(gtable) == FALSE)   # Used to align annotations outside the plot region
  6 |   stop("Could not load library gtable. Please install gtable and then source() this file.")
  7 | 
  8 | #' A waiver object. Copied from ggplot2 
  9 | #'
 10 | #' A waiver is a "flag" object, similar to \code{NULL}, that indicates the
 11 | #' calling function should just use the default value.  It is used in certain
 12 | #' functions to distinguish between displaying nothing (\code{NULL}) and
 13 | #' displaying a default value calculated elsewhere (\code{waiver()})
 14 | #'
 15 | #' @export
 16 | #' @keywords internal
 17 | waiver <- function() structure(list(), class = "waiver")
 18 | 
 19 | is.waive <- function(x) inherits(x, "waiver")
 20 | 
 21 | #' @title plot.qcc
 22 | #' @author Scrucca, L. (qcc package)
 23 | #' @author Hopper, T. J. (ggplot/grid rewrite of plot.qcc) \email{tomhopper@@gmail.com}
 24 | #' @copyright (C) 2017 Thomas J. Hopper The MIT License
 25 | #' @description Implementation of plot.qcc using ggplot2 and grid. Version 1.0.6
 26 | #' @details 
 27 | #' @import grid
 28 | #' @import ggplot2
 29 | #' @import gtable
 30 | #' @param x A qcc object to plot.
 31 | #' @param add.stats A boolean flag controlling whether summary statistics are
 32 | #'      printed on the graph.
 33 | #' @param chart.all All boolean flag controlling whether all (old and new) 
 34 | #'      statistics are plotted, or only one or the other
 35 | #' @param label.limits A character vector with to elements containing the 
 36 | #'      labels for the lower control limit line and the upper control limit line. The default
 37 | #'      argument now uses \code{\link{waiver()}} from \link{ggplot2}.
 38 | #' @param title A character string containing the desired plot title. If not 
 39 | #'      supplied, a default will be created. If set to element_blank(), the title will
 40 | #'      not be printed and the control chart will be expanded (i.e. the space normally allocated
 41 | #'      to the title will be given over to plotting the data).
 42 | #' @param xlab A character string containing the desired plot x-axis label. 
 43 | #'      If not supplied, a default will be created.
 44 | #' @param ylab A character string containing the desired plot y-axis label. 
 45 | #'      If not supplied, a default will be created.
 46 | #' @param ylim A two-element numeric vector containing desired limits for the 
 47 | #'      y axis. If not supplied, a default will be created.
 48 | #' @param axes.las An integer indicating the desired orientation of axis labels. 
 49 | #'      See \code{?par} for details. Defaults to 0.
 50 | #' @param digits An integer indicating the number of digits to print. See 
 51 | #'      \code{?getOption} for details. Defaults to getOption("digits")
 52 | #' @param restore.par A boolean indicating whether or not graphic parameters 
 53 | #'      should be restored. Defaults to TRUE.
 54 | #' @param font.size The desired font size in points (pts). Defaults to 12 pts.
 55 | #' @param label.cl A character vector with one element containing the
 56 | #'      label for the central limit line.
 57 | #' @return A \code{grid} object containing the complete plot.
 58 | #' TODO: Add ability to use user-supplied x-axis tick labels. REQUIRES: control
 59 | #'        of breaks on x-axis to avoid overlapping labels.
 60 | #'        Alt: come up with a pretty labeller that works.
 61 | #' TODO: Add ability to control axis orientation, using axes.las.
 62 | #' TODO: Work out a cleaner layout for the stats grid, especially one that maintains
 63 | #'      spacing when resized to larger sizes (i.e. variable positioning of text).
 64 | #' TODO: Add some user control over the theme, e.g. by adding a parameter "theme" and
 65 | #'      passing "theme_grey" or "theme_bw."
 66 | #' TODO: Switch LCL, UCL, Center labels to engineering notation depending on number
 67 | #'        of digits in characters vectors. IDEAL: add user-defined digits to display
 68 | #' ADDED: Limit digits to getOption(), and try to estimate a smaller value from the data.
 69 | #' ADDED: option to control point sizes. Use \code{cex} for backward compatibility
 70 | #'      and \code{size} for ggplot2 compatibility.
 71 | #' FIXED: "Error: `breaks` and `labels` must have the same length" when using newdata argument
 72 | #' FIXED: label.limits requires three arguments instead of two; make three optional
 73 | #' FIXED: when label.limits supplied, text box reports LCL and UCL = labels; should should actual values, and labels only used on graph
 74 | #' FIXED: CL, UCL, LCL labels grid panel is too narrow (showing 40 instead 
 75 | #'  of 400 and 10 instead of 1030). Used \code{paste(..., collapse = '')}.
 76 | #' FIXED: violating.runs only colors first point.
 77 | #' FIXED: beyond.limits only plots only one (first?) point.
 78 | #' FIXED: variable limits do not plot
 79 | #' FIXED: limit labels plot in wrong location.
 80 | #' ADDED: Ability to disable plot main title with title = element_blank()
 81 | 
 82 | plot.qcc <- function(x, add.stats = TRUE, chart.all = TRUE, 
 83 |                      label.limits = waiver(),
 84 |                      title = NULL, xlab = NULL, ylab = NULL, ylim = NULL, axes.las = 0,
 85 |                      digits =  getOption("digits"),
 86 |                      restore.par = TRUE, font.size = 12, size = 4, cex,
 87 |                      plot.new = TRUE,
 88 |                      label.cl = waiver(), ...) 
 89 | {
 90 |   object <- x  # Argh.  Really want to use 'object' anyway
 91 |   
 92 |   if ((missing(object)) | (!inherits(object, "qcc")))
 93 |     stop("an object of class `qcc' is required")
 94 |   
 95 |   #' if point size is the default and \code{cex} is given, we want to change \code{size} 
 96 |   if (size == 4 & !missing(cex)) { 
 97 |     if (size != cex) {
 98 |       size <- cex
 99 |     }
100 |   }
101 |   # collect info from object
102 |   type <- object$type
103 |   std.dev <- object$std.dev
104 |   data.name <- object$data.name
105 |   center <- object$center
106 |   stats <- object$statistics
107 |   limits <- object$limits 
108 |   lcl <- limits[,1]
109 |   ucl <- limits[,2]
110 |   newstats <- object$newstats
111 |   newdata.name <- object$newdata.name
112 |   violations <- object$violations
113 |   #' Set up observation indices
114 |   if(chart.all) { 
115 |     v.statistics <- c(stats, newstats)
116 |     v.indices <- 1:length(v.statistics) 
117 |   } else { 
118 |     if(is.null(newstats)) { 
119 |       v.statistics <- stats
120 |       v.indices <- 1:length(v.statistics) 
121 |     } else { 
122 |       v.statistics <- newstats 
123 |       v.indices <- seq(length(stats)+1, length(stats)+length(newstats)) 
124 |     }
125 |   }
126 |   
127 |   #' Set y-axis limits explicitly so we can re-use them to control
128 |   #' the layout and appearance of other elements in the grid.
129 |   if(is.null(ylim)) ylim <- range(v.statistics, limits, center)
130 |   #' Set x-axis limit explicitly so we can control the appearance
131 |   #' and re-use for other ggplot objects in a grid arrangement.
132 |   xlim <- range(v.indices)
133 |   
134 |   #' Set up axis titles
135 |   #' Set axis titles if not provided by the user
136 |   if(is.null(ylab)) ylab <- c("Group summary statistics")
137 |   if(is.null(xlab)) xlab <- c("Group")
138 |   
139 |   
140 |   #' Create a main graph title. If provided by the user, use that.
141 |   if (!inherits(x=title, what="element_blank")){
142 |     if (is.null(title)) {          # Need to create a plot title
143 |       if (is.null(newstats))  {    # Just for the qcc data used to calculate limits
144 |         main.title <- paste(type, "Chart\nfor", data.name)
145 |       } else {                     # Also have new data (not used for limits calcs)
146 |         if (chart.all){            # Plotting both old and new data
147 |           main.title <- paste(type, "Chart\nfor", data.name, 
148 |                               "and", newdata.name)
149 |         } else {                   # Plotting only the new data
150 |           main.title <- paste(type, "Chart\nfor", newdata.name) 
151 |         }
152 |       }
153 |     } else {main.title <- paste(title)}  # Plot title given by the user
154 |   }
155 |   
156 |   #' Determine significant figures
157 |   #' If \code{digits} is provided (i.e., \code{digits != getOption("digits")}), then use that, 
158 |   #' otherwise estimate the correct number of significant measurement digits. 
159 |   #' Find the largest number of digits in $statistics, then take the smaller of that and 
160 |   #' getOption("digits")
161 |   if(digits == getOption("digits")) {
162 |     #' Assume user did not set a value.
163 |     has.dec <- FALSE
164 |     sig.dig <- rep(0, length(stats))
165 |     for(i in 1:length(stats)) {
166 |       sig.dig[i] <- length(gregexpr("[[:digit:]]", as.character(stats[i]))[[1]])
167 |     }
168 |     sig.figs <- max(sig.dig) # assume numbers with decimals imply significant figures
169 |     if (sig.figs > getOption("digits")) sig.figs <- getOption("digits")
170 |   } else {
171 |     sig.figs <- digits
172 |   }
173 |   
174 |   #' If the default limit labels are used, create new labels using the last values
175 |   #' for center, limits[1] and limits[2].
176 |   #' Possibilities: label.limits is numeric; label.cl is default or text
177 |   #'                label.cl is numeric; label.limits is default or text
178 |   #' Desired result: label.limits is a character vector with 3 elements
179 |   if(is.waive(label.limits)) {
180 |     label.limits <- c(as.character(signif(lcl[length(lcl)], digits = sig.figs)),
181 |                       as.character(signif(ucl[length(ucl)], digits = sig.figs)))
182 |   } else{
183 |     if(is.numeric(label.limits)) {
184 |       label.limits.text <- as.character(c(NA, NA))
185 |       label.limits.text[1] <- as.character(signif(label.limits[1], digits = sig.figs))
186 |       label.limits.text[2] <- as.character(signif(label.limits[2], digits = sig.figs))
187 |       label.limits <- label.limits.text
188 |     }
189 |   }
190 |   if(is.waive(label.cl)) {
191 |     label.cl <- as.character(signif(center[length(center)], digits = sig.figs))
192 |   } else {
193 |     if(is.numeric(label.cl)) {
194 |       label.cl <- as.character(signif(label.cl, digits = sig.figs))
195 |     }
196 |   }
197 |   
198 |   label.limits <- c(label.limits, label.cl)
199 |   
200 |   #' Set up x-axis tick labels
201 |   # x_labels <-  if(is.null(names(statistics))) # statistics is now stats
202 |   #   as.character(indices) else names(statistics) # indices is now v.indices
203 | 
204 |   if(is.null(names(stats))) {
205 |     x_labels = as.character(v.indices) # x_labels = as.character(indices) 
206 |   } else { 
207 |     x_labels = c(as.character(names(stats)), as.character(names(newstats)))
208 |   }
209 |   
210 |   ## PROBLEM: v.indices is numeric; x_labels is character.
211 |   ## TODO: trace calls to ggplot using x_labels, v.indices or df_indices to determine if
212 |   ##       this should always be numeric or always be character. Update qc.data accordingly
213 |   ## RESOLVED: df_indices needs to be numeric
214 |   ## TODO: replace with x_labels with an index
215 |   ## TODO: use x_labels for labels -> axis title; not axis label
216 |   #' create a data frame for use by ggplot
217 |   qc.data <- data.frame(df_indices = v.indices, 
218 |                         df_stats = as.vector(v.statistics),
219 |                         df_labs_x = x_labels)
220 |   
221 |   rm(v.indices, v.statistics, x_labels)
222 |   
223 |   # print(environment())
224 |   # print(nrow(qc.data))
225 |   # print(qc.data)
226 |   
227 |   # plot Shewhart chart
228 |   
229 |   #' Set up the plot
230 |   #' Expand the x axis manually so we can control the position
231 |   #' of CL, UCL and LCL labels outside the plot
232 |   #' Set the plot margins to allow space for the limit labels
233 |   #' TODO: adjust axis and tick labels based on axes.las
234 |   # las
235 |   #   0: parallel to axis
236 |   #   1: horizontal
237 |   #   2: perpendicular to axis
238 |   #   3: vertical
239 |   # angle = [0, 360]
240 |   #  angle=if(las=0) 90 else ...
241 |   #  angle=if(las=0) 0 else ...
242 |   # bp + theme(axis.title.x = element_text(face="bold", colour="#990000", size=20),
243 |   #            axis.text.x  = element_text(angle=90, vjust=0.5, size=16))
244 |   if (axes.las != 0) {
245 |     #' Adjust axis title orientation based on "las" value.
246 |     #' TODO: Need to calculate appropriate angle.
247 |   }
248 |   
249 |   qc.gplot <- ggplot(data = qc.data, environment = environment(), 
250 |                      aes_string(x = "df_indices", y = "df_stats")) +
251 |     theme(
252 |       text = element_text(size = font.size), 
253 |       plot.margin = unit(c(1,1,1,1), "mm")) +
254 |     scale_x_continuous(expand = c(0, 0.5), limits = xlim) #, breaks = qc.data$df_indices, labels = qc.data$df_labs_x
255 |   
256 |   #' Plot dots and connecting lines for the statistic variable
257 |   qc.gplot <- qc.gplot + 
258 |     geom_line(colour = "grey40") + 
259 |     geom_point(shape = 20, size = size) 
260 |   ###
261 |   # Code is broken here
262 |   ###
263 |   qc.gplot <- qc.gplot + ylim(ylim)
264 |   
265 |   #' Add graph labels
266 |   #' The plotting of the graph title may need to change when using grid
267 |   #' main.title will be in a separate viewport
268 |   qc.gplot <- qc.gplot + labs(x = xlab, y = ylab)
269 |   
270 |   #' Add center line
271 |   if(length(center) == 1) {
272 |     #' If there are not steps, just plot a horizontal line for the
273 |     #' individuals average.
274 |     qc.gplot <- qc.gplot + geom_hline(yintercept = center)
275 |     #else lines(indices, c(center, center[length(center)]), type="s")
276 |   } else {
277 |     #' otherwise, we need to plot a stepped center line
278 |     print(center)
279 |     qc.gplot <- qc.gplot + 
280 |       geom_step(aes(x = df_indices, y = c(center, center[length(center)])), direction="hv")
281 |   }
282 |   
283 |   #' Add control limit lines
284 |   if(length(lcl) == 1) {
285 |     #' Likewise for the UCL and LCL lines
286 |     qc.gplot <- qc.gplot + geom_hline(yintercept = lcl, linetype = 2)
287 |     qc.gplot <- qc.gplot + geom_hline(yintercept = ucl, linetype = 2)
288 |   } else {
289 |     #' For variable limits, plot stepped lines for UCL and LCL
290 |     varlimits.df <- data.frame(x.l = qc.data$df_indices, yu.l = ucl[qc.data$df_indices], yl.l = lcl[qc.data$df_indices])
291 |     qc.gplot <- qc.gplot + geom_step(data = varlimits.df, 
292 |                                      aes_string(x = "x.l", y = "yl.l"), 
293 |                                      direction = "hv", linetype = 2)
294 |     qc.gplot <- qc.gplot + geom_step(data = varlimits.df, 
295 |                                      aes_string(x = "x.l", y = "yu.l"), 
296 |                                      direction = "hv", linetype = 2)
297 |   }
298 |   
299 |   #' Violating runs
300 |   #' Identify violating runs.
301 |   if(is.null(qcc.options("violating.runs")))
302 |     stop(".qcc.options$violating.runs undefined. See help(qcc.options).")
303 |   index.r <- rep(NA, length(violations$violating.runs))
304 |   if(length(violations$violating.runs > 0)) { 
305 |     index.r <- violations$violating.runs
306 |     if(!chart.all & !is.null(newstats)) { 
307 |       index.r <- index.r - length(stats) 
308 |       index.r <- index.r[index.r>0] 
309 |     }
310 |     #' Create a data frame to (over)plot violating run points.
311 |     df.runs <- data.frame(x.r = qc.data$df_indices[index.r], y.r = qc.data$df_stats[index.r])
312 |     #' Replot points in violating runs in the adjusted color.
313 |     qc.gplot <- qc.gplot + 
314 |       geom_point(data = df.runs, 
315 |                  aes_string(x = "x.r", y = "y.r"), 
316 |                  colour = qcc.options("violating.runs")$col, 
317 |                  shape = qcc.options("violating.runs")$pch,
318 |                  size = size)
319 |   }
320 |   
321 |   #' Points beyond limits
322 |   #' Identify points beyond limits
323 |   index.b <- rep(NA, length(violations$beyond.limits))
324 |   if(is.null(qcc.options("beyond.limits")))
325 |     stop(".qcc.options$beyond.limits undefined. See help(qcc.options).")
326 |   if(length(violations$beyond.limits > 0)) { 
327 |     index.b <- violations$beyond.limits
328 |     if(!chart.all & !is.null(newstats)) { 
329 |       index.b <- index.b - length(stats) 
330 |       index.b <- index.b[index.b>0] 
331 |     }
332 |     #' Create a data frame to (over)plot beyond limit points.
333 |     df.beyond <- data.frame(x.b = qc.data$df_indices[index.b], y.b = qc.data$df_stats[index.b])
334 |     #' Replot points that are beyond limits.
335 |     qc.gplot <- qc.gplot + 
336 |       geom_point(data = df.beyond, aes_string(x = "x.b", y = "y.b"), 
337 |                  colour = qcc.options("beyond.limits")$col,
338 |                  shape = qcc.options("beyond.limits")$pch,
339 |                  size = size)
340 |   }
341 |   
342 |   #' New Statistics
343 |   #' Plot and label a vertical break line to mark points used for limits calculation from
344 |   #' added points.
345 |   if(chart.all & (!is.null(newstats))) { 
346 |     len.obj.stats <- length(object$statistics)
347 |     len.new.stats <- nrow(qc.data) - len.obj.stats
348 |     qc.gplot <- qc.gplot + geom_vline(xintercept = len.obj.stats + 0.5, linetype = "dotted")
349 |     
350 |   }
351 |   
352 |   #' Generation of QC plot is complete.
353 |   #' Prepare objects to add annotations outside of plot 
354 |   qc.gt <- ggplot_gtable(ggplot_build(qc.gplot))
355 |   qc.index <- subset(qc.gt$layout, name == "panel")
356 |   
357 |   
358 |   #' Add labels "LCL," "UCL," "CL" to control limits and center line.
359 |   #' First, set up a data frame for plotting.
360 |   qc.df.limitslab <- data.frame(x.ll = c(0,0,0), y.ll = c(limits[length(limits[,1]),1], limits[length(limits[,2]),2], center[length(center)]))
361 |   #' Create a new ggplot object for the labels plot.
362 |   qc.p3 <- ggplot(qc.data, aes_string(x = "df_indices", y = "df_stats"), environment = environment()) +
363 |     geom_blank() +
364 |     theme_minimal() +
365 |     theme(line = element_blank(),
366 |           text = element_blank(),
367 |           panel.background = element_rect(colour = NA)) +
368 |     guides(colour = "none") +
369 |     scale_x_continuous(expand = c(0, 0)) +
370 |     ylim(ylim)
371 |   
372 |   qc.p3 <- qc.p3 +
373 |     geom_text(data = qc.df.limitslab,
374 |               aes( x = 0, y = y.ll[1]),
375 |               label = label.limits[1], 
376 |               hjust = 0)
377 |   qc.p3 <- qc.p3 +
378 |     geom_text(data = qc.df.limitslab,
379 |               aes( x = 0, y = y.ll[2]),
380 |               label = label.limits[2], 
381 |               hjust = 0)
382 |   qc.p3 <- qc.p3 +
383 |     geom_text(data = qc.df.limitslab,
384 |               aes( x = 0, y = y.ll[3]),
385 |               label = label.limits[3], 
386 |               hjust = 0)
387 |   
388 |   #' The labels plot is complete; now just grab the "panel" portion of it
389 |   #' for actual display.
390 |   qc.g3 <- gtable_filter(ggplotGrob(qc.p3), "panel")
391 |   
392 |   #' Add gtable columns to draw annotation
393 |   #' to the right for the UCL, LCL and center line labels
394 |   qc.gt <- gtable_add_cols(x=qc.gt, 
395 |                            widths=unit(x=1, units="strwidth", 
396 |                                        data=paste(rep("M",max(nchar(label.limits))), sep = '', collapse = '')), 
397 |                            pos=-1)
398 |   #' Add out labels plot object into the plot grob
399 |   qc.gt <- gtable_add_grob(qc.gt, qc.g3, 
400 |                            t = qc.index$t, 
401 |                            l = ncol(qc.gt), 
402 |                            b = qc.index$b, 
403 |                            r = ncol(qc.gt))
404 |   
405 |   #' If we're plotting newstats, we need another gtable row above the main
406 |   #' plot for the "calibration data..." and "new data in..." labels.
407 |   if(chart.all & (!is.null(newstats))) { 
408 |     #' Set up a data frame for plotting
409 |     qc.df.nslabel <- data.frame(index = qc.data$df_indices[nrow(qc.data)], y = 0)
410 |     #' Create the newdata label
411 |     qc.p2.label2 <- paste("New data in", object$newdata.name)
412 |     #' Calculate the position of the newdata label
413 |     qc.p2.label2.x <- len.obj.stats + len.new.stats/2
414 |     #' Create the ggplot object
415 |     qc.p2 <- ggplot(qc.data, aes_string(x = "df_indices", y = "df_stats"), environment = environment()) +
416 |       geom_blank() +
417 |       theme_minimal() +
418 |       theme(line = element_blank(),                   # Prevent display axis lines, etc.
419 |             text = element_blank(),                   # Prevent display of labels, etc.
420 |             panel.background = element_rect(colour = NA)) +
421 |       scale_x_continuous(expand = c(0, 0.5), limits = xlim) +
422 |       guides(colour = "none")
423 |     
424 |     qc.p2 <- qc.p2 +
425 |       geom_text(data = qc.df.nslabel,
426 |                 aes(x = len.obj.stats / 2, y = 0), 
427 |                 label = paste("Calibration data in", data.name), 
428 |                 hjust = 0.5,
429 |                 vjust = 0) +
430 |       geom_text(data = qc.df.nslabel,
431 |                 aes(x = qc.p2.label2.x, y = 0), 
432 |                 label = qc.p2.label2, 
433 |                 hjust = 0.5,
434 |                 vjust = 0)
435 |     
436 |     #' Get just the panel from qc.p2
437 |     qc.g2 <- gtable_filter(ggplotGrob(qc.p2), "panel")
438 |     #' Add the newstats label plot above the main plat
439 |     qc.gt <- gtable_add_rows(qc.gt, unit(2*font.size, "points"), pos = 0)
440 |     qc.gt <- gtable_add_grob(x = qc.gt, grobs = qc.g2, 
441 |                              t = 1, 
442 |                              l = 4, 
443 |                              b = 1, 
444 |                              r = 4)
445 |   }
446 |   
447 |   #' The user may call qcc.plot as part of their own code or function
448 |   #' for building up a graph object. 
449 |   if (plot.new) {
450 |     grid.newpage()
451 |   }
452 |   
453 |   #' Explicitly create a parent viewport for the whole plot window so that
454 |   #' we are sure to have dimensional information for positioning.
455 |   qc.vp.main <- viewport(gp = gpar(fontsize = font.size))
456 |   pushViewport(qc.vp.main)
457 |   
458 |   #' If the user does not want a graph title, make the title viewport
459 |   #' zero height. Otherwise, make it 4 lines high.
460 |   if (inherits(x=title, what="element_blank")) {
461 |     qc.vp.top.height = unit(0, "npc")
462 |   } else {
463 |     qc.vp.top.height = convertUnit(unit(4, "lines"), "npc")
464 |   }
465 |   
466 |   #' Set the bottom (stats) panel height to zero. If the user
467 |   #' wanted stats printed, we'll expand this later.
468 |   qc.vp.bot.height = convertUnit(unit(0, "lines"), "npc")
469 |   
470 |   #' Set up the top viewport, pinning it to the top of the parent viewport.
471 |   qc.vp.top <- viewport(x = unit(0.5, "npc"), 
472 |                         y = unit(1, "npc"), 
473 |                         height =qc.vp.top.height, 
474 |                         width = unit(1, "npc"), 
475 |                         just = c("centre", "top"), 
476 |                         name = "vptop", 
477 |                         gp = gpar(fontsize = as.numeric(font.size)+2)) # was "lines"
478 |   
479 |   #' Add statistics to the plot (number of groups, limits, etc.)
480 |   if(add.stats) { # computes the x margins of the figure region
481 |     qc.vp.bot.height <- convertUnit(unit(6, "lines"), "npc")
482 |     qc.vp.bot <- viewport(y = unit(0, "npc"), 
483 |                           height =qc.vp.bot.height, 
484 |                           just = c("centre", "bottom"), 
485 |                           name = "vpstat", 
486 |                           gp = gpar(fontsize = font.size))
487 |     pushViewport(qc.vp.bot)
488 |     #grid.rect(gp = gpar(fill = "grey50"))
489 |     #' Set up a tabular layout for the statistics
490 |     stats.x <- unit(rep(NA, 6), "npc")
491 |     stats.y <- unit(rep(NA, 3), "lines")
492 |     stats.x[1] <- unit(0.1, "npc")
493 |     stats.x[2] <- unit(0.3, "npc")
494 |     stats.x[3] <- unit(0.4, "npc")
495 |     stats.x[4] <- unit(0.5, "npc")
496 |     stats.x[5] <- unit(0.58, "npc")
497 |     stats.x[6] <- unit(0.9, "npc")
498 |     stats.y[1] <- unit(3, "lines")
499 |     stats.y[2] <- unit(2, "lines")
500 |     stats.y[3] <- unit(1, "lines")
501 |     grid.text(c("Number of groups ="), 
502 |               x = stats.x[1],
503 |               y = stats.y[1],
504 |               just = c("left"),
505 |               name = "numgroupslab")
506 |     grid.text(as.character(nrow(qc.data)),
507 |               x = stats.x[3],
508 |               y = stats.y[1],
509 |               just = c("left"),
510 |               name = "numgroups")
511 |     #     center <- object$center
512 |     if(length(center) == 1) { 
513 |       grid.text(c("Center ="),
514 |                 x = stats.x[1],
515 |                 y = stats.y[2],
516 |                 just = c("left"),
517 |                 name = "centerlab")
518 |       grid.text(as.character(signif(center[length(center)], digits = sig.figs)),
519 |                 x = stats.x[2],
520 |                 y = stats.y[2],
521 |                 just = c("left"),
522 |                 name = "centerstat")
523 |     } else {
524 |       grid.text(c("Center is variable"),
525 |                 x = stats.x[2],
526 |                 y = stats.y[2],
527 |                 just = c("left"),
528 |                 name = "centerlab")
529 |     }
530 |     grid.text(c("StdDev ="),
531 |               x = stats.x[1],
532 |               y = stats.y[3],
533 |               just = c("left"),
534 |               name = "stdevlab")
535 |     grid.text(as.character(signif(x=std.dev, sig.figs)),
536 |               x = stats.x[2],
537 |               y = stats.y[3],
538 |               just = c("left"),
539 |               name = "stdevstat")
540 |     
541 |     if(length(unique(lcl)) == 1) {
542 |       grid.text(c("LCL ="),
543 |                 x = stats.x[3],
544 |                 y = stats.y[2],
545 |                 just = c("left"),
546 |                 name = "lcllabel")
547 |       grid.text(as.character(signif(lcl[length(lcl)], digits = sig.figs)),
548 |                 x = stats.x[4],
549 |                 y = stats.y[2],
550 |                 just = c("left"),
551 |                 name = "lclstat")
552 |     } else {
553 |       grid.text(c("LCL is variable"),
554 |                 x = stats.x[3],
555 |                 y = stats.y[2],
556 |                 just = c("left"),
557 |                 name = "lcllabel")
558 |     }
559 |     if(length(unique(ucl)) == 1) {
560 |       grid.text(c("UCL ="),
561 |                 x = stats.x[3],
562 |                 y = stats.y[3],
563 |                 just = c("left"),
564 |                 name = "ucllabel")
565 |       grid.text(as.character(signif(ucl[length(ucl)], digits = sig.figs)),
566 |                 x = stats.x[4],
567 |                 y = stats.y[3],
568 |                 just = c("left"),
569 |                 name = "uclstat")
570 |     } else { 
571 |       grid.text(c("UCL is variable"),
572 |                 x = stats.x[3],
573 |                 y = stats.y[3],
574 |                 just = c("left"),
575 |                 name = "ucllabel")
576 |     }
577 |     if(!is.null(violations)) {
578 |       grid.text(c("Number beyond limits ="),
579 |                 x = stats.x[5],
580 |                 y = stats.y[2],
581 |                 just = c("left"),
582 |                 name = "beyondlabel")
583 |       grid.text(as.character(length(unique(violations$beyond.limits))),
584 |                 x = stats.x[6],
585 |                 y = stats.y[2],
586 |                 just = c("left"),
587 |                 name = "beyondstat")        
588 |       grid.text(c("Number violating limits ="),
589 |                 x = stats.x[5],
590 |                 y = stats.y[3],
591 |                 just = c("left"),
592 |                 name = "violatinglabel")
593 |       grid.text(as.character(length(unique(violations$violating.runs))),
594 |                 x = stats.x[6],
595 |                 y = stats.y[3],
596 |                 just = c("left"),
597 |                 name = "violatingstat")        
598 |     }
599 |     popViewport()
600 |   }
601 |   
602 |   #' Set up the main plot viewport
603 |   #' 
604 |   qc.vp.plt.height = unit(1 - as.numeric(qc.vp.bot.height) - as.numeric(qc.vp.top.height), "npc")
605 |   qc.vp.plt.y = unit(as.numeric(qc.vp.bot.height) + as.numeric(qc.vp.plt.height) / 2, "npc")
606 |   qc.vp.plt <- viewport(y = qc.vp.plt.y, 
607 |                         height =qc.vp.plt.height, 
608 |                         just = c("centre","center"), 
609 |                         name = "vpplot", 
610 |                         gp = gpar(fontsize = font.size))
611 |   #                        xscale = ggplot_build(qc.gplot)$panel$ranges[[1]]$x.range,
612 |   #                        yscale = ggplot_build(qc.gplot)$panel$ranges[[1]]$y.range)
613 |   
614 |   #' Draw the main graph title
615 |   if (!inherits(x=title, what="element_blank")){ 
616 |     pushViewport(qc.vp.top)
617 |     #grid.rect(gp = gpar(fill = "gray80"), 
618 |     #          name = "titlerect")
619 |     grid.text(main.title, name = "titletext", 
620 |               gp = gpar(fontsize = as.numeric(font.size) + 2, fontface = "bold"),
621 |               x = 0.5, 
622 |               y = unit(1, "npc") - unit(1, "lines"), 
623 |               just = c("centre","center"))
624 |     
625 |     popViewport()
626 |   }  
627 |   
628 |   #' Plot the graph
629 |   pushViewport(qc.vp.plt)
630 |   
631 |   grid.draw(qc.gt)
632 |   
633 |   
634 |   popViewport()
635 |   
636 |   invisible()
637 | }
638 | 
639 | #' Replace the qcc package plot function with our custom function.
640 | unlockBinding(sym="plot.qcc", env=getNamespace("qcc"));
641 | assignInNamespace(x="plot.qcc", value=plot.qcc, ns=asNamespace("qcc"), envir=getNamespace("qcc"));
642 | assign("plot.qcc", plot.qcc, envir=getNamespace("qcc"));
643 | lockBinding(sym="plot.qcc", env=getNamespace("qcc"));
644 | 


--------------------------------------------------------------------------------