remvoed bug in download from eln & fixed bug in saving results of dos…

…e response

bs/.development/DiagnosticPlots.R

@@ -0,0 +1,181 @@
+library(car)
+library(ggplot2)
+library(cowplot)
+
+diagnosticPlots <- function(df, formula) {
+  model <- lm(formula, data = df)
+  resids <- residuals(model)
+  fitted <- fitted(model)
+
+  # Identify influential points
+  p <- length(coef(model))
+  n <- length(resids)
+  leverage <- hatvalues(model)
+  cooks_dist <- cooks.distance(model)
+  high_leverage_threshold <- (2 * (p + 1)) / n
+  high_cooks_threshold <- 4 / n
+  influential_points <- which(
+    leverage > high_leverage_threshold | cooks_dist > high_cooks_threshold
+  )
+
+  # resids vs fitted
+  line_data <- lowess(fitted, resids) |> as.data.frame()
+  resids_fitted_df <- data.frame(fitted = fitted, residuals = resids, index = 1:n)
+  resids_vs_fitted <- ggplot(
+    data = resids_fitted_df,
+    aes(x = fitted, y = residuals)
+  ) +
+    geom_point() +
+    geom_hline(yintercept = 0,
+      linetype = "dashed",
+      color = "black",
+      size = 0.25
+    ) +
+    geom_line(
+      data = line_data,
+      aes(x = x, y = y)
+    ) +
+    geom_text(data = resids_fitted_df[influential_points, ],
+      aes(label = index),
+      vjust = -1,
+      color = "black",
+      size = 3) +
+    labs(
+      y = "Residuals", x = "Fitted values",
+      title = "Residuals vs Fitted values"
+    )
+
+  # qq norm plot
+  standardized_resids <- resids / sd(resids)
+  sqrt_resids <- sqrt(abs(standardized_resids))
+  ordered_resids <- sort(standardized_resids)
+  theoretical_quantiles <- qnorm((1:n) / (n + 1))
+  resids_quantiles_df <- data.frame(
+    quantiles = theoretical_quantiles, residuals = ordered_resids,
+    index = 1:n
+  )
+  slope <- sd(ordered_resids)
+  intercept <- mean(ordered_resids)
+  resids_vs_quantiles <- ggplot(
+    data = resids_quantiles_df,
+    aes(x = quantiles, y = residuals)
+  ) +
+    geom_point() +
+    geom_abline(
+      aes(
+        slope = slope,
+        intercept = intercept
+      )
+    ) +
+    geom_text(data = resids_quantiles_df[influential_points, ],
+      aes(label = index),
+      vjust = -1,
+      color = "black",
+      size = 3) +
+    labs(
+      y = "Standardized residuals", x = "Theoretical Quantiles",
+      title = "Q-Q Residuals"
+    )
+
+  # Manual Scale-Location Plot
+  line_data <- lowess(fitted, sqrt_resids) |> as.data.frame()
+  sqrt_resids_fitted_df <- data.frame(
+    fitted = fitted, residuals = sqrt_resids,
+    index = 1:n
+  )
+  sqrt_resids_vs_fitted <- ggplot(
+    data = sqrt_resids_fitted_df,
+    aes(x = fitted, y = residuals)
+  ) +
+    geom_point() +
+    geom_line(
+      data = line_data,
+      aes(x = x, y = y),
+      colour = "black"
+    ) +
+    geom_text(data = sqrt_resids_fitted_df[influential_points, ],
+      aes(label = index),
+      vjust = -1,
+      color = "black",
+      size = 3) +
+    labs(
+      y = expression(sqrt("Standardized residuals")),
+      x = "Fitted values",
+      title = "Scale-Location"
+    )
+
+  # Residuals vs Leverage
+  line_data <- lowess(leverage, standardized_resids) |> as.data.frame()
+  residuals_leverage_df <- data.frame(
+    residuals = standardized_resids, leverage = leverage,
+    index = 1:n
+  )
+  residuals_vs_leverage <- ggplot(
+    data = residuals_leverage_df,
+    aes(x = leverage, y = residuals)
+  ) +
+    geom_point() +
+    geom_line(
+      data = line_data,
+      aes(x = x, y = y)
+    ) +
+    geom_hline(yintercept = 0,
+      linetype = "dashed",
+      color = "black",
+      size = 0.25
+    ) +
+    geom_text(data = residuals_leverage_df[influential_points, ],
+      aes(label = index),
+      vjust = -1,
+      color = "black",
+      size = 3) +
+    labs(
+      y = "Standardized residuals", x = "Leverage",
+      title = "Residuals vs Leverage"
+    )
+
+  plot_grid(
+    resids_vs_fitted,
+    resids_vs_quantiles,
+    sqrt_resids_vs_fitted,
+    residuals_vs_leverage
+  )
+}
+
+df <- CO2
+f <- formula(uptake ~ conc)
+p <- diagnosticPlots(df, f)
+print(p)
+
+model <- lm(f, data = df)
+par(mfrow = c(3, 2))
+plot(model)
+plot(model, 4)
+
+CooksDistance <- function(df, formula) {
+  # https://rpubs.com/DragonflyStats/Cooks-Distance
+  model <- lm(formula, data = df)
+  cd <- cooks.distance(model)
+  cd <- data.frame(CooksDistance = cd,
+    Index = 1:length(cd))
+  n <- nrow(df)
+  # NOTE: number of predictors -1 (remove intercept via -1)
+  k <- length(coef(model)) - 1 
+  cutoff <- 4 / (n - k - 1)
+  ggplot(data = cd, aes(Index, CooksDistance)) +
+    geom_point() +
+    geom_line() +
+    geom_hline(yintercept = cutoff,
+      linetype = "dashed",
+      color = "black",
+      size = 0.25
+    ) +
+    geom_text(data = cd[cd$CooksDistance >= cutoff, ],
+      aes(label = Index),
+      vjust = -1,
+      color = "black",
+      size = 3)
+}
+
+CooksDistance(df, f)
+

bs/R/DoseResponse.R

@@ -245,7 +245,7 @@ DoseResponseServer <- function(id, data, listResults) {
         resP <- resP[!is.null(resP)]
         resP <- resP[!sapply(resP, is.null)]
         r_vals$plots <- resP
-        resPlot <- plot_grid(plotlist = resP, ncol = 3)
+        resPlot <- resP
       })
       if (inherits(e, "try-error")) {
         err <- conditionMessage(attr(e, "condition"))

bs/R/MainApp.R

@@ -284,9 +284,7 @@ server <- function(input, output, session) {
     }
     df <- NULL
     df <- upload(file)
-    if (is.data.frame(df)) {
-      var$df <- df
-    } else {
+    if (!is.data.frame(df)) {
       showNotification("File can not be used. Upload into R failed!", duration = 0)
     }
     tryCatch(
@@ -306,9 +304,12 @@ server <- function(input, output, session) {
 
   output$df <- renderDT({
     if (Sys.getenv("RUN_MODE") == "SERVER") {
-      isolate({
-        dataSet$df <- download_file()
-      })
+      res <- try({download_file()})
+      if (inherits(res, "try-error")) {
+        stop(attributes(res)$condition)
+      } else {
+        dataSet$df <- res
+      }
       datatable(dataSet$df, options = list(pageLength = 10))
     } else {
       req(input$file)

bs/R/OperationsModule.R

@@ -422,6 +422,9 @@ OperationEditorServer <- function(id, data) {
         showNotification(err, type = "error")
       } else {
         r_vals$intermediate_vars[[var_name]] <- new
+        exportTestValues(
+          iv_list = r_vals$intermediate_vars
+        )
       }
     })
 

bs/R/app.R

@@ -1,7 +1,6 @@
 source("MainApp.R")
 
 # TODO: define getenv as command line argument
-Sys.setenv(RUN_MODE = "BROWSER") # SERVER
-# Sys.setenv(RUN_MODE = "SERVER")
-options(shiny.autoreload = TRUE)
+# Sys.setenv(RUN_MODE = "BROWSER") # SERVER
+Sys.setenv(RUN_MODE = "SERVER")
 shinyApp(ui, server)

bs/R/check_ast.R

@@ -1,14 +1,12 @@
 allowed_fcts <- function() {
   c(
-    "-", "+", "*", "/",
+    "-", "+", "*", "/", "(",
     "log", "log10", "sqrt", "exp", "^",
     "sin", "cos", "tan", "tanh", "sinh", "cosh", "acos", "asin", "atan",
-    "is.numeric", "is.character", "is.logical", "is.factor", "is.integer",
     "as.numeric", "as.character", "as.logical", "as.factor", "as.integer",
     ">", "<", "<=", ">=", "==", "!=",
     "abs", "ceiling", "floor", "trunc", "round",
-    "grep", "substr", "sub", "paste", "paste0",
-    "strsplit", "tolower", "toupper",
+    "paste", "paste0", "tolower", "toupper",
     "dnorm", "pnorm", "qnorm", "rnorm", "dbinom",
     "pbinom", "qbinom", "rbinom", "dpois",
     "ppois", "rpois", "dunif", "punif", "qunif", "runif",

bs/R/loadLibraries.R

@@ -16,6 +16,7 @@ library(MASS)
 library(Matrix)
 library(shinyjs)
 library(equatiomatic)
+library(openxlsx)
 # TODO: add missing libraries to the Dockerfile
 
 library(COMELN)