the visualisation, model visualisation, diagnostic plots are now running in the main R process. Previously they are run in a background R process. But the overhead of creating a new process and sending the data is too large

Author: Konrad1991

OpenStats/R/Backend_History.R

@@ -40,16 +40,14 @@ eval_entry_V1_2 <- function(entry, DataModelState,
         com = backend_communicator_V1_2
       )
       res$validate()
-      res <- res$eval(ResultsState)
-      get_result(ResultsState)
+      res$eval(ResultsState)
     },
     VisualizationModel = {
       res <- visualisation_model_V1_2$new(
         df = DataModelState$df, DataModelState$formula, entry[["Layer"]]
       )
       res$validate()
       res$eval(ResultsState)
-      get_result(ResultsState)
     },
     ApplyFilter = {
       res <- apply_filter_V1_2$new(
@@ -147,7 +145,6 @@ eval_entry_V1_2 <- function(entry, DataModelState,
       )
       res$validate()
       res$eval(ResultsState)
-      get_result(ResultsState)
     },
     DoseResponse = {
       response_type <- entry[["Response type"]]

OpenStats/R/Backend_V1_2_Engine.R

@@ -521,7 +521,7 @@ visualisation_V1_2 <- R6::R6Class(
         ),
         promise_result_name = new_result_name,
         promise_history_entry = promise_history_entry,
-        in_background = TRUE, ResultsState
+        in_background = FALSE, ResultsState
       )
     },
     create_history = function(new_result_name) {
@@ -588,7 +588,7 @@ visualisation_model_V1_2 <- R6::R6Class(
             ),
             promise_result_name = new_name,
             promise_history_entry = promise_history_entry,
-            in_background = TRUE, ResultsState
+            in_background = FALSE, ResultsState
           )
         },
         warning = function(warn) {
@@ -1320,7 +1320,7 @@ diagnostic_plots_V1_2 <- R6::R6Class(
             args = list(df = self$df, formula = self$formula),
             promise_result_name = new_name,
             promise_history_entry = promise_history_entry,
-            in_background = TRUE, ResultsState
+            in_background = FALSE, ResultsState
           )
         },
         warning = function(warn) {

OpenStats/R/Server_Visualization.R

@@ -276,7 +276,6 @@ visServer <- function(id, DataModelState, ResultsState) {
     })
 
     # Plot model
-    # TODO: add tests for history and backend
     plot_model_fct <- function(method) {
       print_req(is.data.frame(DataModelState$df), "The dataset is missing")
       print_form(DataModelState$formula)

Randomization/development/example_SaAh.R

@@ -1,3 +1,5 @@
+library(ggplot2)
+library(Randomization)
 groups <- read.csv("./Randomization/development/tesstSaAH.csv", sep = ";", header = TRUE)
 names(groups)[[1L]] <- "ids"
 groups[, 2:6] <- apply(groups[, 2:6], 2, as.numeric)
@@ -11,28 +13,78 @@ n_blocks <- data.frame(
     rep("Gi", 10L)
   )
 )
-n_blocks
 
-result <- Randomization::random_finite_assign(
-  seed = 1234,
+result_mahalanobis <- random_finite_assign(
+  seed = 42L,
   groups = groups[, 2:6],
   design = n_blocks,
   max_iter = 1000L,
-  ids = groups$ids,
+  loss_function = "Mahalanobis",
+  ids = groups$ids
+)
+groups_optim_mahalanobis <- groups[result_mahalanobis$unit_id, 2L:6L]
+df_optim_mahalanobis <- data.frame(
+  stack(groups_optim_mahalanobis),
+  treatment = rep(n_blocks$treatment, 5L),
+  group = "Mahalanobis"
 )
-result
 
-df <- data.frame(
-  treatment = n_blocks$treatment,
-  groups[result$unit_id, 2:6]
+result_default <- random_finite_assign(
+  seed = 42L,
+  groups = groups[, 2:6],
+  design = n_blocks,
+  max_iter = 1000L,
+  ids = groups$ids
+)
+groups_optim_default <- groups[result_default$unit_id, 2L:6L]
+df_optim_default <- data.frame(
+  stack(groups_optim_default),
+  treatment = rep(n_blocks$treatment, 5L),
+  group = "Default"
 )
-means <- tapply(df, df$treatment, function(b) {
-  b <- c(b[, 2:6]) |> unlist()
-  mean(b)
-})
-sds <- tapply(df, df$treatment, function(b) {
-  b <- c(b[, 2:6]) |> unlist()
-  sd(b)
-})
-means
-sds
+
+df_orig <- data.frame(
+  stack(groups[, 2L:6L]),
+  treatment = rep(n_blocks$treatment, 5L),
+  group = "origin"
+)
+
+df <- Reduce(rbind, list(df_optim_mahalanobis, df_optim_default))
+
+ggplot(data = df, aes(x = treatment, y = values)) +
+  stat_summary(
+    data = df, aes(group = group, linetype = group, colour = group),
+    fun = mean, geom = "line",
+    position = position_dodge(width = 0.8), color = "black"
+  ) +
+  stat_summary(
+    aes(group = group, colour = group),
+    fun.data = mean_sdl,
+    fun.args = list(mult = 1), # 1 SD
+    geom = "errorbar",
+    width = 0.2,
+    position = position_dodge(width = 0.8)
+  ) +
+  facet_wrap(~ ind, scales = "free")
+
+
+summary <- function(df, fct) {
+  res <- list()
+  for (g in unique(df$group)) {
+    sub1 <- df[df$group == g, ]
+    temp1 <- c()
+    for (i in unique(sub1$ind)) {
+      sub2 <- sub1[sub1$ind == i, ]
+      temp2 <- c()
+      for (t in unique(sub2$treatment)) {
+        sub3 <- sub2[sub2$treatment == t, ]
+        temp2[[t]] <- fct(sub3$values)
+      }
+      temp1[[i]] <- temp2 |> unlist()
+    }
+    res[[g]] <- Reduce(rbind, temp1)
+  }
+  res
+}
+summary(df, mean)
+summary(df, sd)

development/testing.R

@@ -0,0 +1,2 @@
+install.packages("OpenStats", type = "source", repos = NULL)
+tinytest::test_package("OpenStats")