From f116a56bd352fd4a9a9b1a6974ae6de15ab2eb49 Mon Sep 17 00:00:00 2001 From: "konrad.kraemer" Date: Wed, 11 Sep 2024 11:39:27 +0200 Subject: [PATCH] combination of server modules --- Rplots.pdf | Bin 4599 -> 4085 bytes test.txt | 1 - tsf/NAMESPACE | 1 - tsf/R/{Errorclass.R => FunctionUtils.R} | 15 +- tsf/R/IDA_Server.R | 197 +++++++++++++++++------- tsf/R/RunBatch.R | 4 +- tsf/R/parameterSensitivity.R | 34 ++-- tsf/R/server.R | 2 +- tsf/inst/tinytest/test_batch.R | 19 ++- tsf/inst/tinytest/test_create_polynom.R | 8 +- tsf/inst/tinytest/test_lossFct.R | 1 + tsf/inst/tinytest/test_opti.R | 7 + tsf/inst/tinytest/test_sensitivity.R | 11 +- 13 files changed, 205 insertions(+), 95 deletions(-) delete mode 100644 test.txt rename tsf/R/{Errorclass.R => FunctionUtils.R} (87%) diff --git a/Rplots.pdf b/Rplots.pdf index 9c54bf6ceae3809b7ec0a3440a30097256de1b0d..b0bfa298072b7d8cf3ef4c922366a55939620a75 100644 GIT binary patch delta 137 zcmeya{8fH}6|13%iHYGvdvOS3WAqos$)A~ZxMCIbo%2icN)(JXo3j{lPYz(>nq0*H zpV4S?k%05$P(d**3j+lM5Kzcd-~uxY49qPIF~lqkO(uU8NMJEGHL#q#QcwnH!ZATL QZew#Zb1qd?SARDy0A0r;g#Z8m delta 294 zcmew=|6O^46{~@LiJ3X6MO-#E3i`pBRjCSwW|NQbt8tqc85nY@s=E5SaRC6#HbsR1 diff --git a/test.txt b/test.txt deleted file mode 100644 index d2c39c7..0000000 --- a/test.txt +++ /dev/null @@ -1 +0,0 @@ -i: 1 diff --git a/tsf/NAMESPACE b/tsf/NAMESPACE index ca14fa3..af42899 100644 --- a/tsf/NAMESPACE +++ b/tsf/NAMESPACE @@ -1,6 +1,5 @@ # Generated by roxygen2: do not edit by hand -export(ErrorClass) export(batch) export(convertToNum) export(createPolynom) diff --git a/tsf/R/Errorclass.R b/tsf/R/FunctionUtils.R similarity index 87% rename from tsf/R/Errorclass.R rename to tsf/R/FunctionUtils.R index 27ec3b6..e7a5331 100644 --- a/tsf/R/Errorclass.R +++ b/tsf/R/FunctionUtils.R @@ -1,3 +1,5 @@ +# TODO: do not export it anymores + #' ErrorClass class for handling errors #' @description a class for handling error messages #' @@ -6,26 +8,25 @@ ErrorClass <- R6::R6Class( "ErrorClass", public = list( - #' @field message the error message - message = NULL, + #' @field message the error message + message = NULL, #' @field object an R object which can be stored in the class instance if an error and a result should be returned together. object = NULL, - #' @description + #' @description #' create a new ErrorClass Object #' @param message the string describing the error #' @param object is optional if something besides the message should be stored initialize = function(message, object = NULL) { - if(is.null(message)) { + if (is.null(message)) { stop("No message object is passed. Undefined case") } else { self$message <- message - if(!is.null(object)) { + if (!is.null(object)) { self$object <- object } } } - ) ) @@ -43,4 +44,4 @@ addCode <- function(existingFunction, codeVector) { updatedBody <- c(existingBody, newBody) body(existingFunction) <- as.call(updatedBody) existingFunction -} \ No newline at end of file +} diff --git a/tsf/R/IDA_Server.R b/tsf/R/IDA_Server.R index ed2afe2..d3a53da 100644 --- a/tsf/R/IDA_Server.R +++ b/tsf/R/IDA_Server.R @@ -36,72 +36,131 @@ idaServer <- function(id, df_reactive, df_list_reactive, nclicks) { # NOTE: Start of model specific code # =============================================================================== check_inputs <- function() { - rwn(input$H0 != "", "Please enter a value for the Host") - rwn(input$D0 != "", "Please enter a value for the Dye") - rwn(input$kHD != "", "Please enter a value for KaHD") - rwn(!is.na(input$npop), - "Please enter a value for number of particles") - rwn(!is.na(input$ngen), - "Please enter a value for the number of generations") - rwn(!is.na(input$threshold), - "Please enter a value for the error threshold") - rwn(input$kHG_lb != "", - "Please enter a value for the lower boundary of KaHG") - rwn(input$kHG_ub != "", - "Please enter a value for the upper boundary of KaHG") - rwn(input$IHD_lb != "", - "Please enter a value for the lower boundary of I(HD)") - rwn(input$IHD_ub != "", - "Please enter a value for the upper boundary of I(HD)") - rwn(input$ID_lb != "", - "Please enter a value for the lower boundary of I(D)") - rwn(input$ID_ub != "", - "Please enter a value for the upper boundary of I(D)") - rwn(input$I0_lb != "", - "Please enter a value for the lower boundary of I(0)") - rwn(input$I0_ub != "", - "Please enter a value for the upper boundary of I(0)") - rwn(!is_integer(input$npop), - "Please enter an integer value for number of particles") - rwn(!is_integer(input$ngen), - "Please enter an integer value for number of generations") + if (id == "IDA") { + rwn(input$H0 != "", "Please enter a value for the Host") + rwn(input$D0 != "", "Please enter a value for the Dye") + rwn(input$kHD != "", "Please enter a value for KaHD") + rwn(!is.na(input$npop), + "Please enter a value for number of particles") + rwn(!is.na(input$ngen), + "Please enter a value for the number of generations") + rwn(!is.na(input$threshold), + "Please enter a value for the error threshold") + rwn(input$kHG_lb != "", + "Please enter a value for the lower boundary of KaHG") + rwn(input$kHG_ub != "", + "Please enter a value for the upper boundary of KaHG") + rwn(input$IHD_lb != "", + "Please enter a value for the lower boundary of I(HD)") + rwn(input$IHD_ub != "", + "Please enter a value for the upper boundary of I(HD)") + rwn(input$ID_lb != "", + "Please enter a value for the lower boundary of I(D)") + rwn(input$ID_ub != "", + "Please enter a value for the upper boundary of I(D)") + rwn(input$I0_lb != "", + "Please enter a value for the lower boundary of I(0)") + rwn(input$I0_ub != "", + "Please enter a value for the upper boundary of I(0)") + rwn(!is_integer(input$npop), + "Please enter an integer value for number of particles") + rwn(!is_integer(input$ngen), + "Please enter an integer value for number of generations") + } else if(id == "GDA") { + rwn(input$H0 != "", "Please enter a value for the Host") + rwn(input$G0 != "", "Please enter a value for the Guest") + rwn(input$kHD != "", "Please enter a value for KaHD") + rwn(!is.na(input$npop), + "Please enter a value for number of particles") + rwn(!is.na(input$ngen), + "Please enter a value for the number of generations") + rwn(!is.na(input$threshold), + "Please enter a value for the error threshold") + rwn(input$kHG_lb != "", + "Please enter a value for the lower boundary of KaHG") + rwn(input$kHG_ub != "", + "Please enter a value for the upper boundary of KaHG") + rwn(input$IHD_lb != "", + "Please enter a value for the lower boundary of I(HD)") + rwn(input$IHD_ub != "", + "Please enter a value for the upper boundary of I(HD)") + rwn(input$ID_lb != "", + "Please enter a value for the lower boundary of I(D)") + rwn(input$ID_ub != "", + "Please enter a value for the upper boundary of I(D)") + rwn(input$I0_lb != "", + "Please enter a value for the lower boundary of I(0)") + rwn(input$I0_ub != "", + "Please enter a value for the upper boundary of I(0)") + rwn(!is_integer(input$npop), + "Please enter an integer value for number of particles") + rwn(!is_integer(input$ngen), + "Please enter an integer value for number of generations") + } } check_inputs_sensi <- function() { - rwn(input$H0 != "", - "Please enter a value for the Host") - rwn(input$D0 != "", - "Please enter a value for the Dye") - rwn(input$kHD != "", - "Please enter a value for KaHD") - rwn(!is_integer(input$sens_bounds), - "Please enter an integer value for the sensitivity boundary") - rwn(opti_result_created(), - "Please run first an optimization") + if (id == "IDA") { + rwn(input$H0 != "", + "Please enter a value for the Host") + rwn(input$D0 != "", + "Please enter a value for the Dye") + rwn(input$kHD != "", + "Please enter a value for KaHD") + rwn(!is_integer(input$sens_bounds), + "Please enter an integer value for the sensitivity boundary") + rwn(opti_result_created(), + "Please run first an optimization") + } else if (id == "GDA") { + rwn(input$H0 != "", + "Please enter a value for the Host") + rwn(input$G0 != "", + "Please enter a value for the Guest") + rwn(input$kHD != "", + "Please enter a value for KaHD") + rwn(!is_integer(input$sens_bounds), + "Please enter an integer value for the sensitivity boundary") + rwn(opti_result_created(), + "Please run first an optimization") + } } create_lb <- function() { - lb <- convert_all_to_num( - "lower boundaries", - input$kHG_lb, input$I0_lb, input$IHD_lb, input$ID_lb - ) + lb <- "" + if (id == "IDA" || id == "GDA") { + lb <- convert_all_to_num( + "lower boundaries", + input$kHG_lb, input$I0_lb, input$IHD_lb, input$ID_lb + ) + } return(lb) } create_ub <- function() { - ub <- convert_all_to_num( - "upper boundaries", - input$kHG_ub, input$I0_ub, input$IHD_ub, input$ID_ub - ) + ub <- "" + if (id == "IDA" || id == "GDA") { + ub <- convert_all_to_num( + "upper boundaries", + input$kHG_ub, input$I0_ub, input$IHD_ub, input$ID_ub + ) + } return(ub) } create_additional_parameters <- function() { - additionalParameters <- convert_all_to_num( - "Additional Parameters", - input$H0, input$D0, input$kHD - ) - return(additionalParameters) + if (id == "IDA") { + additionalParameters <- convert_all_to_num( + "Additional Parameters", + input$H0, input$D0, input$kHD + ) + return(additionalParameters) + } else if(id == "GDA") { + additionalParameters <- convert_all_to_num( + "Additional Parameters", + input$H0, input$G0, input$kHD + ) + return(additionalParameters) + } } create_npop <- function() { @@ -125,27 +184,49 @@ idaServer <- function(id, df_reactive, df_list_reactive, nclicks) { } get_Model <- function() { - "ida" + if (id == "IDA") { + return("ida") + } else if (id == "GDA") { + return("gda") + } } get_Model_capital <- function() { - "IDA" + if (id == "IDA") { + return("IDA") + } else if (id == "GDA") { + return("GDA") + } } get_K_param <- function() { - "Ka(HG) [M]" + if (id == "IDA" || id == "GDA") { + return("Ka(HG) [M]") + } } get_update_field <- function() { - "IDAupdateField" + if (id == "IDA") { + return("IDAupdateField") + } else if (id == "GDA") { + return("GDAupdateField") + } } get_update_field_sense <- function() { - "IDAupdateFieldSense" + if (id == "IDA") { + return("IDAupdateFieldSense") + } else if (id == "GDA") { + return("GDAupdateFieldSense") + } } get_update_field_batch <- function() { - "IDAupdateFieldBatch" + if (id == "IDA") { + return("IDAupdateFieldBatch") + } else if (id == "GDA") { + return("GDAupdateFieldBatch") + } } # NOTE: End of model specific code # =============================================================================== diff --git a/tsf/R/RunBatch.R b/tsf/R/RunBatch.R index 7c59a4b..44346f5 100644 --- a/tsf/R/RunBatch.R +++ b/tsf/R/RunBatch.R @@ -113,11 +113,11 @@ batch <- function(case, } } -tq <- create_task_queue( + tq <- create_task_queue( case, lowerBounds, upperBounds, list_df, additionalParameters, seed, npop, ngen, Topology, errorThreshold, num_rep, num_cores -) + ) # 4. assign tasks tq$assign() diff --git a/tsf/R/parameterSensitivity.R b/tsf/R/parameterSensitivity.R index bf53afe..d4d6291 100644 --- a/tsf/R/parameterSensitivity.R +++ b/tsf/R/parameterSensitivity.R @@ -59,7 +59,7 @@ sobolVariance <- function(lossFct, env, lb, ub, parameterNames, runAsShiny) { #' In case of *ida* a numeric vector of length 3 is expected which contains the concentration of the host, dye and the *khd* parameter. #' In case of *gda* a numeric vector of length 3 is expected which contains the concentration of the host, guest and the *khd* parameter. #' @param runAsShiny is internally used when running the algorithm from shiny. -#' @return either an instance of ErrorClass if something went wrong. Otherwise plots showing the sensitivity are returned. +#' @return a plot showing the sensitivity #' @examples #' path <- paste0(system.file("examples", package = "tsf"), "/IDA.txt") #' res <- opti("ida", c(1, 0, 0, 0), c(10^9, 10^6, 10^6, 10^6), path, c(4.3, 6.0, 7079458)) @@ -67,41 +67,41 @@ sobolVariance <- function(lossFct, env, lb, ub, parameterNames, runAsShiny) { sensitivity <- function(case, parameters, path, additionalParameters, percentage = NULL, OffsetBoundaries = NULL, runAsShiny = FALSE) { if (!is.character(case)) { - return(ErrorClass$new("case has to be of type character")) + stop("case has to be of type character") } if (!(case %in% c("dba_dye_const", "dba_host_const", "ida", "gda"))) { - return(ErrorClass$new("case is neither dba_dye_const, dba_host_const, ida or gda")) + stop("case is neither dba_dye_const, dba_host_const, ida or gda") } if (!is.data.frame(parameters)) { - return(ErrorClass$new("optimizedParameters have to be of type data.frame")) + stop("optimizedParameters have to be of type data.frame") } if (length(parameters) == 0) { - return(ErrorClass$new("optimizedParameters vector seems to be empty")) + stop("optimizedParameters vector seems to be empty") } if (length(parameters) > 4) { - return(ErrorClass$new("optimizedParameters vector has more than 4 entries")) + stop("optimizedParameters vector has more than 4 entries") } if (case == "hg" && length(additionalParameters) != 1) { - return(ErrorClass$new("additionalParameters have to be of length 1")) + stop("additionalParameters have to be of length 1") } if (case == "ida" && length(additionalParameters) != 3) { - return(ErrorClass$new("additionalParameters have to be of length 3")) + stop("additionalParameters have to be of length 3") } if (case == "gda" && length(additionalParameters) != 3) { - return(ErrorClass$new("additionalParameters have to be of length 3")) + stop("additionalParameters have to be of length 3") } lowerBounds <- NULL upperBounds <- NULL if (!is.null(percentage) && !is.null(OffsetBoundaries)) { - return(ErrorClass$new("percentage and OffserBoundaries cannot be used together")) + stop("percentage and OffserBoundaries cannot be used together") } if (!is.null(percentage)) { if (!is.numeric(percentage)) { - return(ErrorClass$new("Percentage has to be numeric")) + stop("Percentage has to be numeric") } if (percentage < 0.01) { - return(ErrorClass$new("Percentage has to be at least 0.1")) + stop("Percentage has to be at least 0.1") } perturbationFactor <- percentage / 100 lowerBounds <- parameters - (parameters) * perturbationFactor @@ -110,17 +110,17 @@ sensitivity <- function(case, parameters, path, additionalParameters, lowerBounds <- parameters - OffsetBoundaries upperBounds <- parameters + OffsetBoundaries } else { - return(ErrorClass$new("Neither percentage nor OffsetBoundaries were defined")) + stop("Neither percentage nor OffsetBoundaries were defined") } if (!is.character(path) && !is.data.frame(path)) { - return(ErrorClass$new("path has to be of type character or a data.frame")) + stop("path has to be of type character or a data.frame") } df <- NULL if (!is.data.frame(path)) { df <- try(importData(path)) if (class(df) == "try-error") { - return(ErrorClass$new("Could not read file")) + stop("Could not read file") } } else { df <- path @@ -165,9 +165,9 @@ sensitivity <- function(case, parameters, path, additionalParameters, tryCatch(expr = { sobolVariance(lossFct, env, lowerBounds, upperBounds, parameterNames, runAsShiny) }, interrupt = function(e) { - return(ErrorClass$new("Interrputed the calculation of the Sobol indices")) + stop("Interrputed the calculation of the Sobol indices") }, error = function(e) { em <- conditionMessage(e) - return(ErrorClass$new(em)) + return(em) }) } diff --git a/tsf/R/server.R b/tsf/R/server.R index 3459032..03fc196 100644 --- a/tsf/R/server.R +++ b/tsf/R/server.R @@ -142,5 +142,5 @@ server <- function(input, output, session) { hgServer("HG", data, data_batch, nclicks) dbaServer("DBA", data, data_batch, nclicks) idaServer("IDA", data, data_batch, nclicks) - gdaServer("GDA", data, data_batch, nclicks) + idaServer("GDA", data, data_batch, nclicks) } diff --git a/tsf/inst/tinytest/test_batch.R b/tsf/inst/tinytest/test_batch.R index 41d6b18..4307f06 100644 --- a/tsf/inst/tinytest/test_batch.R +++ b/tsf/inst/tinytest/test_batch.R @@ -28,9 +28,24 @@ test_batch <- function() { num_cores = 2, num_rep = 3 # NOTE: thus 6 runs in total ) - lapply(res[[1]], function(x) { - expect_true(x[[3]]$R2 > 0.99) + metrices <- Reduce(rbind, res[[1]][[3]]) + trash <- sapply(metrices$R2, function(x) { + expect_true(x > 0.99) }) + return() } test_batch() + +# test batch gda + +# test batch dba host const + +# test batch dba dye const + +# test batch with invalid: +# - path +# - model +# - additionalParameters +# - num_cores +# - num_rep diff --git a/tsf/inst/tinytest/test_create_polynom.R b/tsf/inst/tinytest/test_create_polynom.R index 354f0fa..6a79628 100644 --- a/tsf/inst/tinytest/test_create_polynom.R +++ b/tsf/inst/tinytest/test_create_polynom.R @@ -20,8 +20,8 @@ test_createPolynom_valid_input() test_createPolynom_invalid_function <- function() { f <- "not_a_function" elimVars <- c("h", "d") - result <- createPolynom(f, elimVars) - expect_true(inherits(result, "ErrorClass")) + result <- try(createPolynom(f, elimVars)) + expect_true(inherits(result, "try-error")) } test_createPolynom_invalid_function() @@ -32,8 +32,8 @@ test_createPolynom_invalid_elimVars <- function() { hd / (h * d) - kd <- 0 } elimVars <- "not_a_character_vector" - result <- createPolynom(f, elimVars) - expect_true(inherits(result, "ErrorClass")) + result <- try(createPolynom(f, elimVars)) + expect_true(inherits(result, "try-error")) } test_createPolynom_invalid_elimVars() diff --git a/tsf/inst/tinytest/test_lossFct.R b/tsf/inst/tinytest/test_lossFct.R index ed63083..0786097 100644 --- a/tsf/inst/tinytest/test_lossFct.R +++ b/tsf/inst/tinytest/test_lossFct.R @@ -38,3 +38,4 @@ test_lossFctGDA_valid_input <- function() { } test_lossFctGDA_valid_input() +# add test for DBA const dye (not hg) diff --git a/tsf/inst/tinytest/test_opti.R b/tsf/inst/tinytest/test_opti.R index 1d7490d..e25814c 100644 --- a/tsf/inst/tinytest/test_opti.R +++ b/tsf/inst/tinytest/test_opti.R @@ -69,3 +69,10 @@ test_gda <- function() { } test_gda() +# test opti for DBA const dye (not hg) + +# create for each model a test. First create random parameter. +# Use these parameters in the loss function to create trajectories. +# Use these trajectories to create a file. Use this file to run opti. +# Check if the R2 value is greater than 0.99 and the parameter is close to the +# original parameter. diff --git a/tsf/inst/tinytest/test_sensitivity.R b/tsf/inst/tinytest/test_sensitivity.R index cf3d412..58480e2 100644 --- a/tsf/inst/tinytest/test_sensitivity.R +++ b/tsf/inst/tinytest/test_sensitivity.R @@ -13,8 +13,15 @@ test_sensitivity_invalid_case <- function() { parameters <- c(1, 2, 3, 4) additionalParameters <- c(5, 6, 7) path <- "invalid_path.txt" - result <- sensitivity("invalid_case", parameters, path, additionalParameters, percentage = 10) - expect_true("ErrorClass" %in% class(result)) + result <- try( + sensitivity("invalid_case", parameters, path, additionalParameters, percentage = 10) + ) + expect_true("try-error" %in% class(result)) } test_sensitivity_invalid_case() +# run sensitivity for gda + +# run sensitivity for dba const host + +# run sensitivity for dba const dye