added information about outliers to the DoseRespnse

ComPlat · Dec 17, 2024 · 602f259 · 602f259
1 parent 3dc8736
commit 602f259
Show file tree

Hide file tree

Showing 5 changed files with 67 additions and 54 deletions.
diff --git a/bs/R/DoseResponse.R b/bs/R/DoseResponse.R
@@ -176,7 +176,7 @@ DoseResponseServer <- function(id, data, listResults) {
         print_err(err)
       } else {
         output$dr_result <- renderTable(resDF, digits = 6)
-        listResults$curr_data <- new("doseResponse", df = resDF, p = resP)
+        listResults$curr_data <- new("doseResponse", df = resDF, p = resP, outlier_info = "")
         listResults$curr_name <- paste(
           "Test Nr", length(listResults$all_names) + 1,
           "Conducted dose response analysis"
@@ -185,7 +185,7 @@ DoseResponseServer <- function(id, data, listResults) {
         new_result_name <- paste0("DoseResponseNr", listResults$counter)
         listResults$all_data[[new_result_name]] <- new(
           "doseResponse",
-          df = resDF, p = resP
+          df = resDF, p = resP, outlier_info = ""
         )
         exportTestValues(
           doseresponse_res = listResults$curr_data
@@ -249,6 +249,7 @@ DoseResponseServer <- function(id, data, listResults) {
       check_dr()
       resDF <- NULL
       resP <- NULL
+      outliers <- NULL
       e <- try(
         {
           outliers <- list(r_vals$outliers[[name]])
@@ -285,10 +286,11 @@ DoseResponseServer <- function(id, data, listResults) {
         output$dr_result <- renderTable(data.frame(), digits = 6)
         print_err(err)
       } else {
-        # TODO: add version for Substance. _S4_V1, _S4_V2 ...
-        # Why does it jump after update?
         output$dr_result <- renderTable(resDF, digits = 6)
-        listResults$curr_data <- new("doseResponse", df = resDF, p = resP)
+        listResults$curr_data <- new(
+          "doseResponse",
+          df = resDF, p = resP, outlier_info = create_outlier_info(r_vals$outliers)
+        )
         listResults$curr_name <- paste(
           "Test Nr", length(listResults$all_names) + 1,
           "Conducted dose response analysis"
@@ -297,7 +299,7 @@ DoseResponseServer <- function(id, data, listResults) {
         new_result_name <- paste0("DoseResponseNr", listResults$counter)
         listResults$all_data[[new_result_name]] <- new(
           "doseResponse",
-          df = resDF, p = resP
+          df = resDF, p = resP, outlier_info = create_outlier_info(r_vals$outliers)
         )
         exportTestValues(
           doseresponse_res = listResults$curr_data

diff --git a/bs/R/MainApp.R b/bs/R/MainApp.R
@@ -444,7 +444,11 @@ app <- function() {
           } else if (inherits(temp, "plot")) {
             output[[paste0("res_", name)]] <- renderPlot(temp@p)
           } else if (inherits(temp, "doseResponse")) {
-            message <- "Dose Response Analysis. Too large to display."
+            message <- paste0(
+              "Dose response analysis. (Outliers: ",
+              paste0(temp@outlier_info, collapse = ";"),
+              "). Too long to display", collapse = " "
+            )
             output[[paste0("res_", name)]] <- renderPrint(message)
           } else {
             output[[paste0("res_", name)]] <- renderPrint(temp)

diff --git a/bs/R/utils.R b/bs/R/utils.R
@@ -97,10 +97,21 @@ setClass("diagnosticPlot",
   )
 )
 
+create_outlier_info <- function(l) {
+  res <- sapply(
+    seq_len(length(l)), function(idx) {
+      n <- names(l)[idx]
+      points <- paste0(l[[idx]], collapse = ", ")
+      paste0(n, ": ", points)
+    }
+  )
+  res
+}
 setClass("doseResponse",
   slots = c(
     df = "data.frame",
-    p = "ANY"
+    p = "ANY",
+    outlier_info = "character"
   )
 )
 
@@ -421,7 +432,8 @@ print_form <- function(formula) {
             modalButton("Close")
           )
         ))
-      )
+      ),
+      type = "message"
     )
   }
   req(!is.null(formula))
@@ -441,7 +453,7 @@ check_axis_limits <- function(col, min, max) {
     choices <- unique(col)
     if (length(choices) == 1) {
       if (!(min == choices && max == choices)) {
-       stop("If only one level is available the max and min value have to be set to this value!")
+        stop("If only one level is available the max and min value have to be set to this value!")
       }
     } else {
       if (!(min %in% choices) || !(max %in% choices)) {
@@ -599,7 +611,8 @@ check_filename_for_serverless <- function(filename) {
 # Split list of plots into panels of 9 plots
 create_plot_pages <- function(plotList) {
   if (length(plotList) == 0) {
-    plotList <- list(ggplot2::ggplot() + ggplot2::geom_point())
+    plotList <- list(ggplot2::ggplot() +
+      ggplot2::geom_point())
   }
   n_full_pages <- floor(length(plotList) / 9)
   if (n_full_pages == 0) {

diff --git a/bs/R/visualisation.R b/bs/R/visualisation.R
@@ -108,7 +108,6 @@ visUI <- function(id) {
 
 visServer <- function(id, data, listResults) {
   moduleServer(id, function(input, output, session) {
-
     # Render axis limits
     output[["XRangeUI"]] <- renderUI({
       req(!is.null(data$df))
@@ -133,7 +132,7 @@ visServer <- function(id, data, listResults) {
       } else {
         choices <- unique(df[[x]])
         return(
-          shinyWidgets::sliderTextInput( # TODO: add everywhere shinyWidgets
+          shinyWidgets::sliderTextInput(
             "VIS-XRange",
             "Select range for x axis:",
             selected = c(choices[1], choices[length(choices)]),
@@ -166,7 +165,7 @@ visServer <- function(id, data, listResults) {
       } else {
         choices <- unique(df[[y]])
         return(
-          shinyWidgets::sliderTextInput( # TODO: add everywhere shinyWidgets
+          shinyWidgets::sliderTextInput(
             "VIS-YRange",
             "Select range for x axis:",
             selected = c(choices[1], choices[length(choices)]),
@@ -355,41 +354,43 @@ visServer <- function(id, data, listResults) {
       }
       p <- tryCatch(
         {
-          withCallingHandlers({
-            if (method == "box") {
-              p <- BoxplotFct(
-                df, x, y, xlabel, ylabel,
-                fill, fillTitle, themeFill,
-                col, colTitle, theme,
-                facetMode, facet, facetScales,
-                input$XRange[1], input$XRange[2], input$YRange[1], input$YRange[2]
-              )
-            } else if (method == "dot") {
-              k <- NULL
-              if (fitMethod == "gam") {
-                req(input$k)
-                k <- input$k
-                if (k <= 0) {
-                  print_warn("k has to be at least 1 and is set to this value")
-                  k <- 1
+          withCallingHandlers(
+            {
+              if (method == "box") {
+                p <- BoxplotFct(
+                  df, x, y, xlabel, ylabel,
+                  fill, fillTitle, themeFill,
+                  col, colTitle, theme,
+                  facetMode, facet, facetScales,
+                  input$XRange[1], input$XRange[2], input$YRange[1], input$YRange[2]
+                )
+              } else if (method == "dot") {
+                k <- NULL
+                if (fitMethod == "gam") {
+                  req(input$k)
+                  k <- input$k
+                  if (k <= 0) {
+                    print_warn("k has to be at least 1 and is set to this value")
+                    k <- 1
+                  }
                 }
+                p <- DotplotFct(
+                  df, x, y, xlabel, ylabel,
+                  fitMethod,
+                  col, colTitle, theme,
+                  facetMode, facet, facetScales, k,
+                  input$XRange[1], input$XRange[2], input$YRange[1], input$YRange[2]
+                )
+              } else if (method == "line") {
+                p <- LineplotFct(
+                  df, x, y, xlabel, ylabel,
+                  col, colTitle, theme,
+                  facetMode, facet, facetScales,
+                  input$XRange[1], input$XRange[2], input$YRange[1], input$YRange[2]
+                )
               }
-              p <- DotplotFct(
-                df, x, y, xlabel, ylabel,
-                fitMethod,
-                col, colTitle, theme,
-                facetMode, facet, facetScales, k,
-                input$XRange[1], input$XRange[2], input$YRange[1], input$YRange[2]
-              )
-            } else if (method == "line") {
-              p <- LineplotFct(
-                df, x, y, xlabel, ylabel,
-                col, colTitle, theme,
-                facetMode, facet, facetScales,
-                input$XRange[1], input$XRange[2], input$YRange[1], input$YRange[2]
-              )
-            }
-          }, warning = function(warn) {
+            },
+            warning = function(warn) {
               print_warn(warn$message)
               invokeRestart("muffleWarning")
             }
@@ -428,6 +429,5 @@ visServer <- function(id, data, listResults) {
       print_req(is.data.frame(data$df), "The dataset is missing")
       plotFct("line")
     })
-
   })
 }
diff --git a/bs/inst/tinytest/Assumptions.R b/bs/inst/tinytest/Assumptions.R
@@ -1,9 +1,3 @@
-# TODO: Tests
-# Add github actions for the test
-# Add test for diagnostic plot
-# add tests for utils functions
-# add tests for plotting internally
-# add tests for lc50 internally
 library(shinytest2)
 library(tinytest)
 app <- bs::app()