# ==================================================================== #
# TITLE #
# Tools for Data Analysis at Certe #
# #
# AUTHORS #
# Berends MS (m.berends@certe.nl) #
# Meijer BC (b.meijer@certe.nl) #
# Hassing EEA (e.hassing@certe.nl) #
# #
# COPYRIGHT #
# (c) 2019 Certe Medische diagnostiek & advies - https://www.certe.nl #
# #
# LICENCE #
# This R package is free software; you can redistribute it and/or #
# modify it under the terms of the GNU General Public License #
# version 2.0, as published by the Free Software Foundation. #
# This R package 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. #
# ==================================================================== #
#' Tekst van Nelson regels
#'
#' Dit geeft de uitleg van iedere Nelson regel.
#' @param rule Nelson regel
#' @param min.run Standaard is de standaardwaarde volgens Nelson. Minimaal aantal opeenvolgende waarnemingen waaraan de regel moet voldoen.
#' @keywords nelson
#' @export
nelson.text <- function(rule, min.run = nelson.defaultminrun(rule)) {
if (rule == 1) {
tekst <- 'Detecteer waarnemingen >3 sd'
}
if (rule == 2) {
tekst <- 'Detecteer reeks van >= {n} waarnemingen aan dezelfde kant van het gemiddelde'
}
if (rule == 3) {
tekst <- 'Detecteer strikte toename of afname bij >= {n} waarnemingen op een rij'
}
if (rule == 4) {
tekst <- 'Detecteer {n} waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname'
}
if (rule == 5) {
tekst <- 'Detecteer {n-1} van de {n} >2 sd van gemiddelde in dezelfde richting'
}
if (rule == 6) {
tekst <- 'Detecteer {n-1} van de {n} >1 sd van gemiddelde in dezelfde richting'
}
if (rule == 7) {
tekst <- 'Detecteer >= {n} waarnemingen op een rij binnen 1 sd van het gemiddelde'
}
if (rule == 8) {
tekst <- 'Detecteer >= {n} waarnemingen op een rij allen buiten 1sd'
}
tekst <- gsub('{n-1}', min.run - 1, tekst, fixed = TRUE)
tekst <- gsub('{n}', min.run, tekst, fixed = TRUE)
tekst
}
#' Standaardwaarde voor \code{min.run}
#'
#' Bepaal de standaardwaarde van \code{min.run} volgens Nelson per regel.
#' @param rule Nelson regel
#' @keywords nelson
#' @export
nelson.defaultminrun <- function(rule) {
switch(rule,
'1' = 3,
'2' = 9,
'3' = 6,
'4' = 14,
'5' = 3,
'6' = 5,
'7' = 15,
'8' = 8
)
}
#' Nelson QC regel 1
#'
#' Detecteer waarnemingen >3 sd.
#' @param x Gegevensreeks
#' @param m Standaard is \code{mean(x)}. Gemiddelde.
#' @param s Standaard is \code{sd(x)}. Standaardafwijking.
#' @section Alle Nelson QC regels:
#' \itemize{
#' \item{\code{\link{nelson.rule1}}: Detecteer waarnemingen >3 sd}
#' \item{\code{\link{nelson.rule2}}: Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde}
#' \item{\code{\link{nelson.rule3}}: Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij}
#' \item{\code{\link{nelson.rule4}}: Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname}
#' \item{\code{\link{nelson.rule5}}: Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule6}}: Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule7}}: Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde}
#' \item{\code{\link{nelson.rule8}}: Detecteer >= 8 waarnemingen op een rij allen buiten 1sd}
#' }
#' @keywords nelson
#' @export
nelson.rule1 <- function(x, m = mean(x), s = sd(x)) {
which(abs((x - m) / s) >= 3)
}
#' Nelson QC regel 2
#'
#' Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde.
#' @param x Gegevensreeks
#' @param m Standaard is \code{mean(x)}. Gemiddelde.
#' @param min.run Standaard is \code{\link{nelson.defaultminrun}(2)}. Minimaal aantal opeenvolgende waarnemingen waaraan de regel moet voldoen.
#' @section Alle Nelson QC regels:
#' \itemize{
#' \item{\code{\link{nelson.rule1}}: Detecteer waarnemingen >3 sd}
#' \item{\code{\link{nelson.rule2}}: Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde}
#' \item{\code{\link{nelson.rule3}}: Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij}
#' \item{\code{\link{nelson.rule4}}: Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname}
#' \item{\code{\link{nelson.rule5}}: Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule6}}: Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule7}}: Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde}
#' \item{\code{\link{nelson.rule8}}: Detecteer >= 8 waarnemingen op een rij allen buiten 1sd}
#' }
#' @keywords nelson
#' @export
nelson.rule2 <- function(x, m = mean(x), min.run = nelson.defaultminrun(2)) {
n <- length(x)
counts <- sign(x - m)
result <- counts
for (runlength in 2:min.run)
result <- result + c(counts[runlength:n], rep(0, runlength - 1))
which(abs(result) >= min.run)
}
#' Nelson QC regel 3
#'
#' Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij.
#' @param x Gegevensreeks
#' @param min.run Standaard is \code{\link{nelson.defaultminrun}(3)}. Minimaal aantal opeenvolgende waarnemingen waaraan de regel moet voldoen.
#' @section Alle Nelson QC regels:
#' \itemize{
#' \item{\code{\link{nelson.rule1}}: Detecteer waarnemingen >3 sd}
#' \item{\code{\link{nelson.rule2}}: Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde}
#' \item{\code{\link{nelson.rule3}}: Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij}
#' \item{\code{\link{nelson.rule4}}: Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname}
#' \item{\code{\link{nelson.rule5}}: Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule6}}: Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule7}}: Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde}
#' \item{\code{\link{nelson.rule8}}: Detecteer >= 8 waarnemingen op een rij allen buiten 1sd}
#' }
#' @keywords nelson
#' @export
nelson.rule3 <- function(x, min.run = nelson.defaultminrun(3)) {
# Between 6 waarnemingen you have 5 instances of increasing or decreasing. Therefore min.run - 1.
n <- length(x)
signs <- sign(c(x[-1], x[n]) - x)
counts <- signs
for (rl in 2:(min.run - 1)) {
counts <- counts + c(signs[rl:n], rep(0, rl - 1))
}
which(abs(counts) >= min.run - 1)
}
#' Nelson QC regel 4
#'
#' Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname.
#' @param x Gegevensreeks
#' @param m Standaard is \code{mean(x)}. Gemiddelde.
#' @param min.run Standaard is \code{\link{nelson.defaultminrun}(4)}. Minimaal aantal opeenvolgende waarnemingen waaraan de regel moet voldoen.
#' @param direction.mean Standaard is \code{FALSE}. Met \code{TRUE} test deze functie op 14 waarnemingen op een rij alternerend in richting van het gemiddelde.
#' @section Alle Nelson QC regels:
#' \itemize{
#' \item{\code{\link{nelson.rule1}}: Detecteer waarnemingen >3 sd}
#' \item{\code{\link{nelson.rule2}}: Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde}
#' \item{\code{\link{nelson.rule3}}: Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij}
#' \item{\code{\link{nelson.rule4}}: Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname}
#' \item{\code{\link{nelson.rule5}}: Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule6}}: Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule7}}: Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde}
#' \item{\code{\link{nelson.rule8}}: Detecteer >= 8 waarnemingen op een rij allen buiten 1sd}
#' }
#' @keywords nelson
#' @export
nelson.rule4 <- function(x, m = mean(x), min.run = nelson.defaultminrun(4), direction.mean = FALSE) {
n <- length(x)
if (direction.mean == TRUE) {
signs <- sign(x - m)
} else {
signs <- sign(c(x[-1],x[n]) - x)
}
counts <- signs
fac <- -1
for (rl in 2:min.run) {
counts <- counts + fac * c(signs[rl:n], rep(0, rl - 1))
fac <- -fac
}
counts <- abs(counts)
which(counts >= min.run)
}
#' Nelson QC regel 5
#'
#' Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting.
#' @param x Gegevensreeks
#' @param m Standaard is \code{mean(x)}. Gemiddelde.
#' @param s Standaard is \code{sd(x)}. Standaardafwijking.
#' @param min.run Standaard is \code{\link{nelson.defaultminrun}(5)}. Minimaal aantal opeenvolgende waarnemingen waaraan de regel moet voldoen.
#' @section Alle Nelson QC regels:
#' \itemize{
#' \item{\code{\link{nelson.rule1}}: Detecteer waarnemingen >3 sd}
#' \item{\code{\link{nelson.rule2}}: Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde}
#' \item{\code{\link{nelson.rule3}}: Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij}
#' \item{\code{\link{nelson.rule4}}: Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname}
#' \item{\code{\link{nelson.rule5}}: Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule6}}: Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule7}}: Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde}
#' \item{\code{\link{nelson.rule8}}: Detecteer >= 8 waarnemingen op een rij allen buiten 1sd}
#' }
#' @keywords nelson
#' @export
nelson.rule5 <- function(x, m = mean(x), s = sd(x), min.run = nelson.defaultminrun(5)) {
n <- length(x)
pos <- 1 * ((x - m) / s > 2)
neg <- 1 * ((x - m) / s < -2)
poscounts <- pos
negcounts <- neg
for (rl in 2:min.run) {
poscounts <- poscounts + c(pos[rl:n], rep(0, rl - 1))
negcounts <- negcounts + c(neg[rl:n], rep(0, rl - 1))
}
counts <- apply(cbind(poscounts, negcounts), 1, max)
which(counts >= min.run - 1)
}
#' Nelson QC regel 6
#'
#' Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting.
#' @param x Gegevensreeks
#' @param m Standaard is \code{mean(x)}. Gemiddelde.
#' @param s Standaard is \code{sd(x)}. Standaardafwijking.
#' @param min.run Standaard is \code{\link{nelson.defaultminrun}(6)}. Minimaal aantal opeenvolgende waarnemingen waaraan de regel moet voldoen.
#' @section Alle Nelson QC regels:
#' \itemize{
#' \item{\code{\link{nelson.rule1}}: Detecteer waarnemingen >3 sd}
#' \item{\code{\link{nelson.rule2}}: Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde}
#' \item{\code{\link{nelson.rule3}}: Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij}
#' \item{\code{\link{nelson.rule4}}: Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname}
#' \item{\code{\link{nelson.rule5}}: Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule6}}: Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule7}}: Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde}
#' \item{\code{\link{nelson.rule8}}: Detecteer >= 8 waarnemingen op een rij allen buiten 1sd}
#' }
#' @keywords nelson
#' @export
nelson.rule6 <- function(x, m = mean(x), s = sd(x), min.run = nelson.defaultminrun(6)) {
n <- length(x)
pos <- 1 * ((x - m) / s > 1)
neg <- 1 * ((x - m) / s < -1)
poscounts <- pos
negcounts <- neg
for (rl in 2:min.run) {
poscounts <- poscounts + c(pos[rl:n], rep(0, rl - 1))
negcounts <- negcounts + c(neg[rl:n], rep(0, rl - 1))
}
counts <- apply(cbind(poscounts, negcounts), 1, max)
which(counts >= min.run - 1)
}
#' Nelson QC regel 7
#'
#' Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde.
#' @param x Gegevensreeks
#' @param m Standaard is \code{mean(x)}. Gemiddelde.
#' @param s Standaard is \code{sd(x)}. Standaardafwijking.
#' @param min.run Standaard is \code{\link{nelson.defaultminrun}(7)}. Minimaal aantal opeenvolgende waarnemingen waaraan de regel moet voldoen.
#' @section Alle Nelson QC regels:
#' \itemize{
#' \item{\code{\link{nelson.rule1}}: Detecteer waarnemingen >3 sd}
#' \item{\code{\link{nelson.rule2}}: Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde}
#' \item{\code{\link{nelson.rule3}}: Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij}
#' \item{\code{\link{nelson.rule4}}: Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname}
#' \item{\code{\link{nelson.rule5}}: Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule6}}: Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule7}}: Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde}
#' \item{\code{\link{nelson.rule8}}: Detecteer >= 8 waarnemingen op een rij allen buiten 1sd}
#' }
#' @keywords nelson
#' @export
nelson.rule7 <- function(x, m = mean(x), s = sd(x), min.run = nelson.defaultminrun(7)) {
n <- length(x)
within <- 1 * (abs((x - m) / s) < 1)
counts <- within
for (rl in 2:min.run)
counts <- counts + c(within[rl:n], rep(0, rl - 1))
which(counts >= min.run)
}
#' Nelson QC regel 8
#'
#' Detecteer >= 8 waarnemingen op een rij allen buiten 1sd.
#' @param x Gegevensreeks
#' @param m Standaard is \code{mean(x)}. Gemiddelde.
#' @param s Standaard is \code{sd(x)}. Standaardafwijking.
#' @param min.run Standaard is \code{\link{nelson.defaultminrun}(8)}. Minimaal aantal opeenvolgende waarnemingen waaraan de regel moet voldoen.
#' @section Alle Nelson QC regels:
#' \itemize{
#' \item{\code{\link{nelson.rule1}}: Detecteer waarnemingen >3 sd}
#' \item{\code{\link{nelson.rule2}}: Detecteer reeks van >= 9 waarnemingen aan dezelfde kant van het gemiddelde}
#' \item{\code{\link{nelson.rule3}}: Detecteer strikte toename of afname bij >= 6 waarnemingen op een rij}
#' \item{\code{\link{nelson.rule4}}: Detecteer 14 waarnemingen op een rij alternerend in richting van het gemiddelde, of alternerend in toename en afname}
#' \item{\code{\link{nelson.rule5}}: Detecteer 2 van de 3 >2 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule6}}: Detecteer 4 van de 5 >1 sd van gemiddelde in dezelfde richting}
#' \item{\code{\link{nelson.rule7}}: Detecteer >= 15 waarnemingen op een rij binnen 1 sd van het gemiddelde}
#' \item{\code{\link{nelson.rule8}}: Detecteer >= 8 waarnemingen op een rij allen buiten 1sd}
#' }
#' @keywords nelson
#' @export
nelson.rule8 <- function(x, m = mean(x), s = sd(x), min.run = nelson.defaultminrun(8)) {
n <- length(x)
outofrange <- 1 * (abs((x - m) / s) > 1)
counts <- outofrange
for (rl in 2:min.run)
counts <- counts + c(outofrange[rl:n], rep(0, rl - 1))
which(counts >= min.run)
}
#' Kwaliteitsanalyse o.b.v. Nelson, Westgard of anders
#'
#' Met deze functie kan een gegevensreeks getoetst worden op kwaliteitsregels. Daarnaast wordt getoetst of er een significante lineaire trend bestaat.
#' @rdname qc
#' @param x Gegevensreeks.
#' @param dates Standaard is \code{rep(NA, length(x))}. Datums van gegevenswaarden.
#' @param m Standaard is \code{mean(x)}. Gemiddelde van \code{x} dat gebruikt wordt in de kwaliteitsregels.
#' @param s Standaard is \code{sd(x)}. Standaardafwijking van \code{x} dat gebruikt wordt in de kwaliteitsregels.
#' @param round Standaard is \code{2}. Aantal decimalen waarop alle getallen afgerond worden.
#' @param type Standaard is \code{"Nelson"}. Geldige opties zijn \code{"Nelson"}, \code{"Westgard"}, \code{"AIAG"}, \code{"Montgomery"} of \code{"Healthcare"}. Zie \strong{Rules list} (onderaan) voor meer informatie.
#' @param text.show Standaard is \code{TRUE}. Tekstanalyse weergeven.
#' @param plot.show Standaard is \code{TRUE}. Grafiek weergeven met gemiddelde (zie \code{\link[certedata]{mean}}), EWMA (zie \code{\link{ewma}}), 1-3x de standaardafwijking (zie \code{\link[certedata]{sd}}) en de waarnemingen met eventueel overtreden kwaliteitsregels.
#' @param title Standaard is \code{paste("Kwaliteitscontrole volgens", type)}. Titel van de toets en de grafiek. Tekst tussen sterretjes wordt cursief gemaakt.
#' @param subtitle Standaard is \code{""}. Ondertitel van de grafiek. Tekst tussen sterretjes wordt cursief gemaakt.
#' @param subtitle.colour Standaard is \code{colourpicker("certeblauw")}. Zie ook \code{\link{colourpicker}}. Kleur van de ondertitel.
#' @param plot.withoutrule1 Standaard is \code{FALSE}. Als regel 1 overtreden wordt (zie \code{\link{nelson.rule1}}), de plot opnieuw weergeven met data zonder deze waarnemingen.
#' @param plot.print Standaard is \code{TRUE}. De grafiek direct printen met de functie \code{print}. Met \code{FALSE} wordt de grafiek als ggplot-model geretourneerd.
#' @param x.lbl Standaard is \code{"Waarneming"}. De tekst op de x-as.
#' @param y.lbl Standaard is \code{"Waarde"}. De tekst op de y-as.
#' @param markdown Standaard is \code{FALSE}. Tekstanalyse afdrukken in markdown-formaat met \code{\link{tbl_markdown}}.
#' @param force Standaard is \code{FALSE}. Bij grote afwijkingen wordt de analyse gestaakt. Gebruik deze optie om de analyse te forceren.
#' @param ... Parameters die doorgegeven worden aan \code{qc.test}.
#' @section Rules list:
#' Voor parameter \code{type}: \cr
#' \tabular{lccccc}{
#' \emph{Nelson (N), Westgard (W), AIAG (A), Montgomery (M), Healthcare (H):} \tab N \tab W \tab A \tab M \tab H\cr
#' ---------------------------------------------------------------------------------------\tab ----- \tab ----- \tab ----- \tab ----- \tab -----\cr
#' \strong{#1} Waarnemingen >3 sd \tab 1 \tab 1 \tab 1 \tab 1 \tab 1\cr
#' \strong{#2} Reeks van >= \code{n} waarnemingen aan dezelfde kant van het gemiddelde \tab 9 \tab 9 \tab 7 \tab 8 \tab 8\cr
#' \strong{#3} Strikte toename of afname bij >=\code{n} waarnemingen op een rij \tab 6 \tab - \tab 6 \tab 6 \tab 6\cr
#' \strong{#4} \code{n} waarnemingen op een rij alternerend (gemiddelde of toename/afname)\tab 14 \tab - \tab 14 \tab 14 \tab - \cr
#' \strong{#5} \code{n}-1 van de \code{n} >2 sd van gemiddelde in dezelfde richting \tab 3 \tab 3 \tab 3 \tab 3 \tab 3\cr
#' \strong{#6} \code{n}-1 van de \code{n} >1 sd van gemiddelde in dezelfde richting \tab 5 \tab 5 \tab 5 \tab 5 \tab - \cr
#' \strong{#7} >=\code{n} waarnemingen op een rij binnen 1 sd van het gemiddelde \tab 15 \tab - \tab 15 \tab 15 \tab 15\cr
#' \strong{#8} >=\code{n} waarnemingen op een rij allen buiten 1sd \tab 8 \tab - \tab 8 \tab 8 \tab -
#' }
#' Bron: \url{https://www.qimacros.com/control-chart/nelson-juran-rules.jpg}
#' @keywords nelson westgard qcc qc
#' @export
qc.test <- function(x,
dates = rep(NA, length(x)),
m = mean(x),
s = sd(x),
round = 2,
type = 'Nelson',
text.show = TRUE,
plot.show = TRUE,
title = paste('Kwaliteitscontrole volgens', type),
subtitle = '',
subtitle.colour = colourpicker("certeblauw"),
plot.withoutrule1 = FALSE,
plot.print = TRUE,
x.lbl = 'Waarneming',
y.lbl = 'Waarde',
markdown = FALSE,
force = FALSE) {
if (text.show == FALSE & plot.show == FALSE) {
stop('`text.show` or `plot.show` must be TRUE.')
}
if (!tolower(type) %in% tolower(c('Nelson', 'Westgard', 'AIAG', 'Montgomery', 'Healthcare'))) {
stop('Invalid type: ', type, '.')
}
if (length(boxplot.stats(x)$out) > 30 & force == FALSE) {
stop('Data contains ', format2(length(boxplot.stats(x)$out)), ' outliers.',
'\nUse `force = TRUE` to force analysis.')
}
if (length(boxplot.stats(x)$out) / length(x) > 0.1 & force == FALSE) {
stop('Data consists of ', format2(percent = TRUE, x = length(boxplot.stats(x)$out) / length(x)), '% outliers.',
'\nUse `force = TRUE` to force analysis.')
}
if (length(x) > 250 & force == FALSE) {
stop('Data consists of ', format2(length(x)), ' observations.',
'\nUse `force = TRUE` to force analysis.')
}
hasdates <- !identical(dates, rep(NA, length(x)))
data <- x
markdown.vet <- ''
markdown.cursief <- ''
markdown.kop4 <- ''
if (markdown == TRUE) {
markdown.vet <- '**'
markdown.cursief <- '*'
markdown.kop4 <- '#### '
}
n.nelson1 <- NA
n.totaal <- 0
symbool.gesloten <- 16
symbool.open <- 1
colour.list <- colourpicker('rainbow', length = 8)
# printfunctie voor alle toetsen en plottoevoegingen
printen <- function(regelnr, afw, minimaal.aantal) {
if (length(afw) > 0) {
n.totaal <<- n.totaal + length(afw)
if (regelnr == 1) {
n.nelson1 <<- afw
resultaat <- tibble::tibble('Waarneming' = afw,
'Waarde' = format2(x[afw], round))
if (hasdates) {
resultaat <- cbind(resultaat, 'Datum' = format2(dates[afw], 'dd-mm-yy'))
}
if (plot.show == TRUE) {
grfk <<- grfk + geom_point(data = data.frame(x = afw,
y = data[afw]),
colour = colour.list[regelnr],
shape = symbool.open,
size = 3,
stroke = 1.5)
}
} else {
# x2 <- character(2)
# dates2 <- character(2)
# for (i in 1:length(afw)) {
# afw.laatste <- afw[i] + minimaal.aantal - 1
# x2[i] <- paste(format2(x[afw[i]:afw.laatste], round), collapse = ' / ')
# if (hasdates) {
# dates2[i] <- paste(format2(dates[afw[i]:afw.laatste], 'dd-mm-yy'), collapse = ' / ')
# }
# }
resultaat <- tibble::tibble('Waarnemingen' = paste(afw, 't/m', afw + minimaal.aantal - 1),
'1e waarde' = format2(x[afw], round))
if (hasdates) {
# resultaat <- cbind(resultaat, 'Datums' = dates2)
resultaat <- cbind(resultaat, '1e datum' = format2(dates[afw], 'dd-mm-yy'))
}
if (plot.show == TRUE) {
for (i in 1:length(afw)) {
# voor elke afwijking the lijn plotten
mx <- min(afw[i] + minimaal.aantal - 1, length(x))
grfk <<- grfk + geom_line(data = data.frame(x = afw[i]:mx,
y = data[afw[i]:mx]),
size = 1,
colour = colour.list[regelnr])
for (j in afw[i]:mx) {
# voor elke lijn de punten plotten
yval <- data[j]
symbool <- symbool.open
if (j == afw[i]) {
# eerste punt van iedere lijn met gesloten punt beginnen
symbool <- symbool.gesloten
# cijfer van de fout plotten
y.afstand = max(m + 3 * s, max(data)) - min(m - 3 * s, min(data))
grfk <<- grfk +
geom_point(data = data.frame(x = j,
y = yval + (0.03 * y.afstand)),
colour = 'gray25',
#color = colour.list[regelnr],
shape = symbool.open,
size = 4.5) +
geom_text(data = data.frame(x = j,
y = yval + (0.03 * y.afstand)),
label = regelnr,
hjust = 0.5,
vjust = 0.25,
colour = 'gray25',
#colour = colour.list[regelnr],
size = 3)
}
grfk <<- grfk + geom_point(data = data.frame(x = j,
y = yval),
colour = colour.list[regelnr],
shape = symbool,
size = 2.5)
}
}
}
}
if (text.show == TRUE) {
cat(paste0(markdown.kop4,
'#',
regelnr,
': ',
nelson.text(regelnr, minimaal.aantal),
' ',
markdown.cursief,
'(kleur: ',
colour.name(colour.list[regelnr]),
')',
markdown.cursief))
if (markdown == FALSE) {
cat('\n')
print.data.frame(resultaat, row.names = FALSE, right = FALSE)
} else {
tbl_markdown(resultaat, align = 'c', format.dates = 'd mmm yyyy')
}
cat('\n')
}
}
}
fit <- lm(x ~ c(1:length(x)))
var.p <- summary(fit)$coefficients[2, 4]
if (var.p < 0.05) {
signtoets <- 'Ja'
} else {
signtoets <- 'Nee'
}
var.F <- summary(fit)$fstatistic['value']
var.R2 <- summary(fit)$r.squared
header <- paste(paste0('\n', markdown.vet, title, markdown.vet),
'\n\nAantal waarnemingen: ', length(x),
'\nGemiddelde: ', format2(mean(x), round),
'\nStandaardafwijking: ', format2(sd(x), round),
'\nVariatieco\u00EBffici\u00EBnt: ', format2(cv(x), round),
'\nSpreidingsco\u00EBffici\u00EBnt:', format2(cqv(x), round),
'\nLineair significant: ', paste0(markdown.vet, signtoets, markdown.vet,
' (p = ',
format2(var.p, round),
'; F = ',
format2(var.F, round),
'; R^2 = ',
format2(var.R2, round),
')'),
'\n')
if (markdown == TRUE) {
header <- gsub('R^2', 'R^2^', header, fixed = TRUE)
header <- gsub('\n', '\n\n', header, fixed = TRUE)
}
if (text.show == TRUE) {
cat(header)
}
# plot maken nog voor het testen
if (plot.show == TRUE) {
# if (hasdates & length(dates[is.na(dates)]) == 0) {
# grfk <-
# ggplot(data.frame(x = dates, y = data), aes(x = x, y = y))
# } else {
# grfk <-
# ggplot(data.frame(x = c(1:length(data)), y = data), aes(x = x, y = y))
# }
if (grepl('*.*', title)) {
# expressie van maken met hulpfunctie
title <- markdown.italic(title)
}
if (grepl('*.*', subtitle)) {
# expressie van maken met hulpfunctie
subtitle <- markdown.italic(subtitle)
}
grfk <-
ggplot(data.frame(x = c(1:length(data)), y = data), aes(x = x, y = y)) +
theme_certe(subtitle.colour = ifelse(grepl('(LET OP: zonder ).*(waarneming\\(en\\) >3 sd.)', subtitle),
'red',
subtitle.colour)) +
theme(panel.grid.minor.y = element_blank()) +
labs(title = title,
subtitle = subtitle,
x = x.lbl,
y = y.lbl) +
scale_y_continuous(
limits = c(
min(m - 3 * s, min(data)),
max(m + 3 * s, max(data))),
labels = format.number) +
# waarnemingen:
geom_point(colour = 'darkgray', shape = 4) +
# EWMA:
geom_ribbon(aes(ymin = m, ymax = ewma(y, 0.9)), fill = rgb(0, 1, 0, 0.2)) +
geom_line(aes(x = x, y = ewma(y, 0.9)), size = 0.25, colour = rgb(0, 0.5, 0, 0.5)) +
# gemiddelde, bovenop EWMA plotten:
geom_hline(yintercept = m, size = 0.75, colour = rgb(0, 0.5, 0)) +
# 1sd:
geom_hline(yintercept = m + s, size = 0.75, colour = 'orange', linetype = 3) +
geom_hline(yintercept = m - s, size = 0.75, colour = 'orange', linetype = 3) +
# 2sd:
geom_hline(yintercept = m + 2 * s, size = 0.75, colour = 'orange', linetype = 2) +
geom_hline(yintercept = m - 2 * s, size = 0.75, colour = 'orange', linetype = 2) +
# 3sd:
geom_hline(yintercept = m + 3 * s, size = 0.75, colour = 'red', linetype = 2) +
geom_hline(yintercept = m - 3 * s, size = 0.75, colour = 'red', linetype = 2)
if (var.p < 0.05) {
# met 95% betrouwbaarheidsinterval (level = 0.95) en foutmarges (se = TRUE)
grfk <- grfk +
geom_smooth(colour = rgb(0, 170, 240, maxColorValue = 255),
size = 0.75,
level = 0.95,
method = "lm",
se = TRUE,
alpha = 0.15,
fill = rgb(0, 170, 240, maxColorValue = 255))
}
}
if (text.show == TRUE) {
cat(paste0('\n', markdown.cursief, 'Toetsen:', markdown.cursief, '\n\n'))
}
if (tolower(type) == tolower('Nelson')) {
printen(1, nelson.rule1(x, m, s), 1)
printen(2, nelson.rule2(x, m, 9), 9)
printen(3, nelson.rule3(x, 6), 6)
printen(4, nelson.rule4(x, m, 14, FALSE), 14)
printen(5, nelson.rule5(x, m, s, 3), 3)
printen(6, nelson.rule6(x, m, s, 5), 5)
printen(7, nelson.rule7(x, m, s, 15), 15)
printen(8, nelson.rule8(x, m, s, 8), 8)
} else if (tolower(type) == tolower('Westgard')) {
printen(1, nelson.rule1(x, m, s), 1)
printen(2, nelson.rule2(x, m, 9), 9)
printen(5, nelson.rule5(x, m, s, 3), 3)
printen(6, nelson.rule6(x, m, s, 5), 5)
} else if (tolower(type) == tolower('AIAG')) {
printen(1, nelson.rule1(x, m, s), 1)
printen(2, nelson.rule2(x, m, 7), 7)
printen(3, nelson.rule3(x, 6), 6)
printen(4, nelson.rule4(x, m, 14, FALSE), 14)
printen(5, nelson.rule5(x, m, s, 3), 3)
printen(6, nelson.rule6(x, m, s, 5), 5)
printen(7, nelson.rule7(x, m, s, 15), 15)
printen(8, nelson.rule8(x, m, s, 8), 8)
} else if (tolower(type) == tolower('Montgomery')) {
printen(1, nelson.rule1(x, m, s), 1)
printen(2, nelson.rule2(x, m, 8), 8)
printen(3, nelson.rule3(x, 6), 6)
printen(4, nelson.rule4(x, m, 14, FALSE), 14)
printen(5, nelson.rule5(x, m, s, 3), 3)
printen(6, nelson.rule6(x, m, s, 5), 5)
printen(7, nelson.rule7(x, m, s, 15), 15)
printen(8, nelson.rule8(x, m, s, 8), 8)
} else if (tolower(type) == tolower('Healthcare')) {
printen(1, nelson.rule1(x, m, s), 1)
printen(2, nelson.rule2(x, m, 8), 8)
printen(3, nelson.rule3(x, 6), 6)
printen(5, nelson.rule5(x, m, s, 3), 3)
printen(7, nelson.rule7(x, m, s, 15), 15)
}
if (text.show == TRUE & n.totaal == 0) {
cat('Geen afwijkingen gevonden.\n')
}
if (plot.show == TRUE) {
suppressWarnings(
if (plot.print == TRUE) {
print(grfk)
} else {
# hiermee is het onderstaande deel (zonder Nelson #1) niet meer ter sprake,
# maar kunnen de functies qc.test() en plot2.qcc() wel gevolgd worden door plot2.save()
return(grfk)
}
)
if (plot.withoutrule1 == TRUE & !identical(NA, n.nelson1)) {
x <- x[-n.nelson1]
dates <- dates[-n.nelson1]
plot2.qcc(x = x,
dates = dates,
m = m,
s = s,
round = round,
type = type,
title = title,
subtitle = paste('LET OP: zonder', length(n.nelson1), 'waarneming(en) >3 sd.'),
x.lbl = x.lbl,
y.lbl = y.lbl,
colour.list = colour.list,
force = TRUE
)
}
}
}
#' @rdname qc
#' @export
nelson.test <- function(x, ...) {
qc.test(x, ..., type = 'Nelson')
}
#' @rdname qc
#' @export
westgard.test <- function(x, ...) {
qc.test(x, ..., type = 'Westgard')
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.