feat(game initialisation): add rng_seed parameter

This is a first step to let user initialise the game with different
parameters from the app directly.
Here only for one parameter, the `rng_seed`.

.github/workflows/tests.yml

@@ -29,3 +29,13 @@ jobs:
         path: playwright-report/
         retention-days: 30
 
+
+  initialise_data_from_script:
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v4
+    - uses: cachix/install-nix-action@v25
+      with:
+        github_access_token: ${{ secrets.GITHUB_TOKEN }}
+    - uses: DeterminateSystems/magic-nix-cache-action@v2
+    - run: nix develop -c -- nix run .\#initialise-data

flake.nix

@@ -19,6 +19,7 @@
           shinydashboard
           shinycssloaders
           shinyjs
+          shinyvalidate
           RSQLite
           MASS
           digest

global.R

@@ -27,6 +27,8 @@ source("src/fun/func_id.R", local = TRUE, encoding = "UTF-8")
 source("./src/fun/module_constants.R", local = TRUE, encoding = "UTF-8")
 source("./src/fun/module_breederList.R", local = TRUE, encoding = "UTF-8")
 source("./src/fun/func_dbRequests.R", local = TRUE, encoding = "UTF-8")
+source("./src/fun/module_gameInit_params.R", local = TRUE, encoding = "UTF-8")
+source("./src/fun/func_gameInit_validation.R", local = TRUE, encoding = "UTF-8")
 
 ## -------------------------------------------------------------------
 ## parameters

src/dependencies.R

@@ -27,6 +27,7 @@ suppressPackageStartupMessages({
   library(shinydashboard)
   library(shinycssloaders)
   library(shinyjs)
+  library(shinyvalidate)
   library(RSQLite)
   library(MASS)
   library(digest)

src/fun/func_gameInit_validation.R

@@ -0,0 +1,48 @@
+# functions used to validate game initialisation parameters
+# these functions are defined here because they are used at 2 different
+# places:
+#  - The application, trhough the modules of each parameters
+#    with an `InputValidator` object (to highlight wrong inputs in the UI)
+#  - The Game Initialisation script (to stop it in case the inputs are wrong)
+#
+# Technically, the error messages should be slightly different if we raise an
+# error from the initialisation script or in the application. But since it
+# would complexify the code for few benefit the error messages to show on the
+# UI are implemented here (as it is the intended way to setup the game).
+#
+# These functions can either `stop` or `return` an error message.
+# The stop behaviour is intended to be used in the initialisation script
+# and the return behaviour is intended to be used with `InputValidator$add_rule`
+
+
+valid_rng_seed <- function(seed, accept_null = TRUE, raise_error = FALSE) {
+
+  error <- return
+  if (raise_error) {
+    error <- stop
+  }
+
+  if (is.null(seed)) {
+    if (accept_null) {
+      return(NULL)
+    }
+    error("Must not be NULL")
+  }
+
+  if (is.na(seed)) {
+    error("Mandatory and should be a positive integer")
+  }
+
+  if (!is.numeric(seed)) {
+    error("Should be a positive integer")
+  }
+
+  if (seed %% 1 != 0 || seed < 0) {
+    error("Should be a positive integer")
+  }
+
+  return(NULL)
+}
+
+
+

src/fun/module_gameInit_params.R

@@ -0,0 +1,38 @@
+
+# this file list all the game initialisation parameters (implemented in the
+# application)
+# It takes the forms of "shiny modules" to:
+#   - include the "input validation" in the module
+#   - have more complex UI that provides informations to users based on several
+#     "groups of inputs" (eg. all inputs related to budgets)
+#   - lighten the code related to "Admin server".
+
+# in the "server" parts of these modules, the `iv` argument is an
+# `InputValidator` object
+
+library(shinyvalidate)
+
+
+gameInit_seed_ui <- function(id) {
+  ns <- NS(id)
+  numericInput(ns("seed"), "RNG seed", value = 1993, step = 1)
+}
+
+gameInit_seed_server <- function(id, iv) {
+  moduleServer(id, function(input, output, session) {
+
+    iv$add_rule("seed", valid_rng_seed)
+    return(
+      list(
+        value = reactive({
+          if (is.null(iv$validate()[[session$ns('seed')]])) {
+            return(input$seed)
+          }
+          return(NA)
+        }),
+        iv = iv
+      )
+    )
+
+  })
+}

src/plantbreedgame_setup.Rmd

@@ -4,13 +4,15 @@ author: "Timothée Flutre (INRA)"
 date: "`r format(Sys.time(), '%d/%m/%Y %H:%M:%S')`"
 params:
   progressBar: NULL
+  rng_seed: 1993
 colorlinks: true
 output:
   html_document:
     toc: true
     toc_depth: 4
     toc_float: true
     number_sections: TRUE
+    code_folding: hide
   pdf_document:
     toc: true
     toc_depth: 4
@@ -99,15 +101,28 @@ suppressPackageStartupMessages(library(scrm)) # from CRAN
 suppressPackageStartupMessages(library(GenomicRanges)) # from bioconductor
 
 source("fun/functions.R")
+source("fun/module_gameInit_params.R")
+source("fun/func_gameInit_validation.R")
+
 ```
 
-Set the seed:
+# Parameters
+
+Validation and overview of the parameters used to initialised this game session.
+
 ```{r}
-RNGkind("L'Ecuyer-CMRG") # to make mclapply reproducible
-set.seed(1993) # better to change it from one game session to the next
+progressBar$set(
+  value = progressBar$getValue() + 1,
+  detail = "Parameter validation..."
+)
+
+valid_rng_seed(params$rng_seed, accept_null = FALSE, raise_error = TRUE)
+
+print(params[names(params) != "progressBar"])
 ```
 
-Set up directories:
+# Set up data directories and RNG seed
+
 ```{r setup_dir}
 progressBar$set(
   value = progressBar$getValue() + 1,
@@ -133,7 +148,12 @@ dir.create(truth.dir)
 dir.create(shared.dir)
 dir.create(init.dir)
 dir.create(reports.dir)
+```
 
+
+```{r}
+RNGkind("L'Ecuyer-CMRG") # to make mclapply reproducible
+set.seed(params$rng_seed)
 ```
 
 # Create initial breeders

src/server/server_admin.R

@@ -666,8 +666,25 @@ output$initialisation_button <- renderUI({
   )
 })
 
+
+
+
+gameInit_input_validator <- InputValidator$new()
+
+gameInit_seed <- gameInit_seed_server("gameInit_seed", gameInit_input_validator)
+
+
+gameInit_input_validator$add_rule("initialisation_security_text", function(x) {
+  if (is.null(x)) return(NULL)
+  if (x != "plantbreedgame") return("")
+  }
+)
+
+gameInit_input_validator$enable()
+
+
 observe({
-  if (identical(input$initialisation_security_text, "plantbreedgame")) {
+  if (gameInit_input_validator$is_valid()) {
     shinyjs::enable("initialiseGame")
     return(TRUE)
   }
@@ -676,13 +693,23 @@ observe({
 
 
 observeEvent(input$initialiseGame, {
-  progress_bar <- shiny::Progress$new(session, min = 0, max = 15)
+  progress_bar <- shiny::Progress$new(session, min = 0, max = 16)
 
   progress_bar$set(
     value = 1,
     message = "Game Initialisation:",
     detail = "Initialisation..."
   )
+
+  if (!gameInit_input_validator$is_valid()) {
+    progress_bar$set(
+      value = 1,
+      message = "Game Initialisation:",
+      detail = "ERROR, invalid parameters"
+    )
+    return(NULL)
+  }
+
   if (gameInitialised()) {
     # WARN / TODO --- IMPORTANT ! ---
     # the initialisation script do not allow its execution if "the data" folder
@@ -723,8 +750,10 @@ observeEvent(input$initialiseGame, {
   )
 
   params <- list(
-      progressBar = progress_bar
+    progressBar = progress_bar,
+    rng_seed = gameInit_seed$value()
   )
+
   out_report <- rmarkdown::render("./src/plantbreedgame_setup.Rmd",
     output_file = tempfile(),
     encoding = "UTF-8",
@@ -735,12 +764,12 @@ observeEvent(input$initialiseGame, {
 
   addResourcePath("reports", DATA_REPORTS)
 
-  print(progress_bar$getValue())
   progress_bar$set(
     value = progress_bar$max,
     message = "Game Initialisation:",
     detail = "Done"
   )
+
   alert("Game initialisation finished. This page will automatically refresh.")
   gameInitialised()
   shinyjs::refresh()

src/ui/ui_admin_loggedIn.R

@@ -360,6 +360,10 @@ game_initialisation_tab_content <- div(
         tags$li(code("Tester"), "(this breeder do not have a password, you can leave the password field empty to connect)")
       )
     ),
+    div(
+      h3("Game Initialisation Parameters:"),
+      gameInit_seed_ui("gameInit_seed")
+    ),
     uiOutput("initialisation_button")
   )
 )

tests/testthat.R

@@ -1,19 +1,6 @@
 library(testthat)
 
 # load functions
-invisible(
-  sapply(FUN = source,
-         X = list.files("src/fun", pattern = ".R$", full.names = T))
-)
-
-# run tests
-# test_file("tests/testthat/test_0_dependencies.R",
-#           stop_on_failure = TRUE,
-#           stop_on_warning = FALSE)
-# test_file("tests/testthat/test_game_time.R",
-#           stop_on_failure = TRUE,
-#           stop_on_warning = FALSE)
-
 test_dir("tests/testthat",
          stop_on_failure = TRUE,
          stop_on_warning = FALSE)

tests/testthat/test_0_dependencies.R

@@ -14,5 +14,6 @@ test_that("dependencies", {
   expect_no_error({library(shinycssloaders)})
   expect_no_error({library(shinydashboard)})
   expect_no_error({library(shinyjs)})
+  expect_no_error({library(shinyvalidate)})
   expect_no_error({library(vistime)})
 })

tests/testthat/test_gameInit_validation.R

@@ -0,0 +1,22 @@
+
+library(testthat)
+source("../../src/fun/func_gameInit_validation.R", local = TRUE, encoding = "UTF-8")
+
+
+test_that("valid_rng_seed", {
+
+  # OK cases
+  expect_null(valid_rng_seed(42))
+  expect_null(valid_rng_seed(NULL))
+
+  # invalid cases (no error)
+  expect_type(valid_rng_seed(NA), "character")
+  expect_type(valid_rng_seed(24.234), "character")
+  expect_type(valid_rng_seed(-42), "character")
+  expect_type(valid_rng_seed("abc"), "character")
+  expect_type(valid_rng_seed(NULL, FALSE), "character")
+
+  # invalid cases (error)
+  expect_error(valid_rng_seed(24.234, FALSE, TRUE))
+
+})

tests/testthat/test_game_time.R

@@ -1,4 +1,8 @@
 
+library(testthat)
+source("../../src/fun/func_time.R", local = TRUE, encoding = "UTF-8")
+
+
 firstYear = 2000
 game_first_day = strptime(paste0(firstYear, "-01-01 00:00"), format = "%Y-%m-%d %H:%M")