Test functions for V module.

R/fnc_flt_Vdata.R

@@ -0,0 +1,24 @@
+#' @title flt_Vdata.
+#' @description \code{flt_Vdata} will filter a V data table for specific analytes and levels.
+#' @param x The imported V data.
+#' @param a Analyte name(s).
+#' @param l Level name(s). Will be used to determine the maximum range of levels.
+#' @return A object 'res' from an RData file.
+#' @examples
+#' inp <- system.file(package = "eCerto", "extdata", "eCerto_Testdata_VModule.xlsx")
+#' tab <- eCerto:::read_Vdata(file = inp)
+#' eCerto:::flt_Vdata(x = tab, l = c(2,3), a = c("PFOA", "PFBA"))
+#' eCerto:::flt_Vdata(x = tab, l = c(2,5), a = "PFBA")
+#' @keywords internal
+#' @noRd
+flt_Vdata <- function(x = NULL, l = NULL, a = NULL) {
+  if (!is.null(l)) {
+    l_rng <- range(which(levels(x[,"Level"]) %in% l))
+    l_rng <- seq(min(l_rng), max(l_rng))
+    x <- x[as.numeric(x[,"Level"]) %in% l_rng,]
+  }
+  if (!is.null(a)) {
+    x <- x[as.character(x[,"Analyte"]) %in% a,]
+  }
+  return(x)
+}

R/fnc_prepDataV1.R

@@ -6,6 +6,11 @@
 #' @param a Analyte name.
 #' @param l Level name.
 #' @param fmt Export format of the data.
+#' @examples
+#' inp <- system.file(package = "eCerto", "extdata", "eCerto_Testdata_VModule.xlsx")
+#' tab <- eCerto:::read_Vdata(file = inp)
+#' ab <- eCerto:::prepDataV1(tab = tab, a = "PFOA", l = c("2", "7"), fmt = "norm")
+#' str(ab)
 #' @return A data frame.
 #' @keywords internal
 #' @noRd
@@ -17,7 +22,7 @@ prepDataV1 <- function(tab = NULL, a = NULL, l = NULL, fmt = c("raw", "norm", "r
       fmt,
       "raw" = levels(tab[,"Analyte"])[1],
       "norm" = levels(tab[,"Analyte"])[1],
-      "rel_norm" = levels(tab[,"Analyte"])[1]
+      "rel_norm" = levels(tab[,"Analyte"])
     )
   }
   stopifnot(all(a %in% levels(tab[,"Analyte"])))

R/fnc_prepFigV1.R

@@ -3,6 +3,11 @@
 #' @details tbd.
 #' @param ab The ab() object from the validation module..
 #' @return A figure.
+#' @examples
+#' inp <- system.file(package = "eCerto", "extdata", "eCerto_Testdata_VModule.xlsx")
+#' tab <- eCerto:::read_Vdata(file = inp)
+#' ab <- eCerto:::prepDataV1(tab = tab, a = "PFOA", l = c("2", "7"), fmt = "rel_norm")
+#' eCerto:::prepFigV1(ab = ab)
 #' @keywords internal
 #' @noRd
 prepFigV1 <- function(ab = NULL) {
@@ -15,14 +20,17 @@ prepFigV1 <- function(ab = NULL) {
   graphics::box(); graphics::axis(2)
   graphics::boxplot(ab, add=TRUE, axes=FALSE, col = grDevices::grey((3+as.numeric(attr(ab, "Level")))/(5+max(as.numeric(attr(ab, "Level"))))))
 
+  # get position of right alignment of labels
+  x_ann <- par("usr")[1]
+
   # show Analyte-ID and Level-ID
-  graphics::mtext(text = "Analyte-ID", side = 3, line = 1.5, at = 0, adj = 1)
+  graphics::mtext(text = "Analyte-ID", side = 3, line = 1.5, at = x_ann, adj = 1)
   a_id <- as.numeric(attr(ab, "Analyte"))
   #a_id[duplicated(a_id)] <- "_"
   #mtext(text = a_id[!duplicated(a_id)], side = 3, line = 1.5, at = (1:length(ab))[!duplicated(a_id)])
   #mtext(text = a_id, side = 3, line = 1.5, at = 1:length(ab))
   graphics::mtext(text = a_id[!duplicated(a_id)], side = 3, line = 1.5, at = sapply(split(1:length(ab), a_id), mean))
-  graphics::mtext(text = "Level", side = 3, line = 0.25, at = 0, adj = 1)
+  graphics::mtext(text = "Level", side = 3, line = 0.25, at = x_ann, adj = 1)
   graphics::mtext(text = as.numeric(attr(ab, "Level")), side = 3, line = 0.25, at = 1:length(ab))
 
   # F test to check for Variance homogeneity
@@ -32,12 +40,12 @@ prepFigV1 <- function(ab = NULL) {
   if (!all(is.na(P_F))) {
     F_p_text <- sapply(P_F, function(x) { ifelse(x<=0.01, "**", ifelse(x<=0.05, "*", "ns")) })
     F_p_col <- sapply(P_F, function(x) { ifelse(x<=0.01, 2, ifelse(x<=0.05, "orange", 3)) })
-    graphics::mtext(text = expression(P[F-test]), side = 3, line = 2.75, at = 0, adj = 1)
+    graphics::mtext(text = expression(P[F-test]), side = 3, line = 2.75, at = x_ann, adj = 1)
     graphics::mtext(text = F_p_text, side = 3, line = 2.75, at = sapply(split(1:length(ab), a_id), mean), col=F_p_col)
   }
 
   # show n
-  graphics::mtext(text = expression(n), side = 1, line = 0.25, at = 0, adj = 1)
+  graphics::mtext(text = expression(n), side = 1, line = 0.25, at = x_ann, adj = 1)
   graphics::mtext(text = sapply(ab, length), side = 1, line = 0.25, at = 1:length(ab))
 
   # normality test
@@ -46,7 +54,7 @@ prepFigV1 <- function(ab = NULL) {
   })
   KS_p_text <- sapply(KS_p, function(x) { ifelse(x<=0.01, "**", ifelse(x<=0.05, "*", "ns")) })
   KS_p_col <- sapply(KS_p, function(x) { ifelse(x<=0.01, 2, ifelse(x<=0.05, "orange", 3)) })
-  graphics::mtext(text = expression(P[KS]), side = 1, line = 1.5, at = 0, adj = 1)
+  graphics::mtext(text = expression(P[KS]), side = 1, line = 1.5, at = x_ann, adj = 1)
   graphics::mtext(text = KS_p_text, side = 1, line = 1.5, at = 1:length(ab), col=KS_p_col)
 
   # outlier test Grubbs
@@ -55,7 +63,7 @@ prepFigV1 <- function(ab = NULL) {
   })
   Grubbs_text <- sapply(out_Grubbs, function(x) { ifelse(any(x[,"Grubbs1"]==".01"), "**", ifelse(any(x[,"Grubbs1"]==".05"), "*", "ns")) })
   Grubbs_col <- sapply(out_Grubbs, function(x) { ifelse(any(x[,"Grubbs1"]==".01"), 2, ifelse(any(x[,"Grubbs1"]==".05"), "orange", 3)) })
-  graphics::mtext(text = expression(P[Grubbs1]), side = 1, line = 2.75, at = 0, adj = 1)
+  graphics::mtext(text = expression(P[Grubbs1]), side = 1, line = 2.75, at = x_ann, adj = 1)
   graphics::mtext(text = Grubbs_text, side = 1, line = 2.75, at = 1:length(ab), col=Grubbs_col)
   if (any(Grubbs_text!="ns")) {
     for (i in which(Grubbs_text!="ns")) {
@@ -66,7 +74,7 @@ prepFigV1 <- function(ab = NULL) {
   }
   Grubbs_text <- sapply(out_Grubbs, function(x) { ifelse(any(x[,"Grubbs2"]==".01"), "**", ifelse(any(x[,"Grubbs2"]==".05"), "*", "ns")) })
   Grubbs_col <- sapply(out_Grubbs, function(x) { ifelse(any(x[,"Grubbs2"]==".01"), 2, ifelse(any(x[,"Grubbs2"]==".05"), "orange", 3)) })
-  graphics::mtext(text = expression(P[Grubbs2]), side = 1, line = 4, at = 0, adj = 1)
+  graphics::mtext(text = expression(P[Grubbs2]), side = 1, line = 4, at = x_ann, adj = 1)
   graphics::mtext(text = Grubbs_text, side = 1, line = 4, at = 1:length(ab), col=Grubbs_col)
   if (any(Grubbs_text!="ns")) {
     for (i in which(Grubbs_text!="ns")) {
@@ -82,7 +90,7 @@ prepFigV1 <- function(ab = NULL) {
   })
   NM_text <- sapply(out_Neumann, function(x) { ifelse(x<=0.01, "**", ifelse(x<=0.05, "*", "ns")) })
   NM_col <- sapply(out_Neumann, function(x) { ifelse(x<=0.01, 2, ifelse(x<=0.05, "orange", 3)) })
-  graphics::mtext(text = expression(P[Neumann]), side = 1, line = 5.25, at = 0, adj = 1)
+  graphics::mtext(text = expression(P[Neumann]), side = 1, line = 5.25, at = x_ann, adj = 1)
   graphics::mtext(text = NM_text, side = 1, line = 5.25, at = 1:length(ab), col=NM_col)
 
   invisible(NULL)

R/fnc_prepFigV2.R

@@ -1,11 +1,22 @@
 #' @title fnc_prepFigV2.
 #' @description \code{prepFigV2} will generate Fig.V2 (linearity details).
 #' @details tbd.
-#' @param ab The ab() object from the validation module..
+#' @param tab The imported V data.
+#' @param a Analyte name.
+#' @param alpha Probability of error.
+#' @param k result uncertainty.
+#' @param flt_outliers Logical. Shall outliers, determined via an F-test testing
+#'     the highest residual be removed from the analysis.
+#' @param cex Character expansion of Figure. In an app 1.5 is a nice scaling to
+#'     get a detailed figure comparable to the other text.
+#' @examples
+#' inp <- system.file(package = "eCerto", "extdata", "eCerto_Testdata_VModule.xlsx")
+#' tab <- eCerto:::read_Vdata(file = inp)
+#' eCerto:::prepFigV2(tab = tab, a = "PFOA", alpha = 0.01, cex = 1)
 #' @return A figure.
 #' @keywords internal
 #' @noRd
-prepFigV2 <- function(tab = NULL, a = NULL, alpha = 0.05, k = 3, flt_outliers = flt_outliers, cex = 1.5) {
+prepFigV2 <- function(tab = NULL, a = NULL, alpha = 0.05, k = 3, flt_outliers = FALSE, cex = 1.5) {
   opar <- graphics::par(no.readonly = TRUE)
   on.exit(graphics::par(opar))
   vals <- prepTabV1(tab = tab, a = a, alpha = alpha, k = k, flt_outliers = flt_outliers)

R/fnc_prepFigV3.R

@@ -1,11 +1,17 @@
 #' @title fnc_prepFigV3.
 #' @description \code{prepFigV3} will generate Fig.V3.
 #' @details tbd.
-#' @param x A list of data frames containing a column 'Value'.
+#' @param x A data.frame as imported by V module.
+#' @examples
+#' inp <- system.file(package = "eCerto", "extdata", "eCerto_Testdata_VModule.xlsx")
+#' tab <- eCerto:::read_Vdata(file = inp)
+#' x <- eCerto:::flt_Vdata(x = tab, l = c(2,4), a = "PFBA")
+#' eCerto:::prepFigV3(x = x, cex = 0.8)
 #' @return A figure.
 #' @keywords internal
 #' @noRd
 prepFigV3 <- function(x, cex = 1.5) {
+  stopifnot(all(c("Analyte", "Level", "Area_Analyte", "Area_IS", "rel_norm") %in% colnames(x)))
   opar <- graphics::par(no.readonly = TRUE)
   on.exit(graphics::par(opar))
   m <- length(unique(x[,"Analyte"]))

R/fnc_prepTabV1.R

@@ -11,9 +11,10 @@
 #' @examples
 #' inp <- system.file(package = "eCerto", "extdata", "eCerto_Testdata_VModule.xlsx")
 #' tab <- eCerto:::read_Vdata(file = inp)
+#' eCerto:::prepTabV1(tab = tab, a = "PFOA", alpha = 0.01)
 #' plyr::ldply(levels(tab[,"Analyte"]), function(a) {
 #'     eCerto:::prepTabV1(tab = tab, a = a)
-#' })#'
+#' })
 #' @return A data frame with attributes.
 #' @keywords internal
 #' @noRd
@@ -22,6 +23,9 @@ prepTabV1 <- function(tab = NULL, a = NULL, alpha = 0.05, k = 3, flt_outliers =
   if (is.null(a)) a <- levels(factor(tab[,"Analyte"]))
   stopifnot(all(a %in% levels(factor(tab[,"Analyte"]))))
 
+  alpha <- as.numeric(alpha)
+  k <- as.numeric(k)
+
   plyr::ldply(a, function(a) {
 
     # extract the data
@@ -85,7 +89,7 @@ prepTabV1 <- function(tab = NULL, a = NULL, alpha = 0.05, k = 3, flt_outliers =
       "Analyte" = a,
       "N" = N,
       "n" = n,
-      "alpha" = 0.05,
+      "alpha" = alpha,
       "k" = round(1/k, 2),
       "b0" = stats::coef(df.lm)[1],
       "b1" = stats::coef(df.lm)[2],
@@ -94,7 +98,7 @@ prepTabV1 <- function(tab = NULL, a = NULL, alpha = 0.05, k = 3, flt_outliers =
       "P_Neu_Res" = VonNeumannTest(e, unbiased = FALSE)$p.val,
       "F_Test" = F_Test,
       "LOD" = calc_LOD(x = df$Conc, y = df$Area_norm, alpha = alpha, n = n),
-      "LOQ" = calc_LOQ(x = df$Conc, y = df$Area_norm, alpha = 0.05, n = n, k = k),
+      "LOQ" = calc_LOQ(x = df$Conc, y = df$Area_norm, alpha = alpha, n = n, k = k),
       "c_WR_min" = min(df[,"Conc"]),
       "c_WR_max" = max(df[,"Conc"]),
       "s_yx" = s_yx,

R/fnc_styleTabV1.R

@@ -4,6 +4,13 @@
 #' @param df The data.frame of values.
 #' @param precision Number of digits to display.
 #' @param selected Currently selected row.
+#' @examples
+#' inp <- system.file(package = "eCerto", "extdata", "eCerto_Testdata_VModule.xlsx")
+#' tab <- eCerto:::read_Vdata(file = inp)
+#' out <- plyr::ldply(levels(tab[,"Analyte"]), function(a) {
+#'     eCerto:::prepTabV1(tab = tab, a = a)
+#' })
+#' eCerto:::style_tabV1(df = out, selected = NULL)
 #' @return A datatable object.
 #' @keywords internal
 #' @noRd

R/page_validation.R

@@ -212,20 +212,7 @@ page_validationServer <- function(id, test_data = NULL) {
 
     tab_flt <- shiny::reactive({
       req(tab())
-      x <- tab()
-      if (input$opt_tabV1_useLevels) {
-        req(input$opt_V1_k)
-        l_rng <- range(which(levels(x[,"Level"]) %in% input$opt_V1_k))
-        l_rng <- seq(min(l_rng), max(l_rng))
-        x <- x[as.numeric(x[,"Level"]) %in% l_rng,]
-        #x[,"Level"] <- factor(x[,"Level"])
-      }
-      if (input$opt_tabV1_useAnalytes) {
-        req(input$opt_V1_anal)
-        x <- x[as.character(x[,"Analyte"]) %in% input$opt_V1_anal,]
-        #x[,"Analyte"] <- factor(x[,"Analyte"])
-      }
-      return(x)
+      flt_Vdata(x = tab(), l = if (input$opt_tabV1_useLevels) input$opt_V1_k else NULL, a = if (input$opt_tabV1_useAnalytes) input$opt_V1_anal else NULL)
     })
 
     current_analyte <- shiny::reactiveValues("name" = NULL, "row" = NULL)
@@ -292,6 +279,7 @@ page_validationServer <- function(id, test_data = NULL) {
     # Figures ====
     # Figure V1 ====
     ab <- shiny::reactive({
+      req(tab(), input$opt_V1_anal, input$opt_V1_k)
       ab <- prepDataV1(tab=tab(), a = input$opt_V1_anal, l = input$opt_V1_k, fmt = "rel_norm")
     })