From 602f259c63160e66b9341a4f942b492d82d802f5 Mon Sep 17 00:00:00 2001 From: Konrad1991 Date: Tue, 17 Dec 2024 15:22:55 +0100 Subject: [PATCH] added information about outliers to the DoseRespnse --- bs/R/DoseResponse.R | 14 ++++--- bs/R/MainApp.R | 6 ++- bs/R/utils.R | 21 ++++++++-- bs/R/visualisation.R | 74 +++++++++++++++++----------------- bs/inst/tinytest/Assumptions.R | 6 --- 5 files changed, 67 insertions(+), 54 deletions(-) diff --git a/bs/R/DoseResponse.R b/bs/R/DoseResponse.R index e509c44..76af1f5 100644 --- 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 index 271ab24..c486e4f 100644 --- 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 index 8c8279d..7d9b94c 100644 --- 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 index e71d710..4f39140 100644 --- 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 index d3694a5..6a665e4 100644 --- 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()