feat: game initialisation from the application

With this feature, the admin can initialise (or re-initialise) the game
from the app directly.

README.md

@@ -47,20 +47,7 @@ The package can also be installed after cloning the git repository:
 git clone [email protected]:timflutre/PlantBreedGame.git
 ```
 
-2. Then, enter into the `PlantBreedGame` directory; inside, run the script `plantbreedgame_setup.Rmd` using [Rmarkdown](http://rmarkdown.rstudio.com/) to simulate the initial data set, this can be done with the command:
-
-```sh
-make data
-```
-
-> Or with R:
->  ```sh
->  R -e "rmarkdown::render('plantbreedgame_setup.Rmd')"
->  ```
-
- It also creates all the necessary files and database for the game to function, and initiate the game with two players, "test" (no password) and "admin" (password `1234`).
-
-3. Finally, open a R session, and execute the following commands:
+2. Finally, open a R session, and execute the following commands:
 
 ```
 library(shiny)
@@ -95,18 +82,12 @@ Then, create a new directory for the application (let's call it `breeding-game`
 mkdir /srv/shiny-server/breeding-game
 ```
 
-and copy inside the content of our Shiny application you just downloaded:
+and copy inside the content of the Shiny application you just downloaded:
 
 ```
 cp -r ~/PlantBreedGame-master/* /srv/shiny-server/breeding-game
 ```
 
-Generate the game data with:
-
-```sh
-R -e "rmarkdown::render('/srv/shiny-server/breeding-game/plantbreedgame_setup.Rmd')"
-```
-
 By default, the Shiny server runs as a unix user named `shiny`.
 You hence need to create a unix group, named for instance `breeding`, to which the `shiny` user can be added (the Shiny server may need to be restarted for this to be taken into account).
 
@@ -214,8 +195,7 @@ or
 git clone --depth=1 https://github.com/timflutre/PlantBreedGame.git
 ```
 
-2. modify the file `PlantBreedGame/plantbreedgame_setup.Rmd`
-3. move in the app code folder and build a new image:
+2. move in the app code folder and build a new image:
 
 ```sh
 cd PlantBreedGame
@@ -224,8 +204,23 @@ docker build -t customplantbreedgame ./
 
 You can then run this image by using the same commands as above replacing `juliendiot/plantbreedgame` by `customplantbreedgame`
 
+
 # Usage
 
+## Game Initialisation
+
+To start playing, the game need some specific data (eg. the genotypes and haplotypes of the initial population, a data-base...). This initialisation can be done through the game.
+
+The first time you run the application, most of the game menus will show a message asking you to initialise the game. To do so you need to go to the `Admin` menue, and in `Game Initialisation` tab. There you will find a button that will start the game initialisation. Once the initialisation is completed (which takes about 2 minutes), the page will automatically reload and you will be able to connect and play the game.
+
+The game initialisation will automatically create an `admin` breeder with the default password `1234`.
+
+If the game have already been initialise, it is also possible to re-initialise it to start a new "fresh game". However in such case **all the data of the game will be lost**.
+
+> NOTE: Currently the game do not let you choose the game initialisation parameters, in order to change them, you need to manually modify the file `plantbreedgame_setup.Rmd` befor proceding to the initialisation. In a near future, you will be able to set the intialisation parameters from the game.
+
+## How to play
+
 Once the application is installed and working, _please_ read the game rules (tab `How to play?`) and start by downloading the initial data set as well as example files showing how requests should be formatted (all files listed at the bottom of the tab `How to play?`).
 
 Before making any request, such as phenotyping, you need to log in (tab `Identification`).

src/fun/func_dbRequests.R

@@ -119,3 +119,148 @@ getBreedersIndividuals <- function(breeder) {
   query <- paste0("SELECT * FROM ", tbl)
   return(db_get_request(query))
 }
+
+clean_data_root <- function(data_root = DATA_ROOT) {
+  # WARN / TODO --- IMPORTANT ! ---
+  # the initialisation script do not allow its execution if "the data" folder
+  # already exists.
+  # Therefore here we will delete this folder, however, in general,
+  # IT IS QUITE RISKY to delete folder with code. For example:
+  # - if `DATA_ROOT` have been wrongly defined
+  # - if a malicious agent placed files/folder inside DATA_ROOT
+  # - if files are currently beeing created
+  #
+  # A better approach could be instead to only create a new `DATA_ROOT` folder
+  # and save in the data-base (that should only be erase, not deleted) the current
+  # `DATA_ROOT` to use.
+  # The server administrator would then responsible to safely remove the unecessary data.
+  #
+  # Here, to mitigate the risks the application will remove the files it
+  # has created (based on their names) and the folders if they are empty.
+  #
+  # WARN / TODO --- IMPORTANT ! ---
+
+  data_truth <- file.path(data_root, "truth")
+  data_shared <- file.path(data_root, "shared")
+  data_initial_data <- file.path(data_shared, "initial_data")
+  data_db <- file.path(data_root, "breeding-game.sqlite")
+
+
+  # initial files.
+  initial_haplo_files <- sprintf( # `Coll0001_haplos.RData` to `Coll1000_haplos.RData`
+    paste0(
+      "Coll",
+      "%0", floor(log10(1000)) + 1, "i",
+      "_haplos.RData"
+    ),
+    seq(1000)
+  )
+
+  initial_files_truth <- file.path(data_truth, c(
+    "afs0.RData",
+    "allBV.RData",
+    "coll.RData",
+    "g0.RData",
+    "p0.RData",
+    initial_haplo_files
+  ))
+  initial_files_shared <- file.path(data_shared, c(
+    file.path("initial_data", c(
+      "controls.txt",
+      "example_request_plant_material.txt",
+      "Result_phenos_controls.txt.gz",
+      "snp_coords_hd.txt.gz",
+      "example_request_data.txt",
+      "Result_genos_subset-initialColl-hd.txt.gz",
+      "Result_phenos_initialColl.txt.gz",
+      "snp_coords_ld.txt.gz"
+    )),
+    "Evaluation.txt"
+  ))
+
+  # breeder related files
+  breeders_files <- unlist(lapply(getBreederList(data_db), function(breeder) {
+    # truth
+    all_breeder_inds <- getBreedersIndividuals(breeder)$child
+    haplo_files <- c(
+      initial_haplo_files,
+      paste0(all_breeder_inds, "_haplos.RData")
+    )
+    truth_files <- file.path(data_truth, breeder, haplo_files)
+
+    # shared
+    shared_files <- file.path(data_shared, breeder, c(
+      list.files(
+        file.path(data_shared, breeder),
+        pattern = "^IndList_\\d{4}-\\d{2}-\\d{2}(_\\d+)*\\.txt$"
+      ),
+      list.files(
+        file.path(data_shared, breeder),
+        pattern = "^Request-geno_(.*)\\.txt$"
+      ),
+      list.files(
+        file.path(data_shared, breeder),
+        pattern = "^Request-pheno_(.*)\\.txt$"
+      ),
+      list.files(
+        file.path(data_shared, breeder),
+        pattern = "^Request-pltMat_(.*)\\.txt$"
+      ),
+      list.files(
+        file.path(data_shared, breeder),
+        pattern = "^Result_genos-((hd)|(ld)|(single-snps))_(.*)_\\d{4}-\\d{2}-\\d{2}(_\\d)*\\.txt\\.gz$"
+      ),
+      list.files(
+        file.path(data_shared, breeder),
+        pattern = "^Result_pheno-((field)|(patho))_(.*)_\\d{4}-\\d{2}-\\d{2}(_\\d)*\\.txt\\.gz$"
+      )
+    ))
+    return(c(truth_files, shared_files))
+  }))
+
+  # delete files
+  all_files <- c(
+    initial_files_truth,
+    initial_files_shared,
+    breeders_files
+  )
+  browser()
+  file.remove(all_files[file.exists(all_files)])
+
+  lapply(getBreederList(data_db), function(breeder) {
+    if (length(list.files(file.path(data_shared, breeder))) == 0) {
+      file.remove(file.path(data_shared, breeder))
+    } else {
+      stop(paste("can't remove", file.path(data_shared, breeder), "folder not empty."))
+    }
+    if (length(list.files(file.path(data_truth, breeder))) == 0) {
+      file.remove(file.path(data_truth, breeder))
+    } else {
+      stop(paste("can't remove", file.path(data_truth, breeder), "folder not empty."))
+    }
+  })
+
+  if (length(list.files(data_truth)) == 0) {
+    file.remove(data_truth)
+  } else {
+    stop(paste("can't remove", data_truth, "folder not empty."))
+  }
+  if (length(list.files(file.path(data_shared, "initial_data"))) == 0) {
+    file.remove(file.path(data_shared, "initial_data"))
+  } else {
+    stop(paste("can't remove", file.path(data_shared, "initial_data"), "folder not empty."))
+  }
+  if (length(list.files(data_shared)) == 0) {
+    file.remove(data_shared)
+  } else {
+    stop(paste("can't remove", data_shared, "folder not empty."))
+  }
+
+  file.remove(data_db)
+
+  if (length(list.files(data_root)) == 0) {
+    file.remove(data_root)
+  } else {
+    stop(paste("can't remove", data_root, "folder not empty."))
+  }
+}

src/server/server_admin.R

@@ -365,8 +365,8 @@ output$InfoCurrentMaxDiskUsage <- renderText({
 ## Game progress ----
 
 admin_gameProgressDta <- eventReactive(input$admin_progressButton, {
-  progressPheno <- shiny::Progress$new(session, min = 0, max = 4)
-  calcGameProgress(progressPheno)
+  progress_bar <- shiny::Progress$new(session, min = 0, max = 4)
+  calcGameProgress(progress_bar)
 })
 
 
@@ -546,3 +546,101 @@ output$admin_T1T2GameProgress <- renderPlotly({
       )
     )
 })
+
+
+
+output$initialisation_button <- renderUI({
+  if (!gameInitialised()) {
+    return(
+      actionButton("initialiseGame", "Initialise Game")
+    )
+  }
+
+  return(
+    div(
+      div(
+        h3("Important!"),
+        p(
+          "The game is already initialised. Reinitialising the game",
+          strong("will erase all the current game data"),
+          ". (All the breeders will be deleted along wiht their data.)"
+        ),
+        p("To reinitialise the game, write", code("plantbreedgame"), "in the", code("Confirmation"), "field below", "and click on the", code("Re-Initialise Game"), "button below.")
+      ),
+      div(
+        style = "display: table-row",
+        div(
+          style = "display: table-cell; padding-right: 5px;",
+          textInput("initialisation_security_text", label = "Confirmation:", value = "This action will erase all the data.")
+        ),
+        div(
+          style = "display: table-cell; padding-left: 5px; vertical-align: bottom",
+          actionButton("initialiseGame", "Re-Initialise Game")
+        )
+      )
+    )
+  )
+})
+
+observe({
+  if (identical(input$initialisation_security_text, "plantbreedgame")) {
+    shinyjs::enable("initialiseGame")
+    return(TRUE)
+  }
+  shinyjs::disable("initialiseGame")
+})
+
+
+observeEvent(input$initialiseGame, {
+  progress_bar <- shiny::Progress$new(session, min = 0, max = 1)
+
+  progress_bar$set(
+    value = 1 / 4,
+    message = "Game Initialisation:",
+    detail = "Initialisation..."
+  )
+  if (dir.exists(DATA_ROOT)) {
+    # WARN / TODO --- IMPORTANT ! ---
+    # the initialisation script do not allow its execution if "the data" folder
+    # already exists.
+    # Therefore here we will delete this folder, however, in general,
+    # IT IS QUITE RISKY to delete folder with code. For example:
+    # - if `DATA_ROOT` have been wrongly defined
+    # - if a malicious agent placed files/folder inside DATA_ROOT
+    # - if files are currently beeing created
+    #
+    # A better approach could be instead to only create a new `DATA_ROOT` folder
+    # and save in the data-base (that should only be erase, not deleted) the current
+    # `DATA_ROOT` to use.
+    # The server administrator would then responsible to safely remove the unecessary data.
+    #
+    # Here, to mitigate the risks the application will remove the files it
+    # has created (based on their names). This is not perfect as if one of this
+    # file have been is symlinked to another, the unintended file could be deleted.
+    #
+    # WARN / TODO --- IMPORTANT ! ---
+    progress_bar$set(
+      value = 1 / 4,
+      message = "Game Initialisation:",
+      detail = "Delete existing data..."
+    )
+    clean_data_root()
+  }
+  progress_bar$set(
+    value = 2 / 4,
+    message = "Game Initialisation:",
+    detail = "game setup..."
+  )
+  rmarkdown::render("./plantbreedgame_setup.Rmd",
+    output_file = "./plantbreedgame_setup.html",
+    encoding = "UTF-8"
+  )
+  progress_bar$set(
+    value = 1,
+    message = "Game Initialisation:",
+    detail = "Done"
+  )
+  alert("Game initialisation finished. This page will automatically refresh.")
+  gameInitialised()
+  shinyjs::refresh()
+})