Improved CONFIG specification, introducing a e_msg() function respect…

…ing the `silent` option from golem-config.yml.

R/app_config.R

@@ -22,14 +22,9 @@ app_sys <- function(...) {
 #' @noRd
 get_golem_config <- function(
     value,
-    config = Sys.getenv(
-      "GOLEM_CONFIG_ACTIVE",
-      Sys.getenv(
-        "R_CONFIG_ACTIVE",
-        "default"
-      )
-    ),
-    use_parent = TRUE) {
+    config = Sys.getenv("GOLEM_CONFIG_ACTIVE", Sys.getenv("R_CONFIG_ACTIVE", "default")),
+    use_parent = TRUE)
+{
   config::get(
     value = value,
     config = config,

R/app_utils.R

@@ -558,7 +558,7 @@ verify_suggested <- function(pkg) {
 #' @title auto_fill.
 #' @description Fill all empty values (NA) of a vector with the last valid value.
 #' @param x Vector of values possibly containing NA values.
-#' @return NULL.
+#' @return Vector of values without NA values (which are substituted).
 #' @keywords internal
 #' @noRd
 auto_fill <- function(x) {
@@ -571,3 +571,25 @@ auto_fill <- function(x) {
   return(x)
 }
 
+#' @title get_fun_name.
+#' @description Get the name of a calling function.
+#' @param n Function level to go up.
+#' @return Character.
+#' @keywords internal
+#' @noRd
+get_fun_name <- function (n = 0) {
+  n = n + 1
+  cur_call <- sys.call(sys.parent(n))
+  fun_name <- as.character(cur_call)[1]
+  #fun_name = extract_root_and_last_member(fun_name)[["name"]]
+  return(fun_name)
+}
+
+e_msg <- function(x) {
+  if (get_golem_config("silent")) {
+    invisible(NULL)
+  } else {
+    #message("[", get_fun_name(n=1), "]: ", paste(as.character(list(...))))
+    message("[", get_fun_name(n=1), "]: ", x)
+  }
+}

R/fnc_c_filter_data.R

@@ -16,7 +16,7 @@
 #' @keywords internal
 #' @noRd
 c_filter_data <- function(x, c_apm) {
-  if (!get_golem_config("silent")) message("[c_filter_data] filter certification dataset for analyte ", c_apm$name)
+  e_msg(paste("Filtering certification dataset for analyte", c_apm$name))
   if (c_apm$name %in% x[, "analyte"]) {
     x <- x[x[, "analyte"] %in% c_apm$name, ]
     x <- x[!(x[, "ID"] %in% c_apm[["sample_filter"]]), ]

R/fnc_list2rv.R

@@ -25,7 +25,7 @@ list2rv <- function(x = NULL) {
       # import functions for defined data_format schemes
       if (x$General$dataformat_version == "2021-05-27") {
         # Non-legacy upload #####
-        if (!silent) message("RDataImport: Non-legacy upload started")
+        e_msg("Non-legacy upload started")
         # rv should contain all variables from uploaded x except for deprecated once
         # split must be false here, otherwise one name list is of class character
         # the other of class list -> Error
@@ -71,13 +71,13 @@ list2rv <- function(x = NULL) {
         # reset time_stamp with current
         # $$ToDo think if this is really desirable
         setValue(rv, c("General", "time_stamp"), Sys.time())
-        if (!silent) message("RDataImport: Non-legacy upload finished")
+        e_msg("RDataImport: Non-legacy upload finished")
       }
     } else {
       # Legacy upload
-      if (!silent) message("[RDataImport]: Legacy upload started")
+      e_msg("Legacy upload started")
       if ("Certification" %in% names(x) && !is.null(x$Certification)) {
-        if (!silent) message("RDataImport_Server: Cert data transfered")
+        e_msg("Certification data transfered")
         setValue(rv, c("Certification", "data"), x[["Certification"]][["data_input"]])
         setValue(rv, c("Certification", "input_files"), x[["Certification"]][["input_files"]])
         # save
@@ -104,7 +104,7 @@ list2rv <- function(x = NULL) {
         setValue(rv, c("General", "apm"), apm)
       }
       if ("Homogeneity" %in% names(x) && !is.null(x$Homogeneity)) {
-        if (!silent) message("RDataImport_Server: Homog data transfered")
+        e_msg("Homogeneity data transfered")
         setValue(rv, c("Homogeneity", "data"), x[["Homogeneity"]][["h_dat"]])
         setValue(rv, c("Homogeneity", "input_files"), x[["Homogeneity"]][["h_file"]])
         # Processing
@@ -113,7 +113,7 @@ list2rv <- function(x = NULL) {
         setValue(rv, c("Homogeneity", "h_Fig_width"), x[["Homogeneity"]][["h_Fig_width"]])
       }
       if ("Stability" %in% names(x) && !is.null(x$Stability)) {
-        if (!silent) message("RDataImport_Server: Stab data transfered")
+        e_msg("Stability data transfered")
         setValue(rv, c("Stability", "input_files"), x[["Stability"]][["s_file"]])
         setValue(rv, c("Stability", "data"), x[["Stability"]][["s_dat"]])
         setValue(rv, c("Stability", "s_vals"), x[["Stability"]][["s_vals"]])

R/fnc_prepTabV1.R

@@ -20,6 +20,8 @@
 #' @noRd
 prepTabV1 <- function(tab = NULL, a = NULL, alpha = 0.05, k = 3, flt_outliers = FALSE) {
 
+  e_msg("Preparing Tab.V1 (statistics) from imported data")
+
   if (is.null(a)) a <- levels(factor(tab[,"Analyte"]))
   stopifnot(all(a %in% levels(factor(tab[,"Analyte"]))))
 

R/fnc_styleTabV1.R

@@ -15,6 +15,7 @@
 #' @keywords internal
 #' @noRd
 style_tabV1 <- function(df, precision = 3, selected = 1) {
+  e_msg("Styling Tab.V1 for HTML output")
   colnames(df) <- gsub("^P_KS_Res$", "P<sub>KS,Res</sub>", colnames(df))
   colnames(df) <- gsub("^P_Neu_Res$", "P<sub>Neu,Res</sub>", colnames(df))
   colnames(df) <- gsub("^P_Mandel$", "P<sub>Mandel</sub>", colnames(df))

R/m_ExcelUpload.R

@@ -83,7 +83,6 @@ m_ExcelUpload_UI <- function(id) {
 #' @keywords internal
 m_ExcelUpload_Server <- function(id, rv = NULL, msession = NULL) {
   ns <- shiny::NS(id)
-  silent <- get_golem_config("silent")
 
   shiny::moduleServer(id, function(input, output, session) {
     # Certification, Homogeneity, Stability -----------------------------------
@@ -167,22 +166,23 @@ m_ExcelUpload_Server <- function(id, rv = NULL, msession = NULL) {
     out <- shiny::reactiveValues(data = NULL, input_files = NULL)
 
     # load from Excel
-    load_from_excel <- function() {
+    load_from_excel <- function(fn = current_file_input()$name, fmt = c("Stability", "Homogeneity", "Certification")) {
+      fmt <- match.arg(fmt)
       load_result <- NULL
       tab_flt <- rv_xlsx_range_select$tab
       # Append File column
-      out$input_files <- current_file_input()$name
+      out$input_files <- fn
       # perform minimal validation checks
-      if (exl_fmt() == "Homogeneity") {
+      if (fmt == "Homogeneity") {
         x <- tab_flt[[1]]
         x <- checkHdata(x)
-        x[, "File"] <- rep(current_file_input()$name[1], nrow(x))
+        x[, "File"] <- rep(fn[1], nrow(x))
         load_result <- x
-      } else if (exl_fmt() == "Certification") {
-        if (!silent) message("[m_ExcelUpload_Server] Load Certification data")
+      } else if (fmt == "Certification") {
+        e_msg("Load Certification data (m_ExcelUpload_Server)")
         # append file info
         for (i in 1:length(tab_flt)) {
-          tab_flt[[i]][["File"]] <- rep(current_file_input()$name[i], nrow(tab_flt[[i]]))
+          tab_flt[[i]][["File"]] <- rep(fn[i], nrow(tab_flt[[i]]))
         }
         # try to convert to data frame
         tabC0 <- tryCatch(
@@ -201,7 +201,7 @@ m_ExcelUpload_Server <- function(id, rv = NULL, msession = NULL) {
           attr(tabC0, "msg") <- "Range specification is on default value"
         }
         load_result <- tabC0
-      } else if (exl_fmt() == "Stability") {
+      } else if (fmt == "Stability") {
         # STABILITY data may come in 3 versions
         # (1) as simple two column format (Date, Value) with separate tables for each analyte
         # (2) as LTS format with a meta data header containing machine info, certification data etc.
@@ -238,7 +238,7 @@ m_ExcelUpload_Server <- function(id, rv = NULL, msession = NULL) {
       {
         req(rv_xlsx_range_select$tab)
         message("[m_ExcelUpload] Load-button clicked")
-        tmp <- try(load_from_excel())
+        tmp <- try(load_from_excel(fn = current_file_input()$name, fmt = exl_fmt()))
         if (inherits(tmp, "try-error") | !is.null(attr(tmp, "msg")) | is.null(tmp)) {
           shinyWidgets::ask_confirmation(
             inputId = "ignore_problems", btn_labels = c("Cancel upload", "Upload anyways"),
@@ -262,15 +262,15 @@ m_ExcelUpload_Server <- function(id, rv = NULL, msession = NULL) {
 
     shiny::observeEvent(input$ignore_problems, {
       if (input$ignore_problems) {
-        tmp <- try(load_from_excel())
+        tmp <- try(load_from_excel(fn = current_file_input()$name, fmt = exl_fmt()))
         out$data <- tmp
       }
     })
 
     # when Excel was uploaded with LOAD-Button...
     shiny::observeEvent(out$data,
       {
-        if (!silent) message("[page_start-ExcelUpload] set rv.Data")
+        message("[page_start-ExcelUpload] set rv.Data")
         setValue(rv, c(exl_fmt(), "data"), out$data)
         setValue(rv, c(exl_fmt(), "input_files"), out$input_files)
         if (exl_fmt() == "Certification") {

R/page_validation.R

@@ -221,13 +221,11 @@ page_validationServer <- function(id, test_data = NULL) {
     # Table V1 ====
     tab_V1 <- shiny::reactive({
       req(tab_flt())
-      message("prepTabV1")
       prepTabV1(tab = tab_flt(), alpha = as.numeric(input$opt_tabV1_alpha), k = as.numeric(input$opt_tabV1_k), flt_outliers = input$opt_tabV1_fltLevels)
     })
 
     output$tab_V1 <- DT::renderDT({
       req(tab_V1(), input$opt_tabV1_k, input$opt_tabV1_alpha, input$opt_tabV1_precision)
-      message("style_tabV1")
       a_name <- shiny::isolate(current_analyte$name)
       a_row <- shiny::isolate(current_analyte$row)
       # correct current row of tab V1 in case that analyte filter is applied

tests/testthat.R

@@ -1,6 +1,9 @@
 library(testthat)
 library(eCerto)
 
+# setting this variable will suppress most eCerto message calls
+Sys.setenv("GOLEM_CONFIG_ACTIVE"="default")
+
 ## run all tests similar to Ctrl+Shift+T in RStudio
 # testthat::test_check(package = "eCerto", reporter=c("minimal", "location"))