-- WIP -- feat: game initialisation from the application

TODO: documentation !!!!

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

README.md

@@ -47,6 +47,9 @@ The package can also be installed after cloning the git repository:
 git clone [email protected]:timflutre/PlantBreedGame.git
 ```
 
+TODO: The game can now be initialised within the application
+
+
 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
@@ -101,8 +104,11 @@ and copy inside the content of our Shiny application you just downloaded:
 cp -r ~/PlantBreedGame-master/* /srv/shiny-server/breeding-game
 ```
 
+**TODO**: The game can now be initialised within the application
+
 Generate the game data with:
 
+
 ```sh
 R -e "rmarkdown::render('/srv/shiny-server/breeding-game/plantbreedgame_setup.Rmd')"
 ```

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,88 @@ output$admin_T1T2GameProgress <- renderPlotly({
       )
     )
 })
+
+
+
+output$initialisation_button <- renderUI({
+  if (!gameInitialised()) {
+    return(actionButton("initialiseGame", "Initialise Game"))
+  }
+
+  return(
+    div(
+      h3("Important!"),
+      p(
+        "The game is already initialised. Reinitialising the game will",
+        strong("erase all the current game data"),
+        ". (All the breeders will be deleted along wiht their data.)"
+      ),
+      p("To reinitialise the game, write in the field below", code("plantbreedgame"), "and click on the", code("Re-Initialise Game"), "button below."),
+      textInput("initialisation_security_text", label = h3(""), value = "This action will erase all the data."),
+      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()
+})