ui(game init): add costs/budget parameters

initialise_data.R

@@ -1,8 +1,25 @@
 #! /usr/bin/env Rscript
 
+params = list(
+  rng_seed = 1993,
+  cost.pheno.field = 50,
+  cost.pheno.patho = 0.1,
+  cost.allof = 0.1,
+  cost.autof = 0.25,
+  cost.haplodiplo = 1,
+  cost.geno.hd = 1,
+  cost.geno.ld = 0.5,
+  cost.geno.single = 0.02,
+  cost.register = 4,
+  initialBudget = 3900
+)
+
+
 out_report <- rmarkdown::render("./src/plantbreedgame_setup.Rmd",
   output_file = tempfile(),
-  encoding = "UTF-8"
+  encoding = "UTF-8",
+  params = params,
+  envir = new.env(parent = globalenv()),
 )
 file.copy(
   from = out_report,

playwright.config.js

@@ -73,8 +73,7 @@ module.exports = defineConfig({
 
   /* Run your local dev server before starting the tests */
   webServer: {
-    // command: "rm -r data; unzip data.zip -d .; nix run",
-    command: "nix run",
+    command: "rm -rf data/*; rm  data.zip; nix run",
     url: "http://127.0.0.1:3000",
     reuseExistingServer: true,
   },

src/fun/func_gameInit_validation.R

@@ -44,5 +44,33 @@ valid_rng_seed <- function(seed, accept_null = TRUE, raise_error = FALSE) {
   return(NULL)
 }
 
+valid_positive_number <- function(x, accept_null = TRUE, raise_error = FALSE) {
+
+  error <- return
+  if (raise_error) {
+    error <- stop
+  }
+
+  if (is.null(x)) {
+    if (accept_null) {
+      return(NULL)
+    }
+    error("Must not be NULL")
+  }
+
+  if (is.na(x)) {
+    error("Mandatory and should be a positive number")
+  }
+
+  if (!is.numeric(x)) {
+    error("Should be a positive number")
+  }
+
+  if (x < 0) {
+    error("Should be a positive number")
+  }
+
+  return(NULL)
+}
 
 

src/fun/module_constants.R

@@ -26,8 +26,7 @@ constants_server <- function(const, constantsReactive) {
               return(format(constants$cost.register * constants$cost.pheno.field, digits = 2))
             }
             if (const == "initial.budget") {
-              # TODO, better to calculate this initial budget at game setup and save it in the db
-              return(format(constants$cost.pheno.field * constants$nb.plots * 10 * 1.3, digits = 2, scientific = F))
+              return(format(constants$initialBudget, digits = 2, scientific = F))
             }
             if (const == "cost.geno.single.mendels") {
               return(format(constants$cost.geno.single * constants$cost.pheno.field, digits = 2))

src/fun/module_gameInit_params.R

@@ -24,6 +24,20 @@ tooltip_label <- function(label, description){
   )
 }
 
+collapible_section <- function(title, title_id, content) {
+
+  tags$details(style = "margin-top: 30px;",
+    tags$summary(
+      h3(title, "(click to expand)",
+         style = "margin-top: 0px; display: inline-block;",
+         id = title_id
+      )
+    ),
+    content
+  )
+
+}
+
 gameInit_seed_ui <- function(id) {
   ns <- NS(id)
 
@@ -36,7 +50,7 @@ gameInit_seed_ui <- function(id) {
     )
   )
   div(
-    # shiny::numericInput(ns("seed"), span("RNG seed", tooltip), value = 1993, step = 1)
+    h3("", style = "margin-top: 30px;"),
     shiny::numericInput(ns("seed"), label = label, value = 1993, step = 1)
   )
 }
@@ -59,3 +73,160 @@ gameInit_seed_server <- function(id, iv) {
 
   })
 }
+
+
+
+gameInit_costs_ui <- function(id) {
+  ns <- NS(id)
+
+
+  width_numInput <- "90%"
+
+  div(
+
+    collapible_section(
+      title = "Costs and budget:",
+      title_id = ns("cost_budget_title"),
+      div(
+        tags$blockquote(style = "font-weight: normal; font-size: inherit; font-style: italic;",
+          p("Note: Unless explicitly mentioned, all costs are expressed",
+            strong("relative to the cost of phenotyping one plot"),
+            ".")
+        ),
+
+        div(style = "display: flex;",
+          div(style = "flex: 1;",
+            h4("Phenotyping:", style = "margin-top: 20px;"),
+            shiny::numericInput(ns("cost.pheno.field"), label = "Field phenotyping for 1 plot (in Mendels)", value = 50, step = 1, width = width_numInput),
+            shiny::numericInput(ns("cost.pheno.patho"), label = 'Pathogene phenotyping', value = 0.1, step = 0.1, width = width_numInput),
+
+            h4("Crossing:", style = "margin-top: 20px;"),
+            shiny::numericInput(ns("cost.allof"), label = 'Allo-fecundation', value = 0.1, step = 0.1, width = width_numInput),
+            shiny::numericInput(ns("cost.autof"), label = 'Auto-fecundation', value = 0.25, step = 0.1, width = width_numInput),
+            shiny::numericInput(ns("cost.haplodiplo"), label = 'Haplo-diploidisation', value = 1, step = 0.1, width = width_numInput),
+
+            h4("Genotyping:", style = "margin-top: 20px;"),
+            shiny::numericInput(ns("cost.geno.hd"), label = 'Genotyping HD', value = 1, step = 0.1, width = width_numInput),
+            shiny::numericInput(ns("cost.geno.ld"), label = 'Genotyping LD', value = 0.5, step = 0.1, width = width_numInput),
+            shiny::numericInput(ns("cost.geno.single"), label = 'Genotyping single SNP', value = 0.02, step = 0.1, width = width_numInput),
+
+            h4("Other:", style = "margin-top: 20px;"),
+            shiny::numericInput(ns("cost.register"), label = 'Final evaluation registration', value = 4, step = 0.1, width = width_numInput),
+            shiny::numericInput(ns("initialBudget"), label = "Initial budget", value = 3900, step = 100, width = width_numInput)
+            # 3900 = 300 plots * 10 years + 30%
+          ),
+
+          div(style = "flex: 1;",
+            h4("Cost and budget summary", style = "margin-top: 20px;"),
+            tableOutput(ns("costs_table")),
+            tags$blockquote(style = "font-weight: normal; font-size: inherit; font-style: italic;",
+              textOutput(ns("init_budget_summary"))
+            )
+          )
+        )
+      )
+    )
+  )
+
+
+}
+
+gameInit_costs_server <- function(id, iv) {
+  moduleServer(id, function(input, output, session) {
+
+    output$costs_table <- renderTable({
+      cost_df <- data.frame(
+        Plot = c(
+          1,
+          input$cost.pheno.patho,
+          input$cost.allof,
+          input$cost.autof,
+          input$cost.haplodiplo,
+          input$cost.geno.hd,
+          input$cost.geno.ld,
+          input$cost.geno.single,
+          input$cost.register,
+          input$initialBudget
+        ),
+        row.names = c(
+          "Phenotyping plot",
+          "Phenotyping pathogene",
+          "Allo-fecundation",
+          "Auto-fecundation",
+          "Haplo-diploidisation",
+          "Genotyping HD",
+          "Genotyping LD",
+          "Genotyping single SNP",
+          "Registration",
+          "Initial Budget"
+        )
+      )
+      cost_df$Mendels <- cost_df$Plot * input$cost.pheno.field
+      return(cost_df)
+    }, rownames = TRUE)
+
+    output$init_budget_summary <- renderText({
+      n_plot <- 300 # TODO used game init parameter instead
+      n_year <- 10
+      initB <- input$initialBudget
+
+      bonus <- ((initB / (n_plot * n_year)) - 1) * 100
+
+      paste0("Initial budget represents ",
+        n_plot, " phenotyping plots for ",
+        n_year, " years ",
+        sprintf("%+.0f%%", bonus), "."
+      )
+    })
+
+    cost_validator <- InputValidator$new()
+    cost_validator$add_rule("cost.pheno.field", valid_positive_number)
+    cost_validator$add_rule("cost.pheno.patho", valid_positive_number)
+    cost_validator$add_rule("cost.allof", valid_positive_number)
+    cost_validator$add_rule("cost.autof", valid_positive_number)
+    cost_validator$add_rule("cost.haplodiplo", valid_positive_number)
+    cost_validator$add_rule("cost.geno.hd", valid_positive_number)
+    cost_validator$add_rule("cost.geno.ld", valid_positive_number)
+    cost_validator$add_rule("cost.geno.single", valid_positive_number)
+    cost_validator$add_rule("cost.register", valid_positive_number)
+    cost_validator$add_rule("initialBudget", valid_positive_number)
+
+    iv$add_validator(cost_validator)
+
+    observe({
+      id = session$ns('cost_budget_title')
+      if (cost_validator$is_valid()) {
+        # shinyjs::removeClass(id, "has-error") # not working in modules
+        shinyjs::runjs(code = paste0('$("#', id, '").removeClass("has-error");'))
+      } else {
+        # shinyjs::addClass(id, "has-error") # not working in modules
+        shinyjs::runjs(code = paste0('$("#', id, '").addClass("has-error");'))
+      }
+    })
+
+    return(
+      list(
+        value = reactive({
+          if (cost_validator$is_valid()) {
+            return(list(
+              cost.pheno.field = input$cost.pheno.field,
+              cost.pheno.patho = input$cost.pheno.patho,
+              cost.allof = input$cost.allof,
+              cost.autof = input$cost.autof,
+              cost.haplodiplo = input$cost.haplodiplo,
+              cost.geno.hd = input$cost.geno.hd,
+              cost.geno.ld = input$cost.geno.ld,
+              cost.geno.single = input$cost.geno.single,
+              cost.register = input$cost.register,
+              initialBudget = input$initialBudget
+            ))
+          }
+          return(NA)
+        }),
+        iv = iv
+      )
+    )
+
+  })
+}
+

src/plantbreedgame_setup.Rmd

@@ -5,6 +5,16 @@ date: "`r format(Sys.time(), '%d/%m/%Y %H:%M:%S')`"
 params:
   progressBar: NULL
   rng_seed: 1993
+  cost.pheno.field: 50
+  cost.pheno.patho: 0.1
+  cost.allof: 0.1
+  cost.autof: 0.25
+  cost.haplodiplo: 1
+  cost.geno.hd: 1
+  cost.geno.ld: 0.5
+  cost.geno.single: 0.02
+  cost.register: 4
+  initialBudget: 3900
 colorlinks: true
 output:
   html_document:
@@ -116,7 +126,20 @@ progressBar$set(
   detail = "Parameter validation..."
 )
 
-valid_rng_seed(params$rng_seed, accept_null = FALSE, raise_error = TRUE)
+invisible({
+  valid_rng_seed(params$rng_seed, accept_null = FALSE, raise_error = TRUE)
+
+  valid_positive_number(params$cost.pheno.field, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$cost.pheno.patho, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$cost.allof, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$cost.autof, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$cost.haplodiplo, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$cost.geno.hd, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$cost.geno.ld, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$cost.geno.single, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$cost.register, accept_null = FALSE, raise_error = TRUE)
+  valid_positive_number(params$initialBudget, accept_null = FALSE, raise_error = TRUE)
+})
 
 print(params[names(params) != "progressBar"])
 ```
@@ -1512,45 +1535,44 @@ res <- dbExecute(conn = db, query)
 
 Fill the table with the constants specifying the costs:
 ```{r table_constants_fill_costs}
-cost.pheno.field <- 50
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('cost.pheno.field', '", cost.pheno.field, "')"
+  " ('cost.pheno.field', '", params$cost.pheno.field, "')"
 ) # in Mendels
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('cost.pheno.patho', '", 1 / 10, "')"
+  " ('cost.pheno.patho', '", params$cost.pheno.patho, "')"
 ) # compare to one plot
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('cost.allof', '", 1 / 10, "')"
+  " ('cost.allof', '", params$cost.allof, "')"
 ) # idem
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('cost.autof', '", 1 / 25, "')"
+  " ('cost.autof', '", params$cost.autof, "')"
 ) # idem
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('cost.haplodiplo', '", 1, "')"
+  " ('cost.haplodiplo', '", params$cost.haplodiplo, "')"
 ) # idem
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('cost.geno.hd', '", 1, "')"
+  " ('cost.geno.hd', '", params$cost.geno.hd, "')"
 ) # idem
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('cost.geno.ld', '", 1 / 2, "')"
+  " ('cost.geno.ld', '", params$cost.geno.ld, "')"
 ) # idem
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('cost.geno.single', '", 1 / 50, "')"
+  " ('cost.geno.single', '", params$cost.geno.single, "')"
 ) # idem
 res <- dbExecute(conn = db, query)
 query <- paste0(
@@ -1561,7 +1583,7 @@ res <- dbExecute(conn = db, query)
 
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
-  " ('initialBudget', '", cost.pheno.field * nb.plots * 10 * 1.3, "')"
+  " ('initialBudget', '", params$initialBudget, "')"
 ) # idem
 res <- dbExecute(conn = db, query)
 ```