changed lisense file name

added a stat_mR()
added Stat_QC(method = mR)

DESCRIPTION

@@ -10,9 +10,10 @@ Description: Scaleable Quality Control makes the determinating quality control
   standard XmR and XbarR charts. Additional methods are avalable for robust analysis of 
   noisy data using xMedian-rMedian calculations and plotting capabilites.   
 Depends: R (>= 2.10)
-License: What license is it under?
+License: GPL-3 | file LICENSE
 Encoding: UTF-8
 LazyData: true
-Suggests: testthat
+Suggests: testthat,
+    gridExtra
 RoxygenNote: 6.0.0
 Imports: ggplot2

R/Qc-meanFUNs.R

@@ -1,12 +1,18 @@
+# General Funs ------------------------------------------------------------
+ZERO <- function(...){0}
+QCrange <- function(y){max(y) - min(y)}
+mR_points<- function(y){c(NA, abs(diff(y)))}
+mR_points_gg <- dispersionFUN(mean, mR_points)
+
 # Xbar.One Functions ------------------------------------------------------
-mR <- function(y) {mean(abs(diff(y)))}
-mR_UCL <- function(y) {mR(y)*3.268}
+mR <- function(y, ...) {mean(abs(diff(y)))}
+mR_UCL <- function(y, ...) {mR(y)*3.268}
 xBar_one_UCL <- function(y) {mean(y) + 2.66 * mR(y)}
 xBar_one_LCL <- function(y) {mean(y) - 2.66 * mR(y)}
 
 # Dispersion Central Limit Functions ----------------------------------------------------
-rBar <- dispersionFUN(function(x){max(x)-min(x)}, mean)
-rMedian <- dispersionFUN(function(x){max(x)-min(x)}, median)
+rBar <- dispersionFUN(QCrange, mean)
+rMedian <- dispersionFUN(QCrange, median)
 sBar <- dispersionFUN(sd, mean)
 
 # Dispersion Limit Functions ----------------------------------------------------

R/Stat_ggproto.R

@@ -1,17 +1,38 @@
 
-Stat_QC <- ggplot2::ggproto("Xbar", ggplot2::Stat,
+Stat_QC <- ggplot2::ggproto("Stat_QC", ggplot2::Stat,
         compute_group = function(data, scales, n=NULL, digits=1, method=NULL ){
-          #print(dfs)
+          #print(data)
+          temp <- aggregate(data=data, y~x, mean)
+          #temp3 <- t(ylines_indv(temp$y))
+          #print(temp)
+          #print(mR_UCL(temp$y))
+          if(method == "mR"){
+            limits_df <- data.frame(yintercept =
+                                      c(
+                                        t(ylines_indv(temp$y))[c(1:2)]
+                                      )
+            )
+            #print(limits_df)
+            limits_df$y = limits_df$yintercept
+            limits_df$x = Inf
+            limits_df$label = round(limits_df$yintercept,digits)
+            print(limits_df)
+            limits_df
+          }else{
+
           limits_df <- data.frame(yintercept =
             c(
               t(QC_Lines(data = data, value = "y", grouping = "x",
                          n=n, method = method))[-c(1:4)]
             )
           )
+          #print(limits_df)
           limits_df$y = limits_df$yintercept
           limits_df$x = Inf
           limits_df$label = round(limits_df$yintercept,digits)
+          #print(limits_df)
           limits_df
+          }
         }
         )
 

R/Stat_mR.r

@@ -0,0 +1,36 @@
+Stat_MR <- ggplot2::ggproto("Stat_MR", ggplot2::Stat,
+      compute_group = function(data, scales){
+        #suppressWarnings()
+        mRs3<- mR_points_gg(data = data, value = "y", grouping = "x")
+         mRs <- data.frame(y=mRs3, x=data$x)
+         #mRs
+
+      }
+
+)
+
+
+stat_mR <- function(mapping = NULL,
+                    data = NULL,
+                    geom = "point",
+                    yintercept = NULL,
+                    position = "identity",
+                    na.rm = FALSE,
+                    show.legend = NA,
+                    inherit.aes = TRUE,
+                    ...) {
+
+  ggplot2::layer(
+    stat = Stat_MR,
+    #yintercept=XBar,
+    data = data,
+    mapping = mapping,
+    geom = geom,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(na.rm = na.rm, ...)
+  )
+
+}
+

R/SummayFUNs.R

@@ -1,7 +1,7 @@
 # 2nd Order Functions ------------------------------------------------------
   # Report Lines for XmR chart
 ylines_indv <- function(y){
-  QC_indv_functions <- list(mR = mR,
+  QC_indv_functions <- list(mR = mR, mR_UCL = mR_UCL,
                             xBar_one_LCL = xBar_one_LCL,
                             mean = mean,
                             xBar_one_UCL = xBar_one_UCL)
@@ -63,6 +63,14 @@ QC_Lines <- function(data=NULL, value=NULL, grouping=NULL, formula=NULL, n=NULL,
                          sBar_LCL = sBar_LCL,
                          sBar = sBar,
                          sBar_UCL = sBar_UCL)}
+         # ,
+         # "mR" = {
+         #   print("hi")
+         #   Lines <- list(N = ZERO, N = ZERO,
+         #                 mean = ZERO, N = ZERO,
+         #                 mR_LCL = ZERO,
+         #                 mR = mR,
+         #                 mR_UCL = mR_UCL)}
   )
 
   unlist(lapply(Lines,

R/future-FUNS.R

@@ -0,0 +1,33 @@
+# Future Functions
+
+#Want to build up for a 3 way control chart. see wheeler_USPC pg. 222
+
+#Right now the mR function only works if the data one dimentional.
+# mR_points_future <- function(y, data=NULL, formula = NULL){
+#   if(is.null(formula)) {
+#     return(c(NA, abs(diff(y))))
+#   }
+#   aggTemp <- aggregate(formula, data=data, FUN=mean)
+#   return(c(NA, abs(diff(aggTemp[, ncol(aggTemp)]))))
+# }
+
+# # mR for three way plot ---------------------------------------------------
+# #Not ready for this think need special stat
+# ggmR <- ggplot(Wheeler108, aes(x=Hour, y=value, group=1)) +
+#   #geom_point() + #geom_line() +
+#   #geom_line(aes(group=interaction(Hour,PressCycle))) +
+#   #geom_line(data = Wheeler108, aes(group=as.factor(Hour))) +
+#   stat_summary(fun.y = "mR_points",
+#                #fun.args = list(data=Wheeler108,
+#                #                 formula=value~Cavity+Hour),
+#                colour = "red", size = 1, geom = c("line") )+
+#   stat_summary(fun.y = "mR_points",
+#                #fun.args = list(data=Wheeler108,
+#                #                 formula=value~Cavity+Hour),
+#                colour = "red", size = 2, geom = c("point"))+
+#   stat_QC(digits = 2, method = "sBar") +
+#   stat_QC_labels(digits = 2, method = "sBar") +
+#   theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))  +
+#   facet_grid(.~Cavity, scales = "free_x") # + theme_bw()
+#
+# ggmR

TestFunctions.R

@@ -2,15 +2,19 @@ require(rQC)
 require(plyr)
 require(ggplot2)
 require(gridExtra)
-##
 
+# Test Data ---------------------------------------------------------------
 
-df <- data.frame(process = rep(1,100), DIN = rnorm(100,0,1), repitition=letters[1:20] )
-df2 <- data.frame(process = rep(2,100), DIN = rnorm(100,5,.5), repitition=letters[1:10] )
+df <- data.frame(process = rep(1,100), DIN = rnorm(100,0,1), repitition=1:20 )
+df2 <- data.frame(process = rep(2,100), DIN = rnorm(100,5,.5), repitition=1:10 )
 df_all <- rbind(df, df2)
 df_all$x <- rep(1:100, times=2)
 df_all$regions <- rep(c("top", "bottom"), each=50)
 
+# Basic Test Data ---------------------------------------------------------
+
+
+
 mR(y=df_all$DIN)
 xBar_one_UCL(y=df_all$DIN)
 xBar_one_LCL(y=df_all$DIN)
@@ -49,6 +53,7 @@ aggregate(formula=DIN~process+regions+repitition, data=df_all, FUN=length)
 # xBar_Bar(df_all, "DIN", "repitition")
 # xMedian_Bar(df_all, "DIN", "repitition")
 
+# Wheeler Data 2 way XbarR ------------------------------------------------
 Wheeler108 <- read.csv(file = "tests/testthat/Wheeler_USPC_103.csv", header=T)
 head(Wheeler108)
 
@@ -64,11 +69,11 @@ ddply(Wheeler108,
         QC_Lines(data = df, formula = value~Cavity+Hour)}  )
 
 
-aov.mdl <- aov(value~as.factor(Hour)/PressCycle+Cavity, data=Wheeler108)
-summary(aov.mdl)
+# aov.mdl <- aov(value~as.factor(Hour)/PressCycle+Cavity, data=Wheeler108)
+# summary(aov.mdl)
 
-require(BHH2)
-anovaPlot(aov.mdl, labels = T)
+# require(BHH2)
+# anovaPlot(aov.mdl, labels = T)
 
 #ggplot(Wheeler108, aes(x=Hour, y=value, group=Cavity)) +
 Wheeler108$Hour_Cycle <- paste0(Wheeler108$Hour, "_", Wheeler108$PressCycle)
@@ -82,9 +87,6 @@ ggplot(Wheeler108, aes(x=Hour, y=value, group=1)) +
   stat_QC_labels(digits = 2) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))  +
   facet_grid(.~Cavity, scales = "free_x") # + theme_bw()
 
-QCrange <- function(x){
-  max(x) - min(x)
-}
 
 
 
@@ -99,7 +101,7 @@ ggvalues <- ggplot(Wheeler108, aes(x=Hour, y=value, group=1)) +
   theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))  +
   facet_grid(.~Cavity, scales = "free_x") # + theme_bw()
 
-ggDispersion <- ggplot(Wheeler108, aes(x=Hour, y=value, group=1)) +
+ggDispersion <- ggplot(Wheeler108, aes(x=as.factor(Hour), y=value, group=1)) +
   #geom_point() + #geom_line() +
   #geom_line(aes(group=interaction(Hour,PressCycle))) +
   #geom_line(data = Wheeler108, aes(group=as.factor(Hour))) +
@@ -111,3 +113,52 @@ ggDispersion <- ggplot(Wheeler108, aes(x=Hour, y=value, group=1)) +
   facet_grid(.~Cavity, scales = "free_x") # + theme_bw()
 
 grid.arrange(ggvalues, ggDispersion, nrow=2)
+
+
+# Background XmR Stuff ----------------------------------------------------
+mR_points(df$y)
+
+##mR by group##
+ddply(.data = df_all, .variables = "process",
+        mutate, mR =  mR_points(DIN))
+
+#head(df_all)
+# aggregate(formula=DIN~process, FUN=mR_points, data=df_all)
+   # plot(mR_points(x), ylim=c(0,5))
+ # abline(h = c(mR(x), mR_UCL(x)))
+ # mR_points(formula = value~Cavity+Hour, data =Wheeler108 )
+ #mR_points(df$y)
+ df <- data.frame(x=1:10, y=rnorm(n = 10,mean = 10, sd = 1))
+  mR_points3(df, formula = y~x, )
+ head(df)
+qplot(data=df, x=x, y=y) +
+  stat_mR(color="red") +
+  stat_mR(color="red", geom="line")
+
+
+# Two Way XmR Chart -------------------------------------------------------
+ggX <- ggplot(data = df_all, aes(x=repitition,y=DIN)) +
+  geom_point(alpha=.3) +
+  stat_summary(fun.y = mean, color="black", geom=c("line")) +
+  stat_summary(fun.y = mean, color="black", geom=c("point")) +
+  stat_QC(digits = 2) +
+  stat_QC(digits = 2, n=1, color="blue") + #indv
+  stat_QC_labels(digits=2) +
+
+  facet_grid(.~process, scales = "free_x")
+
+#df_all2<-transform(df_all, repitition=as.factor(repitition))
+ggmR <- ggplot(data = df, aes(x,y)) +
+  #geom_point() +
+  stat_mR(color="red", geom=c("line")) +
+  stat_mR(color="red")  +
+  stat_QC(digits = 2, method="mR") # +
+  #facet_grid(.~process, scales = "free_x")
+
+
+ggRbar <- ggplot(data = df_all, aes(x=repitition,y=DIN)) +
+  #geom_point() +
+  stat_summary(fun.y = "QCrange", color="blue", geom = "point") +
+  stat_QC(digits=2, method="rBar") +facet_grid(.~process, scales = "free_x")
+
+grid.arrange(ggX, ggmR, ggRbar, nrow=3)