From 8faa3eb3c3df435d942c00f3d394f3300e5d4201 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Tue, 7 May 2024 11:07:10 +0900 Subject: [PATCH 01/12] refact (function): move some rutilstimflutre function to this repo Some fuctions was previously in `rutilstimflutre` package but it would be more convinient to have there here in order to maintain them more efficiently. --- src/fun/functions.R | 71 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) diff --git a/src/fun/functions.R b/src/fun/functions.R index 6fab856..654008f 100644 --- a/src/fun/functions.R +++ b/src/fun/functions.R @@ -445,3 +445,74 @@ writeRequest <- function(df, breeder, fileName = NULL) { write.table(df, file = fout, sep = "\t", row.names = FALSE, quote = FALSE) } + + + +##' Get the breeding game setup +##' +##' Retrieve the paths to the directories used for the breeding game. +##' @param root.dir path to the root directory +##' @return list +##' @author Timothee Flutre +getBreedingGameSetup <- function(root.dir) { + stopifnot(is.character(root.dir), + length(root.dir) == 1, + dir.exists(root.dir)) + + out <- list(root.dir = root.dir) + + out$truth.dir <- paste0(root.dir, "/truth") + out$shared.dir <- paste0(root.dir, "/shared") + out$init.dir <- paste0(out$shared.dir, "/initial_data") + tmp <- basename(Sys.glob(paste0(out$shared.dir, "/*"))) + for (x in tmp) { + if (x != "initial_data") + out$breeders <- c(out$breeders, x) + } + + out$breeder.dirs <- c() + for (breeder in out$breeders) + out$breeder.dirs[[breeder]] <- + paste0(out$shared.dir, "/", breeder) + + out$dbname <- paste0(root.dir, "/breeding-game.sqlite") + + return(out) +} + + +##' Get the breeding game constants +##' +##' Retrieve the constants used to parametrized the breeding game from the SQLite database. +##' @param dbname name of the SQLite database (full path) +##' @param table name of the table +##' @return list +##' @author Timothee Flutre +getBreedingGameConstants <- function(dbname) { + requireNamespace("DBI") + requireNamespace("RSQLite") + stopifnot(file.exists(dbname)) + table = "constants" + + out.list <- list() + + ## retrieve the content of the table + db <- DBI::dbConnect(RSQLite::SQLite(), dbname = dbname) + query <- paste0("SELECT *", + " FROM ", table) + out.df <- DBI::dbGetQuery(db, query) + DBI::dbDisconnect(db) + + ## reformat + out.list <- as.list(out.df$value) + names(out.list) <- out.df$item + for (i in seq_along(out.list)) + out.list[[i]] <- tryCatch({ + as.numeric(out.list[[i]]) + }, warning = function(c) { + # ex.: case of 'max.upload.pheno.field' + out.list[[i]] + }) + + return(out.list) +} From 71e0637ca83952494b19ab61ad0fbbda79413480 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Wed, 29 May 2024 15:16:21 +0900 Subject: [PATCH 02/12] refact: remove `constants` global variable Befor this commit, the games "constants" was accessed through a global variable (and used in both UI and server parts). The problem with this design is that those values may not be updated if changed in the data-base. (this is not currently possible but it is planned to be implemented). I have refactor so that those values are always read from the DB. When those constants are used in "calculations" they are requested to the DB with `getBreedingGameConstant()` When those constants are shown in the UI, a "shiny module is used" to ease the developement (cf. `./src/fun/constants_module.R`). All the "servers outputs" for those values are defined in `src/server/server_constants.R`. --- global.R | 35 ++++------ server.R | 1 + src/fun/constants_module.R | 92 ++++++++++++++++++++++++++ src/fun/func_admin.R | 2 +- src/fun/func_eval.R | 7 +- src/fun/func_geno.R | 8 ++- src/fun/func_id.R | 1 + src/fun/func_pheno.R | 14 +++- src/fun/func_plant_material.R | 8 +++ src/fun/functions.R | 64 +++++++++--------- src/server/server_admin.R | 12 +--- src/server/server_constants.R | 102 +++++++++++++++++++++++++++++ src/server/server_eval.R | 13 ++-- src/server/server_geno.R | 4 +- src/server/server_id.R | 25 +++++-- src/server/server_pheno.R | 2 +- src/server/server_plant_material.R | 1 + src/server/server_theory.R | 11 ++-- src/ui/ui_geno.R | 6 +- src/ui/ui_id_loggedIn.R | 4 +- src/ui/ui_information.R | 50 +++++++------- src/ui/ui_pheno.R | 22 +++---- src/ui/ui_plant_material.R | 6 +- src/ui/ui_theory.R | 24 ++++--- tests_UI/test-1.spec.ts | 9 +-- 25 files changed, 363 insertions(+), 160 deletions(-) create mode 100644 src/fun/constants_module.R create mode 100644 src/server/server_constants.R diff --git a/global.R b/global.R index 183ef37..3196ae0 100644 --- a/global.R +++ b/global.R @@ -1,4 +1,5 @@ ## Copyright 2015,2016,2017,2018,2019 Institut National de la Recherche Agronomique + ## and Montpellier SupAgro. ## ## This file is part of PlantBreedGame. @@ -18,11 +19,12 @@ ## . -source("src/dependencies.R", local = TRUE, encoding = "UTF-8")$value +source("src/dependencies.R", local = TRUE, encoding = "UTF-8") -source("src/fun/functions.R", local = TRUE, encoding = "UTF-8")$value -source("src/fun/func_time.R", local = TRUE, encoding = "UTF-8")$value -source("src/fun/func_id.R", local = TRUE, encoding = "UTF-8")$value +source("src/fun/functions.R", local = TRUE, encoding = "UTF-8") +source("src/fun/func_time.R", local = TRUE, encoding = "UTF-8") +source("src/fun/func_id.R", local = TRUE, encoding = "UTF-8") +source("./src/fun/constants_module.R", local = TRUE, encoding = "UTF-8") ## ------------------------------------------------------------------- ## parameters @@ -42,26 +44,15 @@ if (Sys.info()["sysname"] == "Windows") { ## ------------------------------------------------------------------- ## variables -root.dir <- "data" -setup <- getBreedingGameSetup(root.dir) -checkDbFile(setup$dbname) -constants <- getBreedingGameConstants(setup$dbname) -if (is.null(constants$maxEvalInds)) { - constants$maxEvalInds <- 5 -} +DATA_ROOT <- "data" +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") + +setup <- getBreedingGameSetup(DATA_ROOT) -prices <- list( - "allofecundation" = constants$cost.allof * constants$cost.pheno.field, - "autofecundation" = constants$cost.autof * constants$cost.pheno.field, - "haplodiploidization" = constants$cost.haplodiplo * constants$cost.pheno.field, - "pheno-field" = constants$cost.pheno.field, - "pheno-patho" = constants$cost.pheno.patho * constants$cost.pheno.field, - "geno-hd" = constants$cost.geno.hd * constants$cost.pheno.field, - "geno-ld" = round(constants$cost.geno.ld * constants$cost.pheno.field, 2), - "geno-single-snp" = constants$cost.geno.single * constants$cost.pheno.field, - "register" = constants$cost.register * constants$cost.pheno.field -) subset.snps <- list() f <- paste0(setup$init.dir, "/snp_coords_hd.txt.gz") diff --git a/server.R b/server.R index 1988476..b5538e7 100644 --- a/server.R +++ b/server.R @@ -40,4 +40,5 @@ shinyServer(function(input, output, session) { source("src/server/server_theory.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_admin.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_about.R", local = TRUE, encoding = "UTF-8")$value + source("./src/server/server_constants.R", local = TRUE, encoding = "UTF-8")$value }) diff --git a/src/fun/constants_module.R b/src/fun/constants_module.R new file mode 100644 index 0000000..a7819e6 --- /dev/null +++ b/src/fun/constants_module.R @@ -0,0 +1,92 @@ +# Showing DB values in the UI is not so straitforward, as +# each values needs its own id and "outputs". +# This define a "shiny modules" that helps for that. + + +constants_ui <- function(id) { + ns <- NS(id) + textOutput(ns("value"), inline = TRUE) +} + +constants_server <- function(const, constantsReactive) { + function(id) { + moduleServer(id, function(input, output, session) { + output$value <- renderText({ + default <- "NA" + tryCatch( + { + constants <- constantsReactive() + if (const == "") { + } + if (const == "generations.per.year") { + return(12 / constants$duration.allof) + } + if (const == "register.min.trait1.percent") { + return(100 * constants$register.min.trait1) + } + if (const == "cost.register.mendels") { + 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)) + } + if (const == "cost.geno.single.mendels") { + return(format(constants$cost.geno.single * constants$cost.pheno.field, digits = 2)) + } + if (const == "cost.geno.ld.mendels") { + return(format(constants$cost.geno.ld * constants$cost.pheno.field, digits = 2)) + } + if (const == "cost.geno.hd.mendels") { + return(format(constants$cost.geno.hd * constants$cost.pheno.field, digits = 2)) + } + if (const == "cost.haplodiplo.mendels") { + return(format(constants$cost.haplodiplo * constants$cost.pheno.field, digits = 2)) + } + + if (const == "cost.autof.mendels") { + return(format(constants$cost.autof * constants$cost.pheno.field, digits = 2)) + } + if (const == "cost.allof.mendels") { + return(format(constants$cost.allof * constants$cost.pheno.field, digits = 2)) + } + if (const == "max.upload.pheno.field") { + return(format(as.Date(constants$max.upload.pheno.field, format = "%m-%d"), "%B %d")) + } + if (const == "chr.length.Mb") { + return(format(constants$chr.length / 10^6, digits = 2)) + } + + if (const == "duration.allof") { + return(format(12 / constants$duration.allof, + digits = 2 + )) + } + + if (const == "pheno.data.availability.date") { + max.upload.pheno.field <- constants$max.upload.pheno.field + duration.pheno.field <- constants$duration.pheno.field + return(format(seq.Date(as.Date(max.upload.pheno.field, format = "%m-%d"), + length = 2, + by = paste0(duration.pheno.field, " months") + )[2], "%B %d")) + } + if (const == "cost.pheno.patho.mendels") { + return(round(constants$cost.pheno.patho * constants$cost.pheno.field, 2)) + } + if (const == "max.upload.pheno.field") { + return(format(as.Date(constants$max.upload.pheno.field, format = "%m-%d"), "%B %d")) + } + if (const %in% names(constants)) { + return(constants[[const]]) + } + return(default) + }, + error = function(err) { + return(default) + } + ) + }) + }) + } +} diff --git a/src/fun/func_admin.R b/src/fun/func_admin.R index 058c2a4..8d2af99 100644 --- a/src/fun/func_admin.R +++ b/src/fun/func_admin.R @@ -110,7 +110,7 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { rep(NA, length(coll.ids)), coll.ids, rep( - paste0(constants$first.year, "-01-01 00:00:00"), + paste0(getBreedingGameConstants()$first.year, "-01-01 00:00:00"), length(coll.ids) ), sep = "','", collapse = "'),('" diff --git a/src/fun/func_eval.R b/src/fun/func_eval.R index 9016a64..7714df6 100644 --- a/src/fun/func_eval.R +++ b/src/fun/func_eval.R @@ -190,7 +190,7 @@ getAFs <- function(pop, breeder, progressAFS = NULL) { # pop (character verctor) names of individuals X <- matrix( nrow = length(pop), - ncol = constants$nb.snps + ncol = getBreedingGameConstants()$nb.snps ) rownames(X) <- pop @@ -251,19 +251,18 @@ getBreederHistory <- function(breeder, setup) { #' @param query \code{data.frame} containing individuals list #' (\code{ind} column is required) #' @param setup game's setup. -#' @param constants game's constants #' @param progressBar (optional) a \code{shiny} progress bar #' #' @return #' @export #' #' @examples -calcAdditiveRelation <- function(breeder, query, setup, constants, progressBar = NULL) { +calcAdditiveRelation <- function(breeder, query, setup, progressBar = NULL) { query <- query[query$breeder == breeder, ] ## 1. load the haplotypes and convert to genotypes X <- matrix( nrow = length(unique(query$ind)), - ncol = constants$nb.snps + ncol = getBreedingGameConstants()$nb.snps ) for (i in 1:length(unique(query$ind))) { diff --git a/src/fun/func_geno.R b/src/fun/func_geno.R index de2cf02..4a988fc 100644 --- a/src/fun/func_geno.R +++ b/src/fun/func_geno.R @@ -103,7 +103,7 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName X <- matrix( nrow = length(unique(inds.todo$ind)), - ncol = constants$nb.snps + ncol = getBreedingGameConstants()$nb.snps ) for (i in 1:length(unique(inds.todo$ind))) { @@ -237,6 +237,12 @@ createInvoiceGeno <- function(request.df) { # get prices + constants <- getBreedingGameConstants() + prices <- list( + "geno-hd" = constants$cost.geno.hd * constants$cost.pheno.field, + "geno-ld" = round(constants$cost.geno.ld * constants$cost.pheno.field, 2), + "geno-single-snp" = constants$cost.geno.single * constants$cost.pheno.field + ) invoice.geno$Unitary_Price <- as.vector(as.numeric(prices[invoice.geno$Task])) invoice.geno$Total <- invoice.geno$Unitary_Price * invoice.geno$Quantity diff --git a/src/fun/func_id.R b/src/fun/func_id.R index 8ed6384..d25c303 100644 --- a/src/fun/func_id.R +++ b/src/fun/func_id.R @@ -98,6 +98,7 @@ availToDwnld <- function(fileName, gameTime) { requestDate <- strptime(regmatches(fileName, m), format = "%Y-%m-%d") + constants <- getBreedingGameConstants() # calculate the available date if (grepl("pheno-field", fileName)) { diff --git a/src/fun/func_pheno.R b/src/fun/func_pheno.R index dad13f0..108e015 100644 --- a/src/fun/func_pheno.R +++ b/src/fun/func_pheno.R @@ -29,7 +29,7 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa # inds.todo (data frame) output of "readCheckBreedDataFile" # gameTime ("POSIXlt") of the request (given by getGameTime function) - + constants <- getBreedingGameConstants() ## Initialisations db <- dbConnect(SQLite(), dbname = setup$dbname) @@ -105,8 +105,7 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa ## 1. Calculate year effect # get the seed from database: - query <- paste0("SELECT value FROM constants WHERE item=='seed.year.effect'") - yearEffectSeed <- as.numeric(DBI::dbGetQuery(db, query)) + yearEffectSeed <- constants$seed.year.effect # set seed set.seed(yearEffectSeed + year) # seed depend of the year @@ -308,6 +307,12 @@ createInvoicePheno <- function(request.df) { invoice.pheno <- aggregate(details ~ task, data = request.df, sum) names(invoice.pheno) <- c("Task", "Quantity") + constants <- getBreedingGameConstants() + prices <- list( + "pheno-field" = constants$cost.pheno.field, + "pheno-patho" = constants$cost.pheno.patho * constants$cost.pheno.field + ) + # get prices invoice.pheno$Unitary_Price <- as.vector(as.numeric(prices[invoice.pheno$Task])) invoice.pheno$Total <- invoice.pheno$Unitary_Price * invoice.pheno$Quantity @@ -353,6 +358,9 @@ plotAvailable <- function(breeder, inds.todo, gameTime) { historyPheno <- dbGetQuery(conn = db, query) dbDisconnect(db) + ## get game constants + constants <- getBreedingGameConstants() + ## Calculate the start date of the current pheno session: limitDate <- strptime( paste0( diff --git a/src/fun/func_plant_material.R b/src/fun/func_plant_material.R index 14e4ae0..3eac105 100644 --- a/src/fun/func_plant_material.R +++ b/src/fun/func_plant_material.R @@ -186,6 +186,7 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa flush.console() nrow(res <- dbGetQuery(db, paste0("SELECT * FROM ", tbl))) + constants <- getBreedingGameConstants() getAvailDate <- function(type) { if (type == "allofecundation") { availableDate <- seq(from = gameTime, by = paste0(constants$duration.allof, " month"), length.out = 2)[2] @@ -253,6 +254,13 @@ createInvoicePltmat <- function(request.df) { # get prices + constants <- getBreedingGameConstants() + prices <- list( + "allofecundation" = constants$cost.allof * constants$cost.pheno.field, + "autofecundation" = constants$cost.autof * constants$cost.pheno.field, + "haplodiploidization" = constants$cost.haplodiplo * constants$cost.pheno.field + ) + invoice.pltmat$Unitary_Price <- as.vector(as.numeric(prices[invoice.pltmat$Task])) invoice.pltmat$Total <- invoice.pltmat$Unitary_Price * invoice.pltmat$Quantity diff --git a/src/fun/functions.R b/src/fun/functions.R index 654008f..c8457a9 100644 --- a/src/fun/functions.R +++ b/src/fun/functions.R @@ -46,13 +46,6 @@ getCodeVersion <- function(url.repo = "") { return(code.version) } -checkDbFile <- function(db.file) { - stopifnot( - file.exists(db.file), - file.access(db.file, mode = 2) == 0 - ) -} - ##' Simul breeding game ##' ##' Make the structure of the data.frame that will be given to the players when they request phenotyping during the game. @@ -455,9 +448,11 @@ writeRequest <- function(df, breeder, fileName = NULL) { ##' @return list ##' @author Timothee Flutre getBreedingGameSetup <- function(root.dir) { - stopifnot(is.character(root.dir), - length(root.dir) == 1, - dir.exists(root.dir)) + stopifnot( + is.character(root.dir), + length(root.dir) == 1, + dir.exists(root.dir) + ) out <- list(root.dir = root.dir) @@ -466,14 +461,16 @@ getBreedingGameSetup <- function(root.dir) { out$init.dir <- paste0(out$shared.dir, "/initial_data") tmp <- basename(Sys.glob(paste0(out$shared.dir, "/*"))) for (x in tmp) { - if (x != "initial_data") + if (x != "initial_data") { out$breeders <- c(out$breeders, x) + } } out$breeder.dirs <- c() - for (breeder in out$breeders) + for (breeder in out$breeders) { out$breeder.dirs[[breeder]] <- - paste0(out$shared.dir, "/", breeder) + paste0(out$shared.dir, "/", breeder) + } out$dbname <- paste0(root.dir, "/breeding-game.sqlite") @@ -484,35 +481,36 @@ getBreedingGameSetup <- function(root.dir) { ##' Get the breeding game constants ##' ##' Retrieve the constants used to parametrized the breeding game from the SQLite database. -##' @param dbname name of the SQLite database (full path) -##' @param table name of the table ##' @return list ##' @author Timothee Flutre -getBreedingGameConstants <- function(dbname) { - requireNamespace("DBI") - requireNamespace("RSQLite") - stopifnot(file.exists(dbname)) - table = "constants" - - out.list <- list() +getBreedingGameConstants <- function() { + stopifnot(file.exists(DATA_DB)) ## retrieve the content of the table - db <- DBI::dbConnect(RSQLite::SQLite(), dbname = dbname) - query <- paste0("SELECT *", - " FROM ", table) + db <- DBI::dbConnect(RSQLite::SQLite(), dbname = DATA_DB) + query <- "SELECT * FROM constants" out.df <- DBI::dbGetQuery(db, query) DBI::dbDisconnect(db) ## reformat - out.list <- as.list(out.df$value) + # suppress "NAs introduced by coercion" warning + withCallingHandlers( + { + out.list <- lapply(out.df$value, function(x) { + ifelse(!is.na(as.numeric(x)), + as.numeric(x), + x + ) + }) + }, + warning = function(warn) { + warning_to_catch <- "NAs introduced by coercion" + if (identical(warn$message, warning_to_catch)) { + tryInvokeRestart("muffleWarning") + } + } + ) names(out.list) <- out.df$item - for (i in seq_along(out.list)) - out.list[[i]] <- tryCatch({ - as.numeric(out.list[[i]]) - }, warning = function(c) { - # ex.: case of 'max.upload.pheno.field' - out.list[[i]] - }) return(out.list) } diff --git a/src/server/server_admin.R b/src/server/server_admin.R index 3251e1c..f1014f5 100644 --- a/src/server/server_admin.R +++ b/src/server/server_admin.R @@ -200,10 +200,7 @@ observeEvent(input$deleteSession, { # get the current value output$admin_currentSYE <- renderText({ input$admin_button_seedYearEfect # take depedency - db <- DBI::dbConnect(RSQLite::SQLite(), dbname = setup$dbname) - query <- paste0("SELECT value FROM constants WHERE item=='seed.year.effect'") - yearEffectSeed <- as.numeric(DBI::dbGetQuery(db, query)) - DBI::dbDisconnect(db) + yearEffectSeed <- getBreedingGameConstants()$seed.year.effect yearEffectSeed }) @@ -358,12 +355,7 @@ currentMaxDiskUsage <- reactive({ input$admin_maxDiskUsage # take depedency input$updateMaxDiskUsage # take depedency - db <- dbConnect(SQLite(), dbname = setup$dbname) - tbl <- "breeders" - query <- paste0("SELECT value FROM constants WHERE item = 'max.disk.usage'") - maxDiskUsage <- dbGetQuery(conn = db, query)[, 1] - dbDisconnect(db) - + maxDiskUsage <- getBreedingGameConstants()$max.disk.usage maxDiskUsage }) diff --git a/src/server/server_constants.R b/src/server/server_constants.R new file mode 100644 index 0000000..df623b4 --- /dev/null +++ b/src/server/server_constants.R @@ -0,0 +1,102 @@ +constantsReactive <- reactivePoll( + 5000, + session, + function() { + if (file.exists(DATA_DB)) { + file.info(DATA_DB)$mtime[1] + } else { + "" + } + }, + getBreedingGameConstants +) + +# Information page: ("How to play?") +constants_server("chr.length.Mb", constantsReactive)("info_chr.length.Mb") +constants_server("cost.allof", constantsReactive)("info_cost.allof") +constants_server("cost.allof.mendels", constantsReactive)("info_cost.allof.mendels") +constants_server("cost.autof", constantsReactive)("info_cost.autof") +constants_server("cost.autof.mendels", constantsReactive)("info_cost.autof.mendels") +constants_server("cost.geno.hd", constantsReactive)("info_cost.geno.hd") +constants_server("cost.geno.hd.mendels", constantsReactive)("info_cost.geno.hd.mendels") +constants_server("cost.geno.ld", constantsReactive)("info_cost.geno.ld") +constants_server("cost.geno.ld.mendels", constantsReactive)("info_cost.geno.ld.mendels") +constants_server("cost.geno.single", constantsReactive)("info_cost.geno.single") +constants_server("cost.geno.single.mendels", constantsReactive)("info_cost.geno.single.mendels") +constants_server("cost.haplodiplo", constantsReactive)("info_cost.haplodiplo") +constants_server("cost.haplodiplo.mendels", constantsReactive)("info_cost.haplodiplo.mendels") +constants_server("cost.pheno.field", constantsReactive)("info_cost.pheno.field") +constants_server("cost.pheno.patho", constantsReactive)("info_cost.pheno.patho") +constants_server("cost.pheno.patho.mendels", constantsReactive)("info_cost.pheno.patho.mendels") +constants_server("cost.register.mendels", constantsReactive)("info_cost.register.mendels") +constants_server("duration.allof", constantsReactive)("info_duration.allof") +constants_server("duration.autof", constantsReactive)("info_duration.autof") +constants_server("duration.geno.hd", constantsReactive)("info_duration.geno.hd") +constants_server("duration.geno.ld", constantsReactive)("info_duration.geno.ld") +constants_server("duration.geno.single", constantsReactive)("info_duration.geno.single") +constants_server("duration.haplodiplo", constantsReactive)("info_duration.haplodiplo") +constants_server("duration.pheno.field", constantsReactive)("info_duration.pheno.field") +constants_server("duration.pheno.patho", constantsReactive)("info_duration.pheno.patho") +constants_server("first.year", constantsReactive)("info_first.year") +constants_server("generations.per.year", constantsReactive)("info_generations.per.year") +constants_server("initial.budget", constantsReactive)("info_initial.budget") +constants_server("max.nb.haplodiplos", constantsReactive)("info_max.nb.haplodiplos") +constants_server("max.upload.pheno.field", constantsReactive)("info_max.upload.pheno.field") +constants_server("maxEvalInds", constantsReactive)("info_maxEvalInds") +constants_server("mu.trait1", constantsReactive)("info_mu.trait1") +constants_server("mu.trait2", constantsReactive)("info_mu.trait2") +constants_server("nb.chrs", constantsReactive)("info_nb.chrs") +constants_server("nb.controls", constantsReactive)("info_nb.controls") +constants_server("nb.genotyped.coll", constantsReactive)("info_nb.genotyped.coll") +constants_server("nb.inds.denovo", constantsReactive)("info_nb.inds.denovo") +constants_server("nb.phenotyped.coll", constantsReactive)("info_nb.phenotyped.coll") +constants_server("nb.plots", constantsReactive)("info_nb.plots") +constants_server("nb.plots", constantsReactive)("info_nb.plots2") +constants_server("nb.plots.per.ctl", constantsReactive)("info_nb.plots.per.ctl") +constants_server("nb.snps.hd", constantsReactive)("info_nb.snps.hd") +constants_server("nb.snps.ld", constantsReactive)("info_nb.snps.ld") +constants_server("nb.years.per.ctl", constantsReactive)("info_nb.years.per.ctl") +constants_server("pheno.data.availability.date", constantsReactive)("info_pheno.data.availability.date") +constants_server("register.min.trait1.percent", constantsReactive)("info_register.min.trait1.percent") +constants_server("register.min.trait2", constantsReactive)("info_register.min.trait2") + +# identification / home page: +constants_server("maxEvalInds", constantsReactive)("home_maxEvalInds") +constants_server("cost.register.mendels", constantsReactive)("home_cost.register.mendels") +constants_server("", constantsReactive)("") + +# plant material: +constants_server("cost.allof", constantsReactive)("pltmat_cost.allof") +constants_server("cost.allof.mendels", constantsReactive)("pltmat_cost.allof.mendels") +constants_server("cost.autof", constantsReactive)("pltmat_cost.autof") +constants_server("cost.autof.mendels", constantsReactive)("pltmat_cost.autof.mendels") +constants_server("cost.haplodiplo", constantsReactive)("pltmat_cost.haplodiplo") +constants_server("cost.haplodiplo.mendels", constantsReactive)("pltmat_cost.haplodiplo.mendels") +constants_server("duration.allof", constantsReactive)("pltmat_duration.allof") +constants_server("duration.autof", constantsReactive)("pltmat_duration.autof") +constants_server("duration.haplodiplo", constantsReactive)("pltmat_duration.haplodiplo") +constants_server("max.nb.haplodiplos", constantsReactive)("pltmat_max.nb.haplodiplos") + +# phenotyping page: +constants_server("cost.pheno.field", constantsReactive)("pheno_cost.pheno.field") +constants_server("cost.pheno.patho", constantsReactive)("pheno_cost.pheno.patho") +constants_server("cost.pheno.patho.mendels", constantsReactive)("pheno_cost.pheno.patho.mendels") +constants_server("duration.pheno.field", constantsReactive)("pheno_duration.pheno.field") +constants_server("duration.pheno.patho", constantsReactive)("pheno_duration.pheno.patho") +constants_server("max.upload.pheno.field", constantsReactive)("pheno_max.upload.pheno.field") +constants_server("nb.plots", constantsReactive)("pheno_nb.plots") +constants_server("nb.plots", constantsReactive)("pheno_nb.plots_2") +constants_server("pheno.data.availability.date", constantsReactive)("pheno_pheno.data.availability.date") + + +# genotyping page: +constants_server("cost.geno.hd", constantsReactive)("geno_cost.geno.hd") +constants_server("cost.geno.hd.mendels", constantsReactive)("geno_cost.geno.hd.mendels") +constants_server("cost.geno.ld", constantsReactive)("geno_cost.geno.ld") +constants_server("cost.geno.ld.mendels", constantsReactive)("geno_cost.geno.ld.mendels") +constants_server("cost.geno.single", constantsReactive)("geno_cost.geno.single") +constants_server("duration.geno.hd", constantsReactive)("geno_duration.geno.hd") +constants_server("duration.geno.ld", constantsReactive)("geno_duration.geno.ld") +constants_server("duration.geno.single", constantsReactive)("geno_duration.geno.single") +constants_server("nb.snps.hd", constantsReactive)("geno_nb.snps.hd") +constants_server("nb.snps.ld", constantsReactive)("geno_nb.snps.ld") diff --git a/src/server/server_eval.R b/src/server/server_eval.R index c65188b..f5e193f 100644 --- a/src/server/server_eval.R +++ b/src/server/server_eval.R @@ -89,7 +89,7 @@ evalGraphT1 <- reactive({ unique(as.character(dfPheno$ind[dfPheno$breeder != "control"])) ) - target <- median(dfPheno$trait1[dfPheno$breeder == "control"]) * constants$register.min.trait1 + target <- median(dfPheno$trait1[dfPheno$breeder == "control"]) * getBreedingGameConstants()$register.min.trait1 ## Plot @@ -141,7 +141,7 @@ evalGraphT2 <- reactive({ unique(as.character(dfPheno$ind[dfPheno$breeder != "control"])) ) - target <- constants$register.min.trait2 + target <- getBreedingGameConstants()$register.min.trait2 ## Plot @@ -479,7 +479,6 @@ output$addRelTable <- renderTable( breeder = input$addRelBreeder, query = readQryEval(), setup = setup, - constants = constants ) }, rownames = TRUE, @@ -549,6 +548,8 @@ breederHistoryTimeLines <- reactive({ colorPhenoF <- "#ed8b3b" colorPhenoP <- "#ed9e5c" + constants <- getBreedingGameConstants() + dta$duration[dta$task == "geno-hd"] <- constants$duration.geno.hd dta$color[dta$task == "geno-hd"] <- colorGenoHD @@ -713,7 +714,6 @@ scoreTable <- eventReactive(input$calcScore, { dfPheno <- dfPhenoEval() dfPheno$GAT1 <- dfPheno$GAT1 + p0$mu["trait1"] dfPheno$GAT2 <- dfPheno$GAT2 + p0$mu["trait2"] - # browser() scoreTable <- dfPheno %>% group_by(ind, breeder) %>% @@ -728,7 +728,7 @@ scoreTable <- eventReactive(input$calcScore, { } else if (input$scoreType == "T1_minimalT2") { scoreTable$score <- scoreTable$GAT1 - targetQuality <- constants$register.min.trait2 + targetQuality <- getBreedingGameConstants()$register.min.trait2 lowQuality <- scoreTable$GAT2 < targetQuality scoreTable$score[lowQuality] <- scoreTable$score[lowQuality] * (1 - input$T2_penalty / 100) } @@ -777,7 +777,4 @@ output$scoreTable <- renderTable( ## debug ---- output$evalDebug <- renderPrint({ - print("---------") - print(constants$register.min.trait2) - print(scoreTable()) }) diff --git a/src/server/server_geno.R b/src/server/server_geno.R index 4bd2ba6..1d01313 100644 --- a/src/server/server_geno.R +++ b/src/server/server_geno.R @@ -47,7 +47,7 @@ readQryGeno <- reactive({ # read input file max.nb.inds <- ifelse(breederStatus() != "player", - Inf, constants$max.nb.inds + Inf, getBreedingGameConstants()$max.nb.inds ) test <- try(df <- readCheckBreedDataFile(input$file.geno$datapath, subset.snps = subset.snps, @@ -168,7 +168,7 @@ output$genoRequestResultUI <- renderUI({ # display message p( "Great ! Your results will be available in ", - constants$duration.geno.hd, " months." + getBreedingGameConstants()$duration.geno.hd, " months." ) } else if (!is.null(geno_data()) && geno_data() == "error") { p("Something went wrong. Please check your file.") diff --git a/src/server/server_id.R b/src/server/server_id.R index 0a408e8..156c3b7 100644 --- a/src/server/server_id.R +++ b/src/server/server_id.R @@ -77,12 +77,8 @@ accessGranted <- eventReactive(input$submitPSW, if (goodPswd && status != "game master") { withProgress( { - # get maxDiskUsage - db <- dbConnect(SQLite(), dbname = setup$dbname) - tbl <- "breeders" - query <- paste0("SELECT value FROM constants WHERE item = 'max.disk.usage'") - maxDiskUsage <- as.numeric(dbGetQuery(conn = db, query)[, 1]) - dbDisconnect(db) + maxDiskUsage <- getBreedingGameConstants()$max.disk.usage + allDataFiles <- list.files("data", all.files = TRUE, recursive = TRUE) currentSize <- sum(na.omit(file.info(paste0("data/", allDataFiles))$size)) / @@ -166,12 +162,26 @@ budget <- reactive({ input$requestGeno input$id_submitInds if (breeder() != "No Identification") { - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- "log" query <- paste0("SELECT * FROM ", tbl, " WHERE breeder='", breeder(), "'") res <- dbGetQuery(conn = db, query) dbDisconnect(db) + + constants <- getBreedingGameConstants() + prices <- list( + "allofecundation" = constants$cost.allof * constants$cost.pheno.field, + "autofecundation" = constants$cost.autof * constants$cost.pheno.field, + "haplodiploidization" = constants$cost.haplodiplo * constants$cost.pheno.field, + "pheno-field" = constants$cost.pheno.field, + "pheno-patho" = constants$cost.pheno.patho * constants$cost.pheno.field, + "geno-hd" = constants$cost.geno.hd * constants$cost.pheno.field, + "geno-ld" = round(constants$cost.geno.ld * constants$cost.pheno.field, 2), + "geno-single-snp" = constants$cost.geno.single * constants$cost.pheno.field, + "register" = constants$cost.register * constants$cost.pheno.field + ) + if (nrow(res) > 0) { funApply <- function(x) { prices[x[3]][[1]] * as.integer(x[4]) @@ -514,6 +524,7 @@ observeEvent(input$id_submitInds, priority = 10, { } } + constants <- getBreedingGameConstants() if (length(inds) > constants$maxEvalInds - nSubmitted) { alert(paste("Sorry, you have already submitted", nSubmitted, "individuals, on a total of", constants$maxEvalInds, ". You can only submit", constants$maxEvalInds - nSubmitted, "more individuals.")) return(subIndsDta) diff --git a/src/server/server_pheno.R b/src/server/server_pheno.R index 759c6c2..888e441 100644 --- a/src/server/server_pheno.R +++ b/src/server/server_pheno.R @@ -45,7 +45,7 @@ readQryPheno <- reactive({ # read input file max.nb.plots <- ifelse(breederStatus() != "player", - Inf, constants$nb.plots + Inf, getBreedingGameConstants()$nb.plots ) test <- try(df <- readCheckBreedDataFile(input$file.pheno$datapath, subset.snps = subset.snps, diff --git a/src/server/server_plant_material.R b/src/server/server_plant_material.R index cbdbf1b..482743d 100644 --- a/src/server/server_plant_material.R +++ b/src/server/server_plant_material.R @@ -47,6 +47,7 @@ readQryPlmat <- reactive({ # read input file + constants <- getBreedingGameConstants() maxHD <- ifelse(breederStatus() != "player", Inf, constants$max.nb.haplodiplos ) diff --git a/src/server/server_theory.R b/src/server/server_theory.R index c56299b..6325918 100644 --- a/src/server/server_theory.R +++ b/src/server/server_theory.R @@ -22,24 +22,25 @@ source("src/fun/func_theory.R", local = TRUE, encoding = "UTF-8")$value getDatSel <- reactive({ - dat <- simulDat( + data <- simulDat( mu.0 = input$mu.0, sigma2 = (1 - input$h2) * input$sigma.0^2, h2 = input$h2, - I = constants$nb.phenotyped.coll, + I = 800, seed = 1859 ) sel <- applySelection( - mu.0 = dat$mu.0, y = dat$y, y.e = dat$y.e, - y.t = input$y.t, sigma.02 = dat$sigma.a2 + dat$sigma2 + mu.0 = data$mu.0, y = data$y, y.e = data$y.e, + y.t = input$y.t, sigma.02 = data$sigma.a2 + data$sigma2 ) - return(append(dat, sel)) + return(append(data, sel)) }) output$regParsOffs <- renderPlot({ all <- getDatSel() + plotRegMidparentsOffsprings( mu.0 = all$mu.0, sigma.02 = all$sigma.a2 + all$sigma2, diff --git a/src/ui/ui_geno.R b/src/ui/ui_geno.R index cf5c987..58e3de1 100644 --- a/src/ui/ui_geno.R +++ b/src/ui/ui_geno.R @@ -36,10 +36,10 @@ tabItem( p("In this module you, can request genotyping data."), p("A laboratory can be used", strong("all year long"), " to perform genotyping. Two SNP chips are available:"), tags$ul( - tags$li(strong("High-density"), ": ", constants$nb.snps.hd, " SNP, ", constants$duration.geno.hd, "-month delay and costs", constants$cost.geno.hd, " plot (", format(constants$cost.geno.hd * constants$cost.pheno.field, digits = 2), " Mendels )."), - tags$li(strong("Low-density"), ": ", constants$nb.snps.ld, " SNP, ", constants$duration.geno.ld, "-month delay and costs", constants$cost.geno.ld, " plot (", format(constants$cost.geno.ld * constants$cost.pheno.field, digits = 2), " Mendels ).") + tags$li(strong("High-density"), ": ", constants_ui("geno_nb.snps.hd"), " SNP, ", constants_ui("geno_duration.geno.hd"), "-month delay and costs", constants_ui("geno_cost.geno.hd"), " plot (", constants_ui("geno_cost.geno.hd.mendels"), " Mendels )."), + tags$li(strong("Low-density"), ": ", constants_ui("geno_nb.snps.ld"), " SNP, ", constants_ui("geno_duration.geno.ld"), "-month delay and costs", constants_ui("geno_cost.geno.ld"), " plot (", constants_ui("geno_cost.geno.ld.mendels"), " Mendels ).") ), - p(strong("Single-SNP"), "genotyping can also be performed: ", constants$duration.geno.single, "-month delay and costs", constants$cost.geno.single, " plot (", format(constants$cost.geno.single * constants$cost.pheno.field, digits = 2), " Mendels ).") + p(strong("Single-SNP"), "genotyping can also be performed: ", constants_ui("geno_duration.geno.single"), "-month delay and costs", constants_ui("geno_cost.geno.single"), " plot (", constants_ui("geno_cost.geno.single.mendels"), " Mendels ).") ), div( id = "geno_info2", diff --git a/src/ui/ui_id_loggedIn.R b/src/ui/ui_id_loggedIn.R index 1829d7c..0c6f85f 100644 --- a/src/ui/ui_id_loggedIn.R +++ b/src/ui/ui_id_loggedIn.R @@ -104,10 +104,10 @@ shinydashboard::tabBox( p("You can specify here the individuals you want to submit for the final evaluation."), p( "A maximum of ", - strong(constants$maxEvalInds, " individuals"), + strong(constants_ui("home_maxEvalInds"), "individuals"), "can be registered." ), - p("The registration fee is ", strong(format(constants$cost.register * constants$cost.pheno.field, digits = 2), " Mendels"), "per genotype. No refund are possible, thank-you for your understanding.") + p("The registration fee is ", strong(constants_ui("home_cost.register.mendels"), "Mendels"), "per genotype. No refund are possible, thank-you for your understanding.") ), div( selectInput("id_evalInds", diff --git a/src/ui/ui_information.R b/src/ui/ui_information.R index 0d63981..81964ef 100644 --- a/src/ui/ui_information.R +++ b/src/ui/ui_information.R @@ -38,72 +38,72 @@ tabItem( "Recently discovered on the borders of the upper valley of the Aghromonpe, ", shiny::em("Apimeta simulans"), " belongs to the ", shiny::em("Statisticeae"), " genus.", " It produces flowers which contain an alkaloid compound, named ", shiny::em("sepmetin"), ", which is consumed by students to avoid headaches during excessive intellectual effort.", " The market is therefore very important and growing rapidly.", - " Producers are paid for the quantity produced, with yields in the order of ", constants$mu.trait1, " kg of flowers per hectare, but processors have managed to require that the average ", shiny::em("sepmetin"), " content of commercial lots be above ", constants$mu.trait2, " per thousand." + " Producers are paid for the quantity produced, with yields in the order of ", constants_ui("info_mu.trait1"), " kg of flowers per hectare, but processors have managed to require that the average ", shiny::em("sepmetin"), " content of commercial lots be above ", constants_ui("info_mu.trait2"), " per thousand." ), h2("Biology and ecology"), p( shiny::em("Apimeta simulans"), " is annual, hermaphrodite and autogamous.", " It is commercially available as pure lines, and crosses easily.", - " Up to ", format(12 / constants$duration.allof, digits = 2), " generations per year can be produced in greenhouses to accelerate fixation until homozygosity.", + " Up to ", constants_ui("info_generations.per.year"), " generations per year can be produced in greenhouses to accelerate fixation until homozygosity.", " It is also possible to produce doubled haploids via haplodiploidisation.", " The multiplication rate of the species is very high, each plant being able to produce more than 1000 seeds.", " However, ", HTML("A. simulans"), " is susceptible to various fungi, most notably the dreaded fluorescent rust, ", shiny::em("Putrida psychedelica"), "." ), h2("Genomic and genetic resources"), p( - "The species is diploid, with ", constants$nb.chrs, " chromosomes, all of the same size (", format(constants$chr.length / 10^6, digits = 2), " Mb).", + "The species is diploid, with ", constants_ui("info_nb.chrs"), " chromosomes, all of the same size (", constants_ui("info_chr.length.Mb"), " Mb).", " A physical map is also available.", - " Two microarrays were constructed from the ", HTML("de novo"), " sequencing of ", constants$nb.inds.denovo, " individuals: a high-density chip with ", constants$nb.snps.hd, " SNP markers and a low-density one with ", constants$nb.snps.ld, " SNP markers.", + " Two microarrays were constructed from the ", HTML("de novo"), " sequencing of ", constants_ui("info_nb.inds.denovo"), " individuals: a high-density chip with ", constants_ui("info_nb.snps.hd"), " SNP markers and a low-density one with ", constants_ui("info_nb.snps.ld"), " SNP markers.", " KASPar genotyping can also be developed for single SNPs." ), p( "The species was domesticated recently.", " Despite the dangers in the uninhabited Aghromonpe valley, several sampling campaigns were conducted.", - " As a result, numerous accessions were gathered into a genetic resources collection, from which ", constants$nb.phenotyped.coll, " lines were derived." + " As a result, numerous accessions were gathered into a genetic resources collection, from which ", constants_ui("info_nb.phenotyped.coll"), " lines were derived." ), h2("Available data"), p( - "These lines were planted and phenotyped on the only experimental site consisting of ", constants$nb.plots, " plots.", - " Starting in ", constants$first.year, ", each year for ", 10, " years, ", 150, " lines were planted, in ", 2, " plots each.", + "These lines were planted and phenotyped on the only experimental site consisting of ", constants_ui("info_nb.plots"), " plots.", + " Starting in ", constants_ui("info_first.year"), ", each year for ", 10, " years, ", 150, " lines were planted, in ", 2, " plots each.", " In addition, most lines were planted two successive years.", " Each year, the trial hence includes ", 75, " lines already tested in the previous year, and ", 75, " new lines." ), p( "The data collected are flower production in kg/ha (", code("trait1"), "), ", shiny::em("sepmetin"), " content in g/kg (", code("trait2"), "), and the presence of symptoms caused by ", HTML("P. psychedelica"), "(", code("trait3"), ").", - " For ", constants$nb.genotyped.coll, "lines tested the last years, genotypic data on the high-density chip are already available.", - " Moreover, phenotypes of the ", constants$nb.controls, " controls used at the end of the game are also provided (", constants$nb.years.per.ctl, " years, ", constants$nb.plots.per.ctl, " plots per control)." + " For ", constants_ui("info_nb.genotyped.coll"), "lines tested the last years, genotypic data on the high-density chip are already available.", + " Moreover, phenotypes of the ", constants_ui("info_nb.controls"), " controls used at the end of the game are also provided (", constants_ui("info_nb.years.per.ctl"), " years, ", constants_ui("info_nb.plots.per.ctl"), " plots per control)." ), p(strong("Download the data"), " at the bottom of this page."), h2("Experimental and financial means"), p( - strong("Experimental site"), ": the only experimental site, Agrom-sur-Lez (AZ), has ", strong(constants$nb.plots, " plots."), - " Planting a plot should be requested before ", strong(format(as.Date(constants$max.upload.pheno.field, format = "%m-%d"), "%B %d")), ", and requires about ", 500, " seeds.", - " The cost of a single plot (seeding, phenotyping of the three traits and harvesting) is ", strong(constants$cost.pheno.field, " Mendels"), ", and is used as a reference for all other costs.", - " Phenotypic data are available ", constants$duration.pheno.field, " months after, that is not before ", strong(format(seq.Date(as.Date(constants$max.upload.pheno.field, format = "%m-%d"), length = 2, by = paste0(constants$duration.pheno.field, " months"))[2], "%B %d")), "." + strong("Experimental site"), ": the only experimental site, Agrom-sur-Lez (AZ), has ", strong(constants_ui("info_nb.plots2"), " plots."), + " Planting a plot should be requested before ", strong(constants_ui("info_max.upload.pheno.field")), ", and requires about ", 500, " seeds.", + " The cost of a single plot (seeding, phenotyping of the three traits and harvesting) is ", strong(constants_ui("info_cost.pheno.field"), " Mendels"), ", and is used as a reference for all other costs.", + " Phenotypic data are available ", constants_ui("info_duration.pheno.field"), " months after, that is not before ", strong(constants_ui("info_pheno.data.availability.date")), "." ), p( strong("Greenhouse"), ": it can be used all year long to phenotype ", HTML("P. psychedelica"), ", as well as perform crosses (allofecundation and autofecundation).", - " ", strong("Rust phenotyping"), " has a ", strong(constants$duration.pheno.patho, "-month"), " delay and costs ", strong(constants$cost.pheno.patho, " plot"), " (", format(constants$cost.pheno.patho * constants$cost.pheno.field, digits = 2), " Mendels).", - " ", strong("Allofecundation"), " has a ", strong(constants$duration.allof, "-month"), " delay and costs ", strong(constants$cost.allof, " plot"), " (", format(constants$cost.allof * constants$cost.pheno.field, digits = 2), " Mendels).", - " ", strong("Autofecundation"), " has a ", strong(constants$duration.autof, "-month"), " delay and costs ", strong(constants$cost.autof, " plot"), " (", format(constants$cost.autof * constants$cost.pheno.field, digits = 2), " Mendels)." + " ", strong("Rust phenotyping"), " has a ", strong(constants_ui("info_duration.pheno.patho"), "-month"), " delay and costs ", strong(constants_ui("info_cost.pheno.patho"), " plot"), " (", constants_ui("info_cost.pheno.patho.mendels"), " Mendels).", + " ", strong("Allofecundation"), " has a ", strong(constants_ui("info_duration.allof"), "-month"), " delay and costs ", strong(constants_ui("info_cost.allof"), " plot"), " (", constants_ui("info_cost.allof.mendels"), " Mendels).", + " ", strong("Autofecundation"), " has a ", strong(constants_ui("info_duration.autof"), "-month"), " delay and costs ", strong(constants_ui("info_cost.autof"), " plot"), " (", constants_ui("info_cost.autof.mendels"), " Mendels)." ), p( strong("Laboratory"), ": it can be used to perform haplodiploidisation (similar as for maize), and genotype samples on the various SNP chips.", - " ", strong("Haplodiploidisation"), " has a ", strong(constants$duration.haplodiplo, "-month"), " delay, costs ", strong(constants$cost.haplodiplo, " plot"), " (", format(constants$cost.haplodiplo * constants$cost.pheno.field, digits = 2), " Mendels), and a maximum of ", constants$max.nb.haplodiplos, " can be requested at once.", - " ", strong("High-density genotyping"), " has a ", strong(constants$duration.geno.hd, "-month"), " delay and costs ", strong(constants$cost.geno.hd, " plot"), " (", format(constants$cost.geno.hd * constants$cost.pheno.field, digits = 2), " Mendels).", - " ", strong("Low-density genotyping"), " has a ", strong(constants$duration.geno.ld, "-month"), " delay and costs ", strong(format(constants$cost.geno.ld, digits = 2), " plot"), " (", format(constants$cost.geno.ld * constants$cost.pheno.field, digits = 2), " Mendels).", - " ", strong("Single-SNP genotyping"), " has a ", strong(constants$duration.geno.single, "-month"), " delay and costs ", strong(format(constants$cost.geno.single, digits = 2), " plot"), " (", format(constants$cost.geno.single * constants$cost.pheno.field, digits = 2), " Mendels)." + " ", strong("Haplodiploidisation"), " has a ", strong(constants_ui("info_duration.haplodiplo"), "-month"), " delay, costs ", strong(constants_ui("info_cost.haplodiplo"), " plot"), " (", constants_ui("info_cost.haplodiplo.mendels"), " Mendels), and a maximum of ", constants_ui("info_max.nb.haplodiplos"), " can be requested at once.", + " ", strong("High-density genotyping"), " has a ", strong(constants_ui("info_duration.geno.hd"), "-month"), " delay and costs ", strong(constants_ui("info_cost.geno.hd"), " plot"), " (", constants_ui("info_cost.geno.hd.mendels"), " Mendels).", + " ", strong("Low-density genotyping"), " has a ", strong(constants_ui("info_duration.geno.ld"), "-month"), " delay and costs ", strong(constants_ui("info_cost.geno.ld"), " plot"), " (", constants_ui("info_cost.geno.ld.mendels"), " Mendels).", + " ", strong("Single-SNP genotyping"), " has a ", strong(constants_ui("info_duration.geno.single"), "-month"), " delay and costs ", strong(constants_ui("info_cost.geno.single"), " plot"), " (", constants_ui("info_cost.geno.single.mendels"), " Mendels)." ), - p(strong("Budget"), ": each team starts with a total budget of ", strong(format(constants$cost.pheno.field * constants$nb.plots * 10 * 1.3, digits = 2, scientific = F), " Mendels"), ", fully available from the start."), + p(strong("Budget"), ": each team starts with a total budget of ", strong(constants_ui("info_initial.budget"), " Mendels"), ", fully available from the start."), h2("Final trial"), p( - "At the end of the game, each team will have to propose to register their best genotypes (up to five).", - " The registration fee is ", format(constants$cost.register * constants$cost.pheno.field, digits = 2), " Mendels per genotype." + "At the end of the game, each team will have to propose to register their best genotypes (up to", constants_ui("info_maxEvalInds"), ").", + " The registration fee is ", constants_ui("info_cost.register.mendels"), " Mendels per genotype." ), p( " Each of them must meet the DHS criteria, which will be assessed primarily on their heterozygosity: < 3%.", - " They must also meet the VATE criteria corresponding to a minimum of ", 100 * constants$register.min.trait1, "% of the flower production of the control lines (known at the beginning of the program).", - " Varieties below the ", constants$register.min.trait2, " per thousand of ", shiny::em("sepmetin"), " will be eliminated.", + " They must also meet the VATE criteria corresponding to a minimum of ", constants_ui("info_register.min.trait1.percent"), "% of the flower production of the control lines (known at the beginning of the program).", + " Varieties below the ", constants_ui("info_register.min.trait2"), " per thousand of ", shiny::em("sepmetin"), " will be eliminated.", " Resistant varieties will have a bonus." ), p( diff --git a/src/ui/ui_pheno.R b/src/ui/ui_pheno.R index 8f5bff8..fd7c55f 100644 --- a/src/ui/ui_pheno.R +++ b/src/ui/ui_pheno.R @@ -20,8 +20,6 @@ # UI of "pheno" part - - tabItem( tabName = "pheno", fluidRow( @@ -36,12 +34,12 @@ tabItem( id = "pheno_info1", p("In this module, you can request phenotyping data."), p( - "One experimental site, Agrom-sur-Lez (AZ), is available with ", strong(constants$nb.plots, " plots."), - " Planting a plot should be requested ", strong("before ", format(as.Date(constants$max.upload.pheno.field, format = "%m-%d"), "%B %d")), ", and requires about ", 500, " seeds.", - " The data are available ", constants$duration.pheno.field, " months after, that is not before ", strong(format(seq.Date(as.Date(constants$max.upload.pheno.field, format = "%m-%d"), length = 2, by = paste0(constants$duration.pheno.field, " months"))[2], "%B %d")), ".", - " The cost of a single plot (seeding, phenotyping of the three traits and harvesting) is ", strong(constants$cost.pheno.field, " Mendels.") + "One experimental site, Agrom-sur-Lez (AZ), is available with ", strong(constants_ui("pheno_nb.plots"), " plots."), + " Planting a plot should be requested ", strong("before ", constants_ui("pheno_max.upload.pheno.field")), ".", + " The data are then available ", constants_ui("pheno_duration.pheno.field"), " months after, on ", strong(constants_ui("pheno_pheno.data.availability.date")), ".", + " The cost of a single plot (seeding, phenotyping of the three traits and harvesting) is ", strong(constants_ui("pheno_cost.pheno.field"), " Mendels.") ), - p("A", strong("greenhouse"), " can also be used all year long to assess the resistance to", HTML("P. psychedelica."), "This request has a ", strong(constants$duration.pheno.patho, "-month"), " delay and costs ", strong(constants$cost.pheno.patho, " plot"), " (", format(constants$cost.pheno.patho * constants$cost.pheno.field, digits = 2), " Mendels).") + p("A", strong("greenhouse"), " can also be used all year long to assess the resistance to", HTML("P.psychedelica."), "This request takes ", strong(constants_ui("pheno_duration.pheno.patho"), "months"), " and costs ", strong(constants_ui("pheno_cost.pheno.patho.mendels"), " Mendels"), " (which represents", constants_ui("pheno_cost.pheno.patho"), " plot).") ), div( id = "pheno_info2", @@ -67,7 +65,8 @@ tabItem( tags$li("The file should be in", code(".txt"), "format with", strong("tabulations"), "separator and ", strong(code("UTF-8"), "encoding.")), tags$li("All columns (", code("ind"), ", ", code("task"), ", and ", code("details"), ") are compulsory."), tags$li("The ", code("task"), " column should contain 'pheno-field' (for experimental site phenotyping) or 'pheno-patho' (for greenhouse phenotyping)"), - tags$li("If 'task=pheno-field', the ", code("details"), " column should contain the number of plots (the total number of requested plots should not exceed the total available:", strong(constants$nb.plots, " plots."), ")"), + tags$li("If 'task=pheno-field', the ", code("details"), " column should contain the number of plots (the total number of requested plots should not exceed the total available:", strong(constants_ui("pheno_nb.plots_2"), " plots."), ")"), + # WIP ---- blocked here as `outputs` can only be used once ! >< tags$li("If 'task=pheno-patho', the ", code("details"), " column should contain the number of replicates"), tags$li("Individuals should be available."), tags$li("Individuals should not be duplicated within each task."), @@ -107,9 +106,6 @@ tabItem( "Summary", tableOutput("PhenoInvoice") ), - # verbatimTextOutput("PhenoSmy"), - # verbatimTextOutput("PhenoStr")), - tabPanel( "Check", verbatimTextOutput("PhenoUploaded") @@ -121,5 +117,5 @@ tabItem( verbatimTextOutput("PhenoDebug") ) } - ) # close fluidRow -) # close tabItem + ) +) diff --git a/src/ui/ui_plant_material.R b/src/ui/ui_plant_material.R index 8cbf22b..3ebf01a 100644 --- a/src/ui/ui_plant_material.R +++ b/src/ui/ui_plant_material.R @@ -35,10 +35,10 @@ tabItem( p("In this module, you can request new plant materials."), p("A greenhouse can be used", strong("all year long"), " to perform crosses:"), tags$ul( - tags$li(strong("Allofecundation"), ": ", constants$duration.allof, "-month delay and costs", constants$cost.allof, " plot (", format(constants$cost.allof * constants$cost.pheno.field, digits = 2), " Mendels )."), - tags$li(strong("Autofecundation"), ": ", constants$duration.autof, "-month delay and costs", constants$cost.autof, " plot (", format(constants$cost.autof * constants$cost.pheno.field, digits = 2), " Mendels ).") + tags$li(strong("Allofecundation"), ": ", constants_ui("pltmat_duration.allof"), "-month delay and costs", constants_ui("pltmat_cost.allof"), " plot (", constants_ui("pltmat_cost.allof.mendels"), " Mendels )."), + tags$li(strong("Autofecundation"), ": ", constants_ui("pltmat_duration.autof"), "-month delay and costs", constants_ui("pltmat_cost.autof"), " plot (", constants_ui("pltmat_cost.autof.mendels"), " Mendels ).") ), - p("A laboratory can also be used to perform ", strong("haplodiploidisation"), ". It has a ", constants$duration.haplodiplo, "-month delay, costs ", constants$cost.haplodiplo, " plot (", format(constants$cost.haplodiplo * constants$cost.pheno.field, digits = 2), " Mendels ), and a maximum of ", constants$max.nb.haplodiplos, " can be requested at once.") + p("A laboratory can also be used to perform ", strong("haplodiploidisation"), ". It has a ", constants_ui("pltmat_duration.haplodiplo"), "-month delay, costs ", constants_ui("pltmat_cost.haplodiplo"), " plot (", constants_ui("pltmat_cost.haplodiplo.mendels"), " Mendels ), and a maximum of ", constants_ui("pltmat_max.nb.haplodiplos"), " can be requested at once.") ), div( id = "cross_info2", diff --git a/src/ui/ui_theory.R b/src/ui/ui_theory.R index d1a51ac..d547120 100644 --- a/src/ui/ui_theory.R +++ b/src/ui/ui_theory.R @@ -38,29 +38,27 @@ tabItem( width = 12, title = "Parameters", sliderInput("mu.0", "Phenotypic mean without selection (\\(\\mu_0\\)):", min = 0, - max = 1.2 * constants$mu.trait1, - value = constants$mu.trait1, - step = 5, round = TRUE + max = 1.2 * 100, # 100 is the default value for mu.trait1 + value = 100, # 100 is the default value for mu.trait1 + step = 1, round = TRUE ), sliderInput("sigma.0", "Phenotypic standard deviation without selection (\\(\\sigma_0\\)):", min = 0, - max = round(1.2 * sqrt(constants$sigma.p2.trait1)), - value = sqrt(constants$sigma.p2.trait1), - step = 10, round = TRUE + max = round(1.2 * sqrt(711)), # 711 is the default value for simga.p2.trait1 + value = sqrt(711), # 711 is the default value for simga.p2.trait1 + step = 1, round = TRUE ), sliderInput("h2", "Narrow-sense heritability (\\(h^2\\)):", min = 0, - max = 1, + max = 0.99, value = 0.75, - step = 0.05 + step = 0.01 ), sliderInput("y.t", "Phenotypic threshold (\\(y_t\\)):", min = 0, - max = round(constants$mu.trait1 + - 4 * sqrt(constants$sigma.p2.trait1)), - value = constants$mu.trait1 + - 2 * sqrt(constants$sigma.p2.trait1), - step = 2, round = TRUE + max = round(100 + 4 * sqrt(711)), # mu + 4 sigma + value = round(100 + 1 * sqrt(711)), + step = 1, round = TRUE ) ), shinydashboard::box( diff --git a/tests_UI/test-1.spec.ts b/tests_UI/test-1.spec.ts index 03e2765..f77e83d 100644 --- a/tests_UI/test-1.spec.ts +++ b/tests_UI/test-1.spec.ts @@ -5,13 +5,14 @@ import { join } from "path"; import gunzip from "gunzip-file"; const psw: string = "1234"; +const page_root: string = "http://127.0.0.1:3000"; interface Registerd_indsList { [key: string]: string[]; } test.describe("PlantBreedGame_UI", () => { test.beforeEach(async ({ page }) => { - await page.goto("/"); + await page.goto(page_root); }); test("addBreeder", async ({ page }) => { @@ -63,7 +64,7 @@ test.describe("PlantBreedGame_UI", () => { // register individuals: for (let breeder in registered_inds) { - await page.goto("http://127.0.0.1:3000/"); + await page.goto(page_root); await login(page, breeder, psw); await registerIndividuals(page, registered_inds[breeder], false); } @@ -109,7 +110,7 @@ test.describe("PlantBreedGame_UI", () => { // register individuals: for (let breeder in registered_inds) { - await page.goto("http://127.0.0.1:3000/"); + await page.goto(page_root); await login(page, breeder, psw); await registerIndividuals(page, registered_inds[breeder], false); } @@ -119,7 +120,7 @@ test.describe("PlantBreedGame_UI", () => { }); async function login(page: Page, username: string, password: string) { - await page.goto("http://127.0.0.1:3000/"); + await page.goto(page_root); await page .getByRole("link", { name: "house-user icon Identification / Home" }) .click(); From 3977b5c2deb7764f368a6b69410479fd97993a23 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Wed, 29 May 2024 16:52:15 +0900 Subject: [PATCH 03/12] suppress R package startup messages --- src/dependencies.R | 45 ++++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/src/dependencies.R b/src/dependencies.R index 45e9ba1..3d73a23 100644 --- a/src/dependencies.R +++ b/src/dependencies.R @@ -21,25 +21,28 @@ ## required packages available on the CRAN ## https://cran.r-project.org/ ## R> install.packages("") -library(shiny) -library(shinydashboard) -library(shinycssloaders) -library(shinyjs) -library(RSQLite) -library(MASS) -library(digest) -library(plotly) -library(DT) -library(igraph) -library(lubridate) -library(vistime) -library(tidyr) -## required packages NOT available on the CRAN -## R> devtools::install_github("timflutre/rutilstimflutre") -library(rutilstimflutre) -stopifnot(compareVersion( - "0.158.2", - as.character(packageVersion("rutilstimflutre")) -) -!= 1) +suppressPackageStartupMessages({ + library(shiny) + library(shinydashboard) + library(shinycssloaders) + library(shinyjs) + library(RSQLite) + library(MASS) + library(digest) + library(plotly) + library(DT) + library(igraph) + library(lubridate) + library(vistime) + library(tidyr) + + ## required packages NOT available on the CRAN + ## R> devtools::install_github("timflutre/rutilstimflutre") + library(rutilstimflutre) + stopifnot(compareVersion( + "0.158.2", + as.character(packageVersion("rutilstimflutre")) + ) + != 1) +}) From b49f32a67eba299768a4dcadcaa324c401e562db Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Thu, 30 May 2024 14:53:56 +0900 Subject: [PATCH 04/12] prevent setup script to run if `data` folder exists The setup script add only add (or overwrite) new files/data to this folder. So if it already exists the resulting data may contain the previous content of the folder, which do not correspond to a "fresh game session". --- Makefile | 1 - flake.nix | 2 ++ plantbreedgame_setup.Rmd | 5 +++-- tests_UI/test-1.spec.ts | 22 ++++++++++++++++++++++ 4 files changed, 27 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 1848f38..1e6f804 100644 --- a/Makefile +++ b/Makefile @@ -1,3 +1,2 @@ - data: R -e "rmarkdown::render('plantbreedgame_setup.Rmd')" diff --git a/flake.nix b/flake.nix index d29095f..a53e15e 100644 --- a/flake.nix +++ b/flake.nix @@ -102,6 +102,8 @@ initialise-data = pkgs.writeShellApplication { name = "initialise-data"; text = '' + rm -rf data + rm data.zip || echo "no data.zip file" make data ''; }; diff --git a/plantbreedgame_setup.Rmd b/plantbreedgame_setup.Rmd index 6c2db48..1376a94 100644 --- a/plantbreedgame_setup.Rmd +++ b/plantbreedgame_setup.Rmd @@ -93,9 +93,10 @@ Set up directories: ```{r setup_dir} root.dir <- file.path(getwd(), "data") root.dir <- path.expand(root.dir) -if (!dir.exists(root.dir)) { - dir.create(root.dir) +if (dir.exists(root.dir)) { + stop(paste0("`data` directory (", root.dir, ") already exists. Please remove this directory before running this script.")) } +dir.create(root.dir) truth.dir <- file.path(root.dir, "truth") if (!dir.exists(truth.dir)) { dir.create(truth.dir) diff --git a/tests_UI/test-1.spec.ts b/tests_UI/test-1.spec.ts index f77e83d..683ee21 100644 --- a/tests_UI/test-1.spec.ts +++ b/tests_UI/test-1.spec.ts @@ -15,6 +15,10 @@ test.describe("PlantBreedGame_UI", () => { await page.goto(page_root); }); + test("basicLogin", async ({ page }) => { + await login(page, "admin", psw); + }); + test("addBreeder", async ({ page }) => { await login(page, "admin", psw); await addBreeder(page, "test_UI", psw, "tester"); @@ -136,7 +140,25 @@ async function login(page: Page, username: string, password: string) { await page.getByLabel("Password").click(); await page.getByLabel("Password").fill(password); await page.getByRole("button", { name: "Log in" }).click(); + + // top bar visible ? + await expect(page.locator("#breederBoxID")).toBeVisible(); await expect(page.getByRole("heading", { name: username })).toBeVisible(); + await expect(page.locator("#dateBoxID")).toBeVisible(); + await expect(page.locator("#budgetBoxID")).toBeVisible(); + await expect(page.locator("#serverIndicID")).toBeVisible(); + + // content + await expect( + page.getByRole("heading", { name: "Phenotyping data:" }), + ).toBeVisible(); + await expect( + page.getByRole("heading", { name: "Genotyping data:" }), + ).toBeVisible(); + await expect( + page.getByRole("heading", { name: "Plant material data:" }), + ).toBeVisible(); + await expect(page.getByRole("heading", { name: "Other:" })).toBeVisible(); } async function addBreeder( From c616897afd82ab57833cf86fe89e5c889c2704b9 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Mon, 3 Jun 2024 14:32:36 +0900 Subject: [PATCH 05/12] refact: use more meaningfull/smaller global variable instead of `setup` --- global.R | 13 +++++-------- src/fun/func_admin.R | 34 +++++++++++++++++----------------- src/fun/func_eval.R | 20 ++++++++++---------- src/fun/func_geno.R | 20 ++++++++++---------- src/fun/func_pheno.R | 24 ++++++++++++------------ src/fun/func_plant_material.R | 20 ++++++++++---------- src/fun/func_time.R | 2 +- src/fun/functions.R | 8 ++++---- src/server/server_admin.R | 12 ++++++------ src/server/server_eval.R | 12 ++++++------ src/server/server_id.R | 18 +++++++++--------- src/ui/ui_admin_loggedIn.R | 2 +- 12 files changed, 91 insertions(+), 94 deletions(-) diff --git a/global.R b/global.R index 3196ae0..e7a684c 100644 --- a/global.R +++ b/global.R @@ -51,20 +51,17 @@ DATA_INITIAL_DATA <- file.path(DATA_SHARED, "initial_data") DATA_DB <- file.path(DATA_ROOT, "breeding-game.sqlite") -setup <- getBreedingGameSetup(DATA_ROOT) - - subset.snps <- list() -f <- paste0(setup$init.dir, "/snp_coords_hd.txt.gz") +f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") subset.snps[["hd"]] <- rownames(read.table(f)) -f <- paste0(setup$init.dir, "/snp_coords_ld.txt.gz") +f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") subset.snps[["ld"]] <- rownames(read.table(f)) url.repo <- "https://github.com/timflutre/PlantBreedGame" code.version <- getCodeVersion(url.repo) -stopifnot(all(c("admin", "test") %in% getBreederList(setup$dbname))) +stopifnot(all(c("admin", "test") %in% getBreederList(DATA_DB))) stopifnot(all( - "game master" == getBreederStatus(setup$dbname, "admin"), - "tester" == getBreederStatus(setup$dbname, "test") + "game master" == getBreederStatus(DATA_DB, "admin"), + "tester" == getBreederStatus(DATA_DB, "test") )) diff --git a/src/fun/func_admin.R b/src/fun/func_admin.R index 8d2af99..fd21254 100644 --- a/src/fun/func_admin.R +++ b/src/fun/func_admin.R @@ -36,9 +36,9 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { } #### initialisation: - initIndsHaplo <- list.files(setup$truth.dir) + initIndsHaplo <- list.files(DATA_TRUTH) initIndsHaplo <- initIndsHaplo[grep("Coll", initIndsHaplo)] - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) #### test if new breeder already exist @@ -128,8 +128,8 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { detail = "create truth and shared folders" ) } - newTruthDir <- paste0(setup$truth.dir, "/", breederName) - newSharedDir <- paste0(setup$shared.dir, "/", breederName) + newTruthDir <- paste0(DATA_TRUTH, "/", breederName) + newSharedDir <- paste0(DATA_SHARED, "/", breederName) dir.create(newTruthDir) dir.create(newSharedDir) @@ -165,7 +165,7 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { detail = paste0("Create haplo copy:", fileName) ) } - fromFile <- paste0(setup$truth.dir, "/", fileName) + fromFile <- paste0(DATA_TRUTH, "/", fileName) toFile <- paste0(newTruthDir, "/", fileName) file.copy(fromFile, toFile) # copy return() @@ -184,8 +184,8 @@ deleteBreeder <- function(breederName) { } ## delete truth and shared folders - sharedDir <- paste0(setup$shared.dir, "/", breederName) - truthDir <- paste0(setup$truth.dir, "/", breederName) + sharedDir <- paste0(DATA_SHARED, "/", breederName) + truthDir <- paste0(DATA_TRUTH, "/", breederName) unlink(sharedDir, recursive = TRUE) unlink(truthDir, recursive = TRUE) @@ -194,7 +194,7 @@ deleteBreeder <- function(breederName) { ## clean dataBase # delete plant_material_oldBreeder tbl_pltMat <- paste0("plant_material_", breederName) - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) allTbls <- dbListTables(conn = db) if (tbl_pltMat %in% allTbls) { # raise error if table do not exist @@ -234,7 +234,7 @@ calcBV <- function(breeder, inds, savedBV = NULL, progress = NULL) { } # load SNP effects - f <- paste0(setup$truth.dir, "/p0.RData") + f <- paste0(DATA_TRUTH, "/p0.RData") load(f) BV <- t(sapply(inds, function(ind.id) { if (!is.null(progress)) { @@ -245,7 +245,7 @@ calcBV <- function(breeder, inds, savedBV = NULL, progress = NULL) { i <<- i + 1 } indName <- paste0(c(breeder, ind.id), collapse = "_") - f <- paste0(setup$truth.dir, "/", breeder, "/", ind.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", breeder, "/", ind.id, "_haplos.RData") if (!file.exists(f)) { stop(paste0(f, " doesn't exist")) } @@ -282,7 +282,7 @@ calcGameProgress <- function(progBar = NULL) { # load breeding values data: - f <- paste0(setup$truth.dir, "/allBV.RData") + f <- paste0(DATA_TRUTH, "/allBV.RData") if (file.exists(f)) { progBar$set(detail = "Load BV...") load(f) # load `breedValuesDta` variable @@ -290,10 +290,10 @@ calcGameProgress <- function(progBar = NULL) { ### GET BV of the initial individuals: progBar$set(detail = "BV calculation for initial collection...") # load initial collection genotypes - f <- paste0(setup$truth.dir, "/coll.RData") + f <- paste0(DATA_TRUTH, "/coll.RData") load(f) # load `coll` variable # load SNP effects - f <- paste0(setup$truth.dir, "/p0.RData") + f <- paste0(DATA_TRUTH, "/p0.RData") load(f) # load `p0` variable # initialisation of the breeding values data with the initial collection @@ -315,7 +315,7 @@ calcGameProgress <- function(progBar = NULL) { ### GET BV of the breeders's individuals: progBar$set(value = progBar$getValue() + 1, detail = "BV calculation for new individuals...") # get the list of the breeders (without "admin" and "test") - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- "SELECT name FROM breeders WHERE name!='admin' AND name!='test'" breeders <- as.character(dbGetQuery(conn = db, query)$name) dbDisconnect(db) @@ -325,7 +325,7 @@ calcGameProgress <- function(progBar = NULL) { breedValuesDta <- breedValuesDta[breedValuesDta$breeder %in% c(breeders, "Initial collection"), ] ### Get all database tables (to avoid query to missing tables). - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) allTbls <- dbListTables(conn = db) dbDisconnect(db) @@ -344,7 +344,7 @@ calcGameProgress <- function(progBar = NULL) { # get list of individuals tbl_pltMat <- paste0("plant_material_", breeder) if (tbl_pltMat %in% allTbls) { - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM ", tbl_pltMat) allInds <- (dbGetQuery(conn = db, query)) dbDisconnect(db) @@ -383,7 +383,7 @@ calcGameProgress <- function(progBar = NULL) { # save breeding values: progBar$set(value = progBar$getValue() + 1, detail = "Save breeding values...") save(breedValuesDta, - file = paste0(setup$truth.dir, "/allBV.RData") + file = paste0(DATA_TRUTH, "/allBV.RData") ) diff --git a/src/fun/func_eval.R b/src/fun/func_eval.R index 7714df6..28215b7 100644 --- a/src/fun/func_eval.R +++ b/src/fun/func_eval.R @@ -55,20 +55,20 @@ phenotype4Eval <- function(df, nRep = 50) { ## Initialisations data.types <- "evaluation" - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) ## 0. load required data flush.console() - f <- paste0(setup$truth.dir, "/p0.RData") + f <- paste0(DATA_TRUTH, "/p0.RData") load(f) - f <- paste0(setup$truth.dir, "/afs0.RData") + f <- paste0(DATA_TRUTH, "/afs0.RData") load(f) subset.snps <- list() - f <- paste0(setup$init.dir, "/snp_coords_hd.txt.gz") + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") subset.snps[["hd"]] <- rownames(read.table(f)) - f <- paste0(setup$init.dir, "/snp_coords_ld.txt.gz") + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") subset.snps[["ld"]] <- rownames(read.table(f)) @@ -102,9 +102,9 @@ phenotype4Eval <- function(df, nRep = 50) { # message(paste0(i, "/", length(inds.todo), " ", ind.id)) if (breeder == "control") { - f <- paste0(setup$truth.dir, "/", ind.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", ind.id, "_haplos.RData") } else { - f <- paste0(setup$truth.dir, "/", breeder, "/", ind.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", breeder, "/", ind.id, "_haplos.RData") } @@ -206,7 +206,7 @@ getAFs <- function(pop, breeder, progressAFS = NULL) { } # message(paste0(i, "/", length(pop), " ", ind.id)) - f <- paste0(setup$truth.dir, "/", breeder, "/", ind.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", breeder, "/", ind.id, "_haplos.RData") load(f) ind$genos <- segSites2allDoses(seg.sites = ind$haplos, ind.ids = ind.id) @@ -229,7 +229,7 @@ getAFs <- function(pop, breeder, progressAFS = NULL) { #' @export getBreederHistory <- function(breeder, setup) { # get data - db <- RSQLite::dbConnect(SQLite(), dbname = setup$dbname) + db <- RSQLite::dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM log WHERE breeder=\'", breeder, "\'") res <- RSQLite::dbGetQuery(conn = db, query) dbDisconnect(db) @@ -275,7 +275,7 @@ calcAdditiveRelation <- function(breeder, query, setup, progressBar = NULL) { ) } - f <- paste0(setup$truth.dir, "/", breeder, "/", ind.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", breeder, "/", ind.id, "_haplos.RData") if (!file.exists(f)) { stop(paste0(f, " doesn't exist")) } diff --git a/src/fun/func_geno.R b/src/fun/func_geno.R index 4a988fc..1c8358d 100644 --- a/src/fun/func_geno.R +++ b/src/fun/func_geno.R @@ -32,14 +32,14 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName ## Initialisations - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT name FROM breeders") breederList <- (dbGetQuery(conn = db, query)) dbDisconnect(db) stopifnot(breeder %in% breederList$name) data.types <- countRequestedBreedTypes(inds.todo) - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) ## calculate output file names: fout <- list(ld = NULL, hd = NULL, "single-snps" = NULL) @@ -47,28 +47,28 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName if (is.null(fileName) | grepl("[0-9]{4}[-][0-9]{2}[-][0-9]{2}", fileName)) { # fileName must not contain a date fout[dty] <- paste0( - setup$shared.dir, "/", breeder, "/", "Result_genos-", dty, "_", + DATA_SHARED, "/", breeder, "/", "Result_genos-", dty, "_", strftime(gameTime, format = "%Y-%m-%d"), ".txt.gz" ) n <- 0 while (file.exists(fout[[dty]])) { n <- n + 1 fout[dty] <- paste0( - setup$shared.dir, "/", breeder, "/", "Result_genos-", dty, "_", + DATA_SHARED, "/", breeder, "/", "Result_genos-", dty, "_", strftime(gameTime, format = "%Y-%m-%d"), "_", n, ".txt.gz" ) } } else { fileName <- strsplit(fileName, split = "[.]")[[1]][1] # delete extention fout[dty] <- paste0( - setup$shared.dir, "/", breeder, "/", "Result_genos-", dty, "_", fileName, "_", + DATA_SHARED, "/", breeder, "/", "Result_genos-", dty, "_", fileName, "_", strftime(gameTime, format = "%Y-%m-%d"), ".txt.gz" ) n <- 0 while (file.exists(fout[[dty]])) { n <- n + 1 fout[dty] <- paste0( - setup$shared.dir, "/", breeder, "/", "Result_genos-", dty, "_", fileName, "_", + DATA_SHARED, "/", breeder, "/", "Result_genos-", dty, "_", fileName, "_", strftime(gameTime, format = "%Y-%m-%d"), "_", n, ".txt.gz" ) } @@ -78,12 +78,12 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName ## 0. load required data flush.console() - f <- paste0(setup$truth.dir, "/p0.RData") + f <- paste0(DATA_TRUTH, "/p0.RData") load(f) subset.snps <- list() - f <- paste0(setup$init.dir, "/snp_coords_hd.txt.gz") + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") subset.snps[["hd"]] <- rownames(read.table(f)) - f <- paste0(setup$init.dir, "/snp_coords_ld.txt.gz") + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") subset.snps[["ld"]] <- rownames(read.table(f)) @@ -117,7 +117,7 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName ) } - f <- paste0(setup$truth.dir, "/", breeder, "/", ind.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", breeder, "/", ind.id, "_haplos.RData") if (!file.exists(f)) { stop(paste0(f, " doesn't exist")) } diff --git a/src/fun/func_pheno.R b/src/fun/func_pheno.R index 108e015..4ab3cd7 100644 --- a/src/fun/func_pheno.R +++ b/src/fun/func_pheno.R @@ -32,7 +32,7 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa constants <- getBreedingGameConstants() ## Initialisations - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT name FROM breeders") breederList <- (dbGetQuery(conn = db, query)) stopifnot(breeder %in% breederList$name) @@ -45,28 +45,28 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa for (dty in c("pheno-field", "pheno-patho")) { if (is.null(fileName) | grepl("[0-9]{4}[-][0-9]{2}[-][0-9]{2}", fileName)) { # fileName must not contain a date fout[dty] <- paste0( - setup$shared.dir, "/", breeder, "/", "Result_", dty, "_", + DATA_SHARED, "/", breeder, "/", "Result_", dty, "_", strftime(gameTime, format = "%Y-%m-%d"), ".txt.gz" ) n <- 0 while (file.exists(fout[[dty]])) { n <- n + 1 fout[dty] <- paste0( - setup$shared.dir, "/", breeder, "/", "Result_", dty, "_", + DATA_SHARED, "/", breeder, "/", "Result_", dty, "_", strftime(gameTime, format = "%Y-%m-%d"), "_", n, ".txt.gz" ) } } else { fileName <- strsplit(fileName, split = "[.]")[[1]][1] # delete extention fout[dty] <- paste0( - setup$shared.dir, "/", breeder, "/", "Result_", dty, "_", fileName, "_", + DATA_SHARED, "/", breeder, "/", "Result_", dty, "_", fileName, "_", strftime(gameTime, format = "%Y-%m-%d"), ".txt.gz" ) n <- 0 while (file.exists(fout[[dty]])) { n <- n + 1 fout[dty] <- paste0( - setup$shared.dir, "/", breeder, "/", "Result_", dty, "_", fileName, "_", + DATA_SHARED, "/", breeder, "/", "Result_", dty, "_", fileName, "_", strftime(gameTime, format = "%Y-%m-%d"), "_", n, ".txt.gz" ) @@ -93,14 +93,14 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa ## 0. load required data flush.console() - f <- paste0(setup$truth.dir, "/p0.RData") + f <- paste0(DATA_TRUTH, "/p0.RData") load(f) - f <- paste0(setup$truth.dir, "/afs0.RData") + f <- paste0(DATA_TRUTH, "/afs0.RData") load(f) subset.snps <- list() - f <- paste0(setup$init.dir, "/snp_coords_hd.txt.gz") + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") subset.snps[["hd"]] <- rownames(read.table(f)) - f <- paste0(setup$init.dir, "/snp_coords_ld.txt.gz") + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") subset.snps[["ld"]] <- rownames(read.table(f)) ## 1. Calculate year effect @@ -150,7 +150,7 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa # message(paste0(i, "/", nrow(inds.todo), " ", ind.id)) - f <- paste0(setup$truth.dir, "/", breeder, "/", ind.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", breeder, "/", ind.id, "_haplos.RData") if (!file.exists(f)) { stop(paste0(f, " doesn't exist")) } @@ -345,7 +345,7 @@ plotAvailable <- function(breeder, inds.todo, gameTime) { ## Initialisations - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT name FROM breeders") breederList <- (dbGetQuery(conn = db, query)) dbDisconnect(db) @@ -353,7 +353,7 @@ plotAvailable <- function(breeder, inds.todo, gameTime) { ## get the historic of pheno requests - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM log WHERE breeder='", breeder, "' AND task='pheno-field' ") historyPheno <- dbGetQuery(conn = db, query) dbDisconnect(db) diff --git a/src/fun/func_plant_material.R b/src/fun/func_plant_material.R index 3eac105..f22fa7b 100644 --- a/src/fun/func_plant_material.R +++ b/src/fun/func_plant_material.R @@ -31,7 +31,7 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa ## Initialisation - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT name FROM breeders") breederList <- (dbGetQuery(conn = db, query)) dbDisconnect(db) @@ -39,35 +39,35 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa stopifnot(!is.null(crosses.todo)) cross.types <- countRequestedBreedTypes(crosses.todo) - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) year <- data.table::year(gameTime) ## file name if (is.null(fileName)) { fout <- paste0( - setup$shared.dir, "/", breeder, "/", "IndList_", + DATA_SHARED, "/", breeder, "/", "IndList_", strftime(gameTime, format = "%Y-%m-%d"), ".txt" ) n <- 0 while (file.exists(fout)) { n <- n + 1 fout <- paste0( - setup$shared.dir, "/", breeder, "/", "IndList_", + DATA_SHARED, "/", breeder, "/", "IndList_", strftime(gameTime, format = "%Y-%m-%d"), "_", n, ".txt" ) } } else { fileName <- strsplit(fileName, split = "[.]")[[1]][1] # delete extention fout <- paste0( - setup$shared.dir, "/", breeder, "/", "IndList_", fileName, "_", + DATA_SHARED, "/", breeder, "/", "IndList_", fileName, "_", strftime(gameTime, format = "%Y-%m-%d"), ".txt" ) n <- 0 while (file.exists(fout)) { n <- n + 1 fout <- paste0( - setup$shared.dir, "/", breeder, "/", "IndList_", fileName, "_", + DATA_SHARED, "/", breeder, "/", "IndList_", fileName, "_", strftime(gameTime, format = "%Y-%m-%d"), "_", n, ".txt" ) } @@ -94,7 +94,7 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa # initialise parent haplotypes parents <- list(haplos = list()) f <- list.files( - path = setup$truth.dir, + path = DATA_TRUTH, pattern = "*_haplos.RData", full.names = T )[1] @@ -129,7 +129,7 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa if ("ind" %in% ls()) { rm(ind) } - f <- paste0(setup$truth.dir, "/", breeder, "/", parent.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", breeder, "/", parent.id, "_haplos.RData") if (!file.exists(f)) { stop(paste0(f, " doesn't exist")) } @@ -176,7 +176,7 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa } # message(new.ind.id) ind <- list(haplos = getHaplosInd(new.inds$haplos, new.ind.id)) - f <- paste0(setup$truth.dir, "/", breeder, "/", new.ind.id, "_haplos.RData") + f <- paste0(DATA_TRUTH, "/", breeder, "/", new.ind.id, "_haplos.RData") save(ind, file = f) } @@ -289,7 +289,7 @@ indExist <- function(indList, breeder) { # breeder (charracter) breeder name # get requested individuals information - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- paste0("plant_material_", breeder) stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child FROM ", tbl) diff --git a/src/fun/func_time.R b/src/fun/func_time.R index ef28f96..f68e09c 100644 --- a/src/fun/func_time.R +++ b/src/fun/func_time.R @@ -30,7 +30,7 @@ getGameTime <- function(setup) { ## get sessions informations - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- "sessions" stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT * FROM ", tbl) diff --git a/src/fun/functions.R b/src/fun/functions.R index c8457a9..c29c044 100644 --- a/src/fun/functions.R +++ b/src/fun/functions.R @@ -362,7 +362,7 @@ indAvailable <- function(indList, gameTime, breeder) { # breeder (character) breeder name ## 1. check that the requested individuals exist - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- paste0("plant_material_", breeder) stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child FROM ", tbl) @@ -378,7 +378,7 @@ indAvailable <- function(indList, gameTime, breeder) { indSQLlist <- paste0("('", paste(indList, collapse = "','"), "')") ## 3. get requested individuals information - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- paste0("plant_material_", breeder) stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child, avail_from FROM ", tbl, " WHERE child IN ", indSQLlist) @@ -429,11 +429,11 @@ writeRequest <- function(df, breeder, fileName = NULL) { # fileName fileName <- strsplit(fileName, split = "[.]")[[1]][1] # delete extention - fout <- paste0(setup$shared.dir, "/", breeder, "/", "Request-", reqType, "_", fileName, ".txt") + fout <- paste0(DATA_SHARED, "/", breeder, "/", "Request-", reqType, "_", fileName, ".txt") n <- 0 while (file.exists(fout)) { n <- n + 1 - fout <- paste0(setup$shared.dir, "/", breeder, "/", "Request-", reqType, "_", fileName, "_", n, ".txt") + fout <- paste0(DATA_SHARED, "/", breeder, "/", "Request-", reqType, "_", fileName, "_", n, ".txt") } write.table(df, file = fout, sep = "\t", row.names = FALSE, quote = FALSE) diff --git a/src/server/server_admin.R b/src/server/server_admin.R index f1014f5..227c2df 100644 --- a/src/server/server_admin.R +++ b/src/server/server_admin.R @@ -103,7 +103,7 @@ observeEvent(input$deleteBreeder, { ## Sessions managment ---- sessionsList <- eventReactive((input$addSession | input$deleteSession), ignoreNULL = FALSE, { # get session table from the data base: - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM sessions") res <- dbGetQuery(conn = db, query) dbDisconnect(db) @@ -133,7 +133,7 @@ observeEvent(input$addSession, { } # check overlaps - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- "SELECT * FROM sessions" res <- dbGetQuery(conn = db, query) dbDisconnect(db) @@ -166,7 +166,7 @@ observeEvent(input$addSession, { # complete "sessions" table - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0( "INSERT INTO sessions", " VALUES", " ('", numId, "','", startDate, "','", endDate, "','", input$yearTime, "')" @@ -181,7 +181,7 @@ observeEvent(input$addSession, { observeEvent(input$deleteSession, { if (input$delSession != "") { # delete entry in sessions' table - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0( "DELETE FROM sessions", " WHERE num = ", input$delSession @@ -215,7 +215,7 @@ observeEvent(input$admin_button_seedYearEfect, { # update data base checkDB <- 1 if (checkOK) { - db <- DBI::dbConnect(RSQLite::SQLite(), dbname = setup$dbname) + db <- DBI::dbConnect(RSQLite::SQLite(), dbname = DATA_DB) query <- paste0( "UPDATE constants SET value = ", newSeed, " WHERE item=='seed.year.effect'" @@ -345,7 +345,7 @@ observeEvent(input$updateMaxDiskUsage, { # so that if the admin change the value, it will affect all connected users maxDiskUsage <- input$admin_maxDiskUsage - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("UPDATE constants SET value = '", maxDiskUsage, "' WHERE item = 'max.disk.usage'") dbExecute(conn = db, query) dbDisconnect(db) diff --git a/src/server/server_eval.R b/src/server/server_eval.R index f5e193f..3519bcb 100644 --- a/src/server/server_eval.R +++ b/src/server/server_eval.R @@ -50,7 +50,7 @@ readQryEval <- reactive({ df <- evalRawFile() # add controls in the data.frame - df.controls <- read.table(paste0(setup$init.dir, "/controls.txt"), col.names = "ind") + df.controls <- read.table(paste0(DATA_INITIAL_DATA, "/controls.txt"), col.names = "ind") df.controls$breeder <- rep("control", length(df.controls)) df <- rbind(df, df.controls) df <- df[order(df$breeder), ] @@ -239,7 +239,7 @@ evalGraphT1vT2 <- reactive({ dfPheno <- dfPheno[(as.numeric(dfPheno$plot) %% input$nRep) == 1, ] # get the data for the initial collection - f <- paste0(setup$truth.dir, "/", "p0.RData") + f <- paste0(DATA_TRUTH, "/", "p0.RData") load(f) dfInitColl <- data.frame(GAT1 = p0$G.A[, 1], GAT2 = p0$G.A[, 2], ind = names(p0$G.A[, 2])) @@ -327,12 +327,12 @@ afsEval <- reactive({ # get parameters prop <- input$propAFS / 100 breeder <- input$afsBreeder - f <- paste0(setup$truth.dir, "/afs0.RData") + f <- paste0(DATA_TRUTH, "/afs0.RData") load(f) # afs0 # get all individuals - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM plant_material_", breeder) res <- (dbGetQuery(conn = db, query)) dbDisconnect(db) @@ -429,7 +429,7 @@ genealogy <- reactive({ gene <- lapply(breeders, function(b) { # extract all individuals - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM plant_material_", b) allInds <- (dbGetQuery(conn = db, query)) dbDisconnect(db) @@ -708,7 +708,7 @@ output$evalUI_t2penalty <- renderUI({ scoreTable <- eventReactive(input$calcScore, { # get intercepts for T1 and T2 - f <- paste0(setup$truth.dir, "/", "p0.RData") + f <- paste0(DATA_TRUTH, "/", "p0.RData") load(f) dfPheno <- dfPhenoEval() diff --git a/src/server/server_id.R b/src/server/server_id.R index 156c3b7..cb91d5b 100644 --- a/src/server/server_id.R +++ b/src/server/server_id.R @@ -27,7 +27,7 @@ source("src/fun/func_id.R", local = TRUE, encoding = "UTF-8")$value ## get breeder list and create select input ---- breederList <- reactive({ - getBreederList(dbname = setup$dbname) + getBreederList(dbname = DATA_DB) }) output$selectBreeder <- renderUI({ selectInput("breederName", "Breeder", choices = as.list(breederList())) @@ -56,10 +56,10 @@ accessGranted <- eventReactive(input$submitPSW, } # 1. get breeder status - status <- getBreederStatus(setup$dbname, input$breederName) + status <- getBreederStatus(DATA_DB, input$breederName) # 2. check given password - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- "breeders" query <- paste0("SELECT h_psw FROM ", tbl, " WHERE name = '", input$breederName, "'") hashPsw <- dbGetQuery(conn = db, query)[, 1] @@ -109,7 +109,7 @@ accessGranted <- eventReactive(input$submitPSW, # 4. check db (in case of "corrupted" data-base) if (goodPswd) { - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) allTbls <- dbListTables(conn = db) dbDisconnect(db) tbl_pltMat <- paste0("plant_material_", input$breederName) @@ -151,7 +151,7 @@ breeder <- reactive({ breederStatus <- reactive({ if (accessGranted()) { - return(getBreederStatus(setup$dbname, input$breederName)) + return(getBreederStatus(DATA_DB, input$breederName)) } else { return("No Identification") } @@ -370,7 +370,7 @@ output$UIdwnlRequest <- renderUI({ ## My plant-material ---- myPltMat <- reactive({ if (input$leftMenu == "id") { - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- paste0("plant_material_", breeder()) stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT * FROM ", tbl) @@ -400,7 +400,7 @@ output$myPltMatDT <- DT::renderDataTable({ ## Change Password ---- pswChanged <- eventReactive(input$"changePsw", { - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- "breeders" query <- paste0("SELECT h_psw FROM ", tbl, " WHERE name = '", input$breederName, "'") hashPsw <- dbGetQuery(conn = db, query)[, 1] @@ -408,7 +408,7 @@ pswChanged <- eventReactive(input$"changePsw", { if (digest(input$prevPsw, "md5", serialize = FALSE) == hashPsw) { newHashed <- digest(input$newPsw, "md5", serialize = FALSE) - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- "breeders" query <- paste0("UPDATE ", tbl, " SET h_psw = '", newHashed, "' WHERE name = '", breeder(), "'") dbExecute(conn = db, query) @@ -541,7 +541,7 @@ observeEvent(input$id_submitInds, priority = 10, { ind = inds ) - db <- dbConnect(SQLite(), dbname = setup$dbname) + db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0( "INSERT INTO log(breeder,request_date,task,quantity)", " VALUES ('", breeder(), diff --git a/src/ui/ui_admin_loggedIn.R b/src/ui/ui_admin_loggedIn.R index 2591b56..9e4f648 100644 --- a/src/ui/ui_admin_loggedIn.R +++ b/src/ui/ui_admin_loggedIn.R @@ -334,7 +334,7 @@ list( class = "col-sm-12 col-md-12 col-lg-6", selectInput("admin_T1T2Breeder", label = "Breeder", - choices = getBreederList(dbname = setup$dbname) + choices = getBreederList(dbname = DATA_DB) # TODO breeders list can change, this is probably not good, need to check. ), plotlyOutput("admin_T1T2GameProgress") %>% withSpinner() ) From 04b5a226cb435ffbafae1298eb542f9d18212fad Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Mon, 3 Jun 2024 15:02:27 +0900 Subject: [PATCH 06/12] refact: remove `subset.snps` from global variables --- global.R | 7 ------- src/server/server_geno.R | 5 +++++ src/server/server_pheno.R | 6 ++++++ 3 files changed, 11 insertions(+), 7 deletions(-) diff --git a/global.R b/global.R index e7a684c..ce05569 100644 --- a/global.R +++ b/global.R @@ -50,13 +50,6 @@ 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") - -subset.snps <- list() -f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") -subset.snps[["hd"]] <- rownames(read.table(f)) -f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") -subset.snps[["ld"]] <- rownames(read.table(f)) - url.repo <- "https://github.com/timflutre/PlantBreedGame" code.version <- getCodeVersion(url.repo) diff --git a/src/server/server_geno.R b/src/server/server_geno.R index 1d01313..49b27b9 100644 --- a/src/server/server_geno.R +++ b/src/server/server_geno.R @@ -49,6 +49,11 @@ readQryGeno <- reactive({ max.nb.inds <- ifelse(breederStatus() != "player", Inf, getBreedingGameConstants()$max.nb.inds ) + subset.snps <- list() + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") + subset.snps[["hd"]] <- rownames(read.table(f)) + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") + subset.snps[["ld"]] <- rownames(read.table(f)) test <- try(df <- readCheckBreedDataFile(input$file.geno$datapath, subset.snps = subset.snps, max.nb.inds = max.nb.inds diff --git a/src/server/server_pheno.R b/src/server/server_pheno.R index 888e441..e7ef92a 100644 --- a/src/server/server_pheno.R +++ b/src/server/server_pheno.R @@ -47,6 +47,12 @@ readQryPheno <- reactive({ max.nb.plots <- ifelse(breederStatus() != "player", Inf, getBreedingGameConstants()$nb.plots ) + + subset.snps <- list() + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") + subset.snps[["hd"]] <- rownames(read.table(f)) + f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") + subset.snps[["ld"]] <- rownames(read.table(f)) test <- try(df <- readCheckBreedDataFile(input$file.pheno$datapath, subset.snps = subset.snps, max.nb.plots = max.nb.plots From 4736c7bb77689d1151beb0f75c92b696ac92aec5 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Mon, 3 Jun 2024 15:27:04 +0900 Subject: [PATCH 07/12] refact: create a `getSNPsubset` function --- src/fun/func_eval.R | 6 +----- src/fun/func_geno.R | 7 +------ src/fun/func_pheno.R | 6 +----- src/fun/functions.R | 13 +++++++++++++ src/server/server_geno.R | 6 +----- src/server/server_pheno.R | 6 +----- 6 files changed, 18 insertions(+), 26 deletions(-) diff --git a/src/fun/func_eval.R b/src/fun/func_eval.R index 28215b7..5ed96a4 100644 --- a/src/fun/func_eval.R +++ b/src/fun/func_eval.R @@ -65,11 +65,7 @@ phenotype4Eval <- function(df, nRep = 50) { load(f) f <- paste0(DATA_TRUTH, "/afs0.RData") load(f) - subset.snps <- list() - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") - subset.snps[["hd"]] <- rownames(read.table(f)) - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") - subset.snps[["ld"]] <- rownames(read.table(f)) + subset.snps <- getSNPsubset() diff --git a/src/fun/func_geno.R b/src/fun/func_geno.R index 1c8358d..e40e937 100644 --- a/src/fun/func_geno.R +++ b/src/fun/func_geno.R @@ -80,12 +80,7 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName flush.console() f <- paste0(DATA_TRUTH, "/p0.RData") load(f) - subset.snps <- list() - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") - subset.snps[["hd"]] <- rownames(read.table(f)) - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") - subset.snps[["ld"]] <- rownames(read.table(f)) - + subset.snps <- getSNPsubset() ## 2. check that the requested individuals already exist diff --git a/src/fun/func_pheno.R b/src/fun/func_pheno.R index 4ab3cd7..f23b399 100644 --- a/src/fun/func_pheno.R +++ b/src/fun/func_pheno.R @@ -97,11 +97,7 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa load(f) f <- paste0(DATA_TRUTH, "/afs0.RData") load(f) - subset.snps <- list() - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") - subset.snps[["hd"]] <- rownames(read.table(f)) - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") - subset.snps[["ld"]] <- rownames(read.table(f)) + subset.snps <- getSNPsubset() ## 1. Calculate year effect # get the seed from database: diff --git a/src/fun/functions.R b/src/fun/functions.R index c29c044..fa35d5f 100644 --- a/src/fun/functions.R +++ b/src/fun/functions.R @@ -514,3 +514,16 @@ getBreedingGameConstants <- function() { return(out.list) } + +getSNPsubset <- function() { + snpcoord_hd_file <- file.path(DATA_INITIAL_DATA, "snp_coords_hd.txt.gz") + snpcoord_ld_file <- file.path(DATA_INITIAL_DATA, "snp_coords_ld.txt.gz") + + if (!file.exists(snpcoord_hd_file) || !file.exists(snpcoord_ld_file)) { + return(NULL) + } + subset.snps <- list() + subset.snps[["hd"]] <- rownames(read.table(snpcoord_hd_file)) + subset.snps[["ld"]] <- rownames(read.table(snpcoord_ld_file)) + return(subset.snps) +} diff --git a/src/server/server_geno.R b/src/server/server_geno.R index 49b27b9..19f595a 100644 --- a/src/server/server_geno.R +++ b/src/server/server_geno.R @@ -49,11 +49,7 @@ readQryGeno <- reactive({ max.nb.inds <- ifelse(breederStatus() != "player", Inf, getBreedingGameConstants()$max.nb.inds ) - subset.snps <- list() - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") - subset.snps[["hd"]] <- rownames(read.table(f)) - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") - subset.snps[["ld"]] <- rownames(read.table(f)) + subset.snps <- getSNPsubset() test <- try(df <- readCheckBreedDataFile(input$file.geno$datapath, subset.snps = subset.snps, max.nb.inds = max.nb.inds diff --git a/src/server/server_pheno.R b/src/server/server_pheno.R index e7ef92a..0d4f04c 100644 --- a/src/server/server_pheno.R +++ b/src/server/server_pheno.R @@ -48,11 +48,7 @@ readQryPheno <- reactive({ Inf, getBreedingGameConstants()$nb.plots ) - subset.snps <- list() - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_hd.txt.gz") - subset.snps[["hd"]] <- rownames(read.table(f)) - f <- paste0(DATA_INITIAL_DATA, "/snp_coords_ld.txt.gz") - subset.snps[["ld"]] <- rownames(read.table(f)) + subset.snps <- getSNPsubset() test <- try(df <- readCheckBreedDataFile(input$file.pheno$datapath, subset.snps = subset.snps, max.nb.plots = max.nb.plots From 9528e66acbf9956704e58c367a42aa8e54e95af1 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Wed, 5 Jun 2024 10:21:05 +0900 Subject: [PATCH 08/12] fix(breederList): breeders lists automatically updates Now when a breeders are added/deleted, the breeders lists automatically updates to show the correct list. No need to reload the page anymore. The desing used to make that can serve a a base for similar behaviour in the future. --- global.R | 3 ++- server.R | 4 ++++ src/fun/module_breederList.R | 12 ++++++++++++ src/fun/{constants_module.R => module_constants.R} | 0 src/server/server_admin.R | 7 ++++++- src/server/server_id.R | 5 ++--- src/ui/ui_admin_loggedIn.R | 10 ++-------- src/ui/ui_id_logPage.R | 2 +- tests_UI/test-1.spec.ts | 12 +++++++----- 9 files changed, 36 insertions(+), 19 deletions(-) create mode 100644 src/fun/module_breederList.R rename src/fun/{constants_module.R => module_constants.R} (100%) diff --git a/global.R b/global.R index ce05569..d5a2023 100644 --- a/global.R +++ b/global.R @@ -24,7 +24,8 @@ source("src/dependencies.R", local = TRUE, encoding = "UTF-8") source("src/fun/functions.R", local = TRUE, encoding = "UTF-8") source("src/fun/func_time.R", local = TRUE, encoding = "UTF-8") source("src/fun/func_id.R", local = TRUE, encoding = "UTF-8") -source("./src/fun/constants_module.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") ## ------------------------------------------------------------------- ## parameters diff --git a/server.R b/server.R index b5538e7..5ee45ab 100644 --- a/server.R +++ b/server.R @@ -31,6 +31,10 @@ shinyServer(function(input, output, session) { getGameTime(setup) }) + values <- reactiveValues( + lastDBupdate = Sys.time() + ) + source("src/server/server_information.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_id.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_plant_material.R", local = TRUE, encoding = "UTF-8")$value diff --git a/src/fun/module_breederList.R b/src/fun/module_breederList.R new file mode 100644 index 0000000..3ebb1ca --- /dev/null +++ b/src/fun/module_breederList.R @@ -0,0 +1,12 @@ +breeder_list_ui <- function(id) { + ns <- NS(id) + uiOutput(ns("breederList")) +} +breeder_list_server <- function(id, input_id, reactive_breederList) { + moduleServer(id, function(input, output, session) { + output$breederList <- renderUI({ + breederList <- reactive_breederList() + selectInput(input_id, "Breeder", choices = as.list(breederList)) + }) + }) +} diff --git a/src/fun/constants_module.R b/src/fun/module_constants.R similarity index 100% rename from src/fun/constants_module.R rename to src/fun/module_constants.R diff --git a/src/server/server_admin.R b/src/server/server_admin.R index 227c2df..9cf5ce9 100644 --- a/src/server/server_admin.R +++ b/src/server/server_admin.R @@ -67,9 +67,13 @@ observeEvent(input$addNewBreeder, { detail = t ) } + + values$lastDBupdate <- Sys.time() }) # delete breeder: +breeder_list_server("admin_breeder_list_for_deletion", "delBreederName", breederList) + observeEvent(input$deleteBreeder, { if (input$delBreederName != "") { progressDelBreeder <- shiny::Progress$new(session, min = 0, max = 1) @@ -96,6 +100,7 @@ observeEvent(input$deleteBreeder, { ) ) } + values$lastDBupdate <- Sys.time() }) @@ -516,7 +521,7 @@ output$admin_boxPlotGameProgress <- renderPlotly({ - +breeder_list_server("admin_breeder_list_gameProgress", "admin_T1T2Breeder", breederList) output$admin_T1T2GameProgress <- renderPlotly({ dta <- admin_gameProgressDta() diff --git a/src/server/server_id.R b/src/server/server_id.R index cb91d5b..8a4f5e1 100644 --- a/src/server/server_id.R +++ b/src/server/server_id.R @@ -27,11 +27,10 @@ source("src/fun/func_id.R", local = TRUE, encoding = "UTF-8")$value ## get breeder list and create select input ---- breederList <- reactive({ + values$lastDBupdate # add a dependency to the db updates getBreederList(dbname = DATA_DB) }) -output$selectBreeder <- renderUI({ - selectInput("breederName", "Breeder", choices = as.list(breederList())) -}) +breeder_list_server("login_breeder_list", "breederName", breederList) diff --git a/src/ui/ui_admin_loggedIn.R b/src/ui/ui_admin_loggedIn.R index 9e4f648..852fa31 100644 --- a/src/ui/ui_admin_loggedIn.R +++ b/src/ui/ui_admin_loggedIn.R @@ -190,10 +190,7 @@ list( style = "width: 100%; border-collapse: collapse;", tags$td( style = "width: 50%; vertical-align: bottom; padding: 10px;", - selectInput("delBreederName", "Breeder's name", - choices = c("", breederList()), - selected = "", width = "100%" - ) + breeder_list_ui("admin_breeder_list_for_deletion"), ), tags$td( style = "width: 50%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", @@ -332,10 +329,7 @@ list( ), div( class = "col-sm-12 col-md-12 col-lg-6", - selectInput("admin_T1T2Breeder", - label = "Breeder", - choices = getBreederList(dbname = DATA_DB) # TODO breeders list can change, this is probably not good, need to check. - ), + breeder_list_ui("admin_breeder_list_gameProgress"), plotlyOutput("admin_T1T2GameProgress") %>% withSpinner() ) ) # end fluidRow diff --git a/src/ui/ui_id_logPage.R b/src/ui/ui_id_logPage.R index 44a1eb4..a5c772e 100644 --- a/src/ui/ui_id_logPage.R +++ b/src/ui/ui_id_logPage.R @@ -43,7 +43,7 @@ tabItem( br(), div( style = "display: inline-block; vertical-align:top; width: 30%; min-height: 100%;", id = "id_1", - uiOutput("selectBreeder") + breeder_list_ui("login_breeder_list") ), div( style = "display: inline-block; vertical-align:top; min-width: 5%; min-height:: 100%;", id = "id_2", diff --git a/tests_UI/test-1.spec.ts b/tests_UI/test-1.spec.ts index 683ee21..16048d6 100644 --- a/tests_UI/test-1.spec.ts +++ b/tests_UI/test-1.spec.ts @@ -19,6 +19,12 @@ test.describe("PlantBreedGame_UI", () => { await login(page, "admin", psw); }); + test("add and delete breeder", async ({ page }) => { + await login(page, "admin", psw); + await addBreeder(page, "toto", psw, "tester"); + await deleteBreeder(page, "toto"); + }); + test("addBreeder", async ({ page }) => { await login(page, "admin", psw); await addBreeder(page, "test_UI", psw, "tester"); @@ -191,11 +197,7 @@ async function deleteBreeder(page: Page, breederName: string) { page.getByRole("link", { name: "Manage breeders" }), ).toBeVisible(); await page.getByRole("link", { name: "Manage breeders" }).click(); - await page - .locator( - "div:nth-child(2) > table > tbody > tr > td > .form-group > div > .selectize-control > .selectize-input", - ) - .click(); + await page.locator("#delBreederName-selectized").click(); await page.getByRole("option", { name: breederName, exact: true }).click(); await page .getByRole("button", { From 06edc741fca107c0ff044ab4ccb85ec65a1933e1 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Wed, 5 Jun 2024 13:02:58 +0900 Subject: [PATCH 09/12] refact: use unique functions for DB requests This helps to modify the db requests behaviour accross the entire app. - `db_get_request` is for SELECT request - `db_execute_request` is for the orther requests --- global.R | 1 + src/fun/func_admin.R | 46 ++++---------- src/fun/func_dbRequests.R | 113 ++++++++++++++++++++++++++++++++++ src/fun/func_eval.R | 11 +--- src/fun/func_geno.R | 14 ++--- src/fun/func_id.R | 22 ------- src/fun/func_pheno.R | 23 +++---- src/fun/func_plant_material.R | 25 +++----- src/fun/func_time.R | 9 +-- src/fun/functions.R | 100 +----------------------------- src/server/server_admin.R | 24 ++------ src/server/server_eval.R | 8 +-- src/server/server_id.R | 44 ++++--------- tests_UI/test-1.spec.ts | 5 ++ 14 files changed, 178 insertions(+), 267 deletions(-) create mode 100644 src/fun/func_dbRequests.R diff --git a/global.R b/global.R index d5a2023..f006dab 100644 --- a/global.R +++ b/global.R @@ -26,6 +26,7 @@ source("src/fun/func_time.R", local = TRUE, encoding = "UTF-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") ## ------------------------------------------------------------------- ## parameters diff --git a/src/fun/func_admin.R b/src/fun/func_admin.R index fd21254..80120e4 100644 --- a/src/fun/func_admin.R +++ b/src/fun/func_admin.R @@ -38,7 +38,6 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { #### initialisation: initIndsHaplo <- list.files(DATA_TRUTH) initIndsHaplo <- initIndsHaplo[grep("Coll", initIndsHaplo)] - db <- dbConnect(SQLite(), dbname = DATA_DB) #### test if new breeder already exist @@ -49,8 +48,7 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { ) } - tbl <- paste0("plant_material_", breederName) - if (tbl %in% dbListTables(db)) { + if (breederName %in% getBreederList()) { stop("breeder already exist") } @@ -70,7 +68,7 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { "INSERT INTO ", tbl, " VALUES", " ('", breederName, "','", status, "','", hashed.psw, "')" ) - res <- dbExecute(conn = db, query) + db_execute_request(query) @@ -90,7 +88,7 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { ", child TEXT PRIMARY KEY", ", avail_from TEXT)" ) - res <- dbExecute(conn = db, query) + db_execute_request(query) @@ -117,8 +115,7 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) { ), "')" ) - res <- dbExecute(conn = db, query) - dbDisconnect(db) + db_execute_request(query) #### create folders of the new breeder: @@ -194,22 +191,11 @@ deleteBreeder <- function(breederName) { ## clean dataBase # delete plant_material_oldBreeder tbl_pltMat <- paste0("plant_material_", breederName) - db <- dbConnect(SQLite(), dbname = DATA_DB) - allTbls <- dbListTables(conn = db) - if (tbl_pltMat %in% allTbls) { - # raise error if table do not exist - res <- dbExecute(conn = db, paste0("DROP TABLE ", tbl_pltMat)) - } - # delete entry in breeders' table - res <- dbExecute( - conn = db, - paste0( - "DELETE FROM breeders ", - "WHERE name = '", breederName, "'" - ) - ) - # delete entry in log table - dbDisconnect(db) + db_execute_request(paste0("DROP TABLE ", tbl_pltMat)) + db_execute_request(paste0( + "DELETE FROM breeders ", + "WHERE name = '", breederName, "'" + )) # delete entry in Evaluation file: evalDta <- read.table("data/shared/Evaluation.txt", @@ -315,19 +301,15 @@ calcGameProgress <- function(progBar = NULL) { ### GET BV of the breeders's individuals: progBar$set(value = progBar$getValue() + 1, detail = "BV calculation for new individuals...") # get the list of the breeders (without "admin" and "test") - db <- dbConnect(SQLite(), dbname = DATA_DB) - query <- "SELECT name FROM breeders WHERE name!='admin' AND name!='test'" - breeders <- as.character(dbGetQuery(conn = db, query)$name) - dbDisconnect(db) + breeders <- getBreederList() + breeders <- breeders[breeders != "admin" & breeders != "test"] ### Remove deleted breeders from breedValuesDta breedValuesDta <- breedValuesDta[breedValuesDta$breeder %in% c(breeders, "Initial collection"), ] ### Get all database tables (to avoid query to missing tables). - db <- dbConnect(SQLite(), dbname = DATA_DB) - allTbls <- dbListTables(conn = db) - dbDisconnect(db) + allTbls <- db_list_tables() ### calculation # get list of all individuals with generation and BV @@ -344,10 +326,8 @@ calcGameProgress <- function(progBar = NULL) { # get list of individuals tbl_pltMat <- paste0("plant_material_", breeder) if (tbl_pltMat %in% allTbls) { - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM ", tbl_pltMat) - allInds <- (dbGetQuery(conn = db, query)) - dbDisconnect(db) + allInds <- db_get_request(query) } else { return() } diff --git a/src/fun/func_dbRequests.R b/src/fun/func_dbRequests.R new file mode 100644 index 0000000..4aa6e0f --- /dev/null +++ b/src/fun/func_dbRequests.R @@ -0,0 +1,113 @@ +## Copyright 2015~2024 Institut National de la Recherche Agronomique +## and Montpellier SupAgro. +## +## This file is part of PlantBreedGame. +## +## PlantBreedGame is free software: you can redistribute it and/or modify +## it under the terms of the GNU Affero General Public License as +## published by the Free Software Foundation, either version 3 of the +## License, or (at your option) any later version. +## +## PlantBreedGame is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU Affero General Public +## License along with PlantBreedGame. If not, see +## . + +## Functions related to data file / data-base requests + +db_get_request <- function(query, dbname = DATA_DB) { + # for SELECT query only + conn <- dbConnect(SQLite(), dbname = dbname) + tryCatch({ + out <- dbGetQuery(conn = conn, query) + }, finally = { + dbDisconnect(conn) + }) + return(out) +} + +db_execute_request <- function(query, dbname = DATA_DB) { + conn <- dbConnect(SQLite(), dbname = dbname) + tryCatch({ + dbExecute(conn = conn, query) + }, finally = { + dbDisconnect(conn) + }) + return(TRUE) +} + +db_list_tables <- function(dbname = DATA_DB) { + conn <- dbConnect(SQLite(), dbname = dbname) + tryCatch({ + allTbls <- dbListTables(conn = conn) + }, finally = { + dbDisconnect(conn) + }) + return(allTbls) +} + +getBreederList <- function(dbname) { + query <- paste0("SELECT name FROM breeders") + breederNames <- db_get_request(query)[, 1] + return(breederNames) +} + +getBreederStatus <- function(dbname, breeder.name) { + query <- paste0( + "SELECT status FROM breeders WHERE name = '", breeder.name, "'" + ) + breeder.status <- db_get_request(query)[, 1] + return(breeder.status) +} + + + +##' Get the breeding game constants +##' +##' Retrieve the constants used to parametrized the breeding game from the SQLite database. +##' @return list +##' @author Timothee Flutre +getBreedingGameConstants <- function() { + ## retrieve the content of the table + query <- "SELECT * FROM constants" + out.df <- db_get_request(query) + + ## reformat + # suppress "NAs introduced by coercion" warning + withCallingHandlers( + { + out.list <- lapply(out.df$value, function(x) { + ifelse(!is.na(as.numeric(x)), + as.numeric(x), + x + ) + }) + }, + warning = function(warn) { + warning_to_catch <- "NAs introduced by coercion" + if (identical(warn$message, warning_to_catch)) { + tryInvokeRestart("muffleWarning") + } + } + ) + names(out.list) <- out.df$item + + return(out.list) +} + +getSNPsubset <- function() { + snpcoord_hd_file <- file.path(DATA_INITIAL_DATA, "snp_coords_hd.txt.gz") + snpcoord_ld_file <- file.path(DATA_INITIAL_DATA, "snp_coords_ld.txt.gz") + + if (!file.exists(snpcoord_hd_file) || !file.exists(snpcoord_ld_file)) { + return(NULL) + } + subset.snps <- list() + subset.snps[["hd"]] <- rownames(read.table(snpcoord_hd_file)) + subset.snps[["ld"]] <- rownames(read.table(snpcoord_ld_file)) + return(subset.snps) +} diff --git a/src/fun/func_eval.R b/src/fun/func_eval.R index 5ed96a4..d6c74e1 100644 --- a/src/fun/func_eval.R +++ b/src/fun/func_eval.R @@ -55,7 +55,6 @@ phenotype4Eval <- function(df, nRep = 50) { ## Initialisations data.types <- "evaluation" - db <- dbConnect(SQLite(), dbname = DATA_DB) @@ -74,9 +73,8 @@ phenotype4Eval <- function(df, nRep = 50) { for (breeder in unique(df$breeder)) { if (breeder != "control") { tbl <- paste0("plant_material_", breeder) - stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child FROM ", tbl) - res <- dbGetQuery(conn = db, query) + res <- db_get_request(query) stopifnot(all(df$ind[df$breeder == breeder] %in% res$child)) } } @@ -172,8 +170,7 @@ phenotype4Eval <- function(df, nRep = 50) { "', '", "evaluation", "', '", "1", "')" ) - res <- dbExecute(db, query) - dbDisconnect(db) + db_execute_request(query) # output return(phenosField.df) @@ -225,10 +222,8 @@ getAFs <- function(pop, breeder, progressAFS = NULL) { #' @export getBreederHistory <- function(breeder, setup) { # get data - db <- RSQLite::dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM log WHERE breeder=\'", breeder, "\'") - res <- RSQLite::dbGetQuery(conn = db, query) - dbDisconnect(db) + res <- db_get_request(query) # manage variable class res$task <- as.factor(res$task) diff --git a/src/fun/func_geno.R b/src/fun/func_geno.R index e40e937..673c026 100644 --- a/src/fun/func_geno.R +++ b/src/fun/func_geno.R @@ -32,14 +32,10 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName ## Initialisations - db <- dbConnect(SQLite(), dbname = DATA_DB) - query <- paste0("SELECT name FROM breeders") - breederList <- (dbGetQuery(conn = db, query)) - dbDisconnect(db) - stopifnot(breeder %in% breederList$name) + breederList <- getBreederList() + stopifnot(breeder %in% breederList) data.types <- countRequestedBreedTypes(inds.todo) - db <- dbConnect(SQLite(), dbname = DATA_DB) ## calculate output file names: fout <- list(ld = NULL, hd = NULL, "single-snps" = NULL) @@ -86,9 +82,8 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName ## 2. check that the requested individuals already exist flush.console() tbl <- paste0("plant_material_", breeder) - stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child FROM ", tbl) - res <- dbGetQuery(conn = db, query) + res <- db_get_request(query) stopifnot(all(inds.todo$ind %in% res$child)) @@ -204,10 +199,9 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName "', '", type, "', '", data.types[type], "')" ) - res <- dbGetQuery(db, query) + res <- db_get_request(query) } } - dbDisconnect(db) diff --git a/src/fun/func_id.R b/src/fun/func_id.R index d25c303..2dcf89b 100644 --- a/src/fun/func_id.R +++ b/src/fun/func_id.R @@ -19,28 +19,6 @@ ## functions for the "id part" - -getBreederList <- function(dbname) { - db <- dbConnect(SQLite(), dbname = dbname) - tbl <- "breeders" - query <- paste0("SELECT name FROM ", tbl) - breederNames <- dbGetQuery(conn = db, query)[, 1] - dbDisconnect(db) - return(breederNames) -} - -getBreederStatus <- function(dbname, breeder.name) { - db <- dbConnect(SQLite(), dbname = dbname) - tbl <- "breeders" - query <- paste0( - "SELECT status FROM ", tbl, - " WHERE name = '", breeder.name, "'" - ) - breeder.status <- dbGetQuery(conn = db, query)[, 1] - dbDisconnect(db) - return(breeder.status) -} - getDataFileList <- function(type, breeder) { # function to get the list of data file of the breeder # type (char) type of data (pheno or geno) diff --git a/src/fun/func_pheno.R b/src/fun/func_pheno.R index f23b399..6fd171f 100644 --- a/src/fun/func_pheno.R +++ b/src/fun/func_pheno.R @@ -32,10 +32,8 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa constants <- getBreedingGameConstants() ## Initialisations - db <- dbConnect(SQLite(), dbname = DATA_DB) - query <- paste0("SELECT name FROM breeders") - breederList <- (dbGetQuery(conn = db, query)) - stopifnot(breeder %in% breederList$name) + breederList <- getBreederList() + stopifnot(breeder %in% breederList) data.types <- countRequestedBreedTypes(inds.todo) @@ -119,9 +117,8 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa ## 2. check that the requested individuals already exist flush.console() tbl <- paste0("plant_material_", breeder) - stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child FROM ", tbl) - res <- dbGetQuery(conn = db, query) + res <- db_get_request(query) stopifnot(all(inds.todo$ind %in% res$child)) @@ -276,10 +273,9 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa "', '", type, "', '", data.types[type], "')" ) - res <- dbGetQuery(db, query) + res <- db_get_request(query) } } - dbDisconnect(db) # output @@ -341,18 +337,13 @@ plotAvailable <- function(breeder, inds.todo, gameTime) { ## Initialisations - db <- dbConnect(SQLite(), dbname = DATA_DB) - query <- paste0("SELECT name FROM breeders") - breederList <- (dbGetQuery(conn = db, query)) - dbDisconnect(db) - stopifnot(breeder %in% breederList$name) + breederList <- getBreederList() + stopifnot(breeder %in% breederList) ## get the historic of pheno requests - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM log WHERE breeder='", breeder, "' AND task='pheno-field' ") - historyPheno <- dbGetQuery(conn = db, query) - dbDisconnect(db) + historyPheno <- db_get_request(query) ## get game constants constants <- getBreedingGameConstants() diff --git a/src/fun/func_plant_material.R b/src/fun/func_plant_material.R index f22fa7b..32ac113 100644 --- a/src/fun/func_plant_material.R +++ b/src/fun/func_plant_material.R @@ -31,15 +31,11 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa ## Initialisation - db <- dbConnect(SQLite(), dbname = DATA_DB) - query <- paste0("SELECT name FROM breeders") - breederList <- (dbGetQuery(conn = db, query)) - dbDisconnect(db) - stopifnot(breeder %in% breederList$name) + breederList <- getBreederList() + stopifnot(breeder %in% breederList) stopifnot(!is.null(crosses.todo)) cross.types <- countRequestedBreedTypes(crosses.todo) - db <- dbConnect(SQLite(), dbname = DATA_DB) year <- data.table::year(gameTime) @@ -81,9 +77,9 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa parent.ids <- parent.ids[!is.na(parent.ids)] child.ids <- crosses.todo$child tbl <- paste0("plant_material_", breeder) - stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child FROM ", tbl) - res <- dbGetQuery(conn = db, query) + res <- db_get_request(query) + stopifnot(all(parent.ids %in% res$child)) stopifnot(all(!child.ids %in% res$child)) @@ -184,7 +180,6 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa ## insert the requested crosses into their table flush.console() - nrow(res <- dbGetQuery(db, paste0("SELECT * FROM ", tbl))) constants <- getBreedingGameConstants() getAvailDate <- function(type) { @@ -208,7 +203,7 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa sep = "','", collapse = "'),('" ) query <- paste0("INSERT INTO ", tbl, " (parent1, parent2, child, avail_from) VALUES ('", query, "')") - res <- dbGetQuery(conn = db, query) + db_execute_request(query) ## write table write.table( @@ -228,10 +223,9 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa "', '", type, "', '", cross.types[type], "')" ) - res <- dbGetQuery(db, query) + db_execute_request(query) } } - dbDisconnect(db) @@ -284,17 +278,14 @@ createInvoicePltmat <- function(request.df) { indExist <- function(indList, breeder) { - # function to check if an individuals already exist + # function to check if any individuals n indList already exist in the DB # indList (character verctor), list of individuals to check # breeder (charracter) breeder name # get requested individuals information - db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- paste0("plant_material_", breeder) - stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child FROM ", tbl) - res <- dbGetQuery(conn = db, query) - dbDisconnect(db) + res <- db_get_request(query) return(any(indList %in% res$child)) } diff --git a/src/fun/func_time.R b/src/fun/func_time.R index f68e09c..e52a27e 100644 --- a/src/fun/func_time.R +++ b/src/fun/func_time.R @@ -30,13 +30,8 @@ getGameTime <- function(setup) { ## get sessions informations - db <- dbConnect(SQLite(), dbname = DATA_DB) - tbl <- "sessions" - stopifnot(tbl %in% dbListTables(db)) - query <- paste0("SELECT * FROM ", tbl) - res <- dbGetQuery(conn = db, query) - # disconnect db - dbDisconnect(db) + query <- paste0("SELECT * FROM sessions") + res <- db_get_request(query) res$start <- strptime(res$start, format = "%Y-%m-%d %H:%M") res$end <- strptime(res$end, format = "%Y-%m-%d %H:%M") diff --git a/src/fun/functions.R b/src/fun/functions.R index fa35d5f..5fc0e90 100644 --- a/src/fun/functions.R +++ b/src/fun/functions.R @@ -362,12 +362,10 @@ indAvailable <- function(indList, gameTime, breeder) { # breeder (character) breeder name ## 1. check that the requested individuals exist - db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- paste0("plant_material_", breeder) - stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child FROM ", tbl) - res <- dbGetQuery(conn = db, query) - dbDisconnect(db) + res <- db_get_request(query) + if (!all(indList %in% res$child)) { indExist <- FALSE } else { @@ -378,12 +376,9 @@ indAvailable <- function(indList, gameTime, breeder) { indSQLlist <- paste0("('", paste(indList, collapse = "','"), "')") ## 3. get requested individuals information - db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- paste0("plant_material_", breeder) - stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT child, avail_from FROM ", tbl, " WHERE child IN ", indSQLlist) - res <- dbGetQuery(conn = db, query) - dbDisconnect(db) + res <- db_get_request(query) # compare dates funApply <- function(x) { @@ -438,92 +433,3 @@ writeRequest <- function(df, breeder, fileName = NULL) { write.table(df, file = fout, sep = "\t", row.names = FALSE, quote = FALSE) } - - - -##' Get the breeding game setup -##' -##' Retrieve the paths to the directories used for the breeding game. -##' @param root.dir path to the root directory -##' @return list -##' @author Timothee Flutre -getBreedingGameSetup <- function(root.dir) { - stopifnot( - is.character(root.dir), - length(root.dir) == 1, - dir.exists(root.dir) - ) - - out <- list(root.dir = root.dir) - - out$truth.dir <- paste0(root.dir, "/truth") - out$shared.dir <- paste0(root.dir, "/shared") - out$init.dir <- paste0(out$shared.dir, "/initial_data") - tmp <- basename(Sys.glob(paste0(out$shared.dir, "/*"))) - for (x in tmp) { - if (x != "initial_data") { - out$breeders <- c(out$breeders, x) - } - } - - out$breeder.dirs <- c() - for (breeder in out$breeders) { - out$breeder.dirs[[breeder]] <- - paste0(out$shared.dir, "/", breeder) - } - - out$dbname <- paste0(root.dir, "/breeding-game.sqlite") - - return(out) -} - - -##' Get the breeding game constants -##' -##' Retrieve the constants used to parametrized the breeding game from the SQLite database. -##' @return list -##' @author Timothee Flutre -getBreedingGameConstants <- function() { - stopifnot(file.exists(DATA_DB)) - - ## retrieve the content of the table - db <- DBI::dbConnect(RSQLite::SQLite(), dbname = DATA_DB) - query <- "SELECT * FROM constants" - out.df <- DBI::dbGetQuery(db, query) - DBI::dbDisconnect(db) - - ## reformat - # suppress "NAs introduced by coercion" warning - withCallingHandlers( - { - out.list <- lapply(out.df$value, function(x) { - ifelse(!is.na(as.numeric(x)), - as.numeric(x), - x - ) - }) - }, - warning = function(warn) { - warning_to_catch <- "NAs introduced by coercion" - if (identical(warn$message, warning_to_catch)) { - tryInvokeRestart("muffleWarning") - } - } - ) - names(out.list) <- out.df$item - - return(out.list) -} - -getSNPsubset <- function() { - snpcoord_hd_file <- file.path(DATA_INITIAL_DATA, "snp_coords_hd.txt.gz") - snpcoord_ld_file <- file.path(DATA_INITIAL_DATA, "snp_coords_ld.txt.gz") - - if (!file.exists(snpcoord_hd_file) || !file.exists(snpcoord_ld_file)) { - return(NULL) - } - subset.snps <- list() - subset.snps[["hd"]] <- rownames(read.table(snpcoord_hd_file)) - subset.snps[["ld"]] <- rownames(read.table(snpcoord_ld_file)) - return(subset.snps) -} diff --git a/src/server/server_admin.R b/src/server/server_admin.R index 9cf5ce9..00267d8 100644 --- a/src/server/server_admin.R +++ b/src/server/server_admin.R @@ -108,10 +108,8 @@ observeEvent(input$deleteBreeder, { ## Sessions managment ---- sessionsList <- eventReactive((input$addSession | input$deleteSession), ignoreNULL = FALSE, { # get session table from the data base: - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM sessions") - res <- dbGetQuery(conn = db, query) - dbDisconnect(db) + res <- db_get_request(query) return(res) }) @@ -138,10 +136,8 @@ observeEvent(input$addSession, { } # check overlaps - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- "SELECT * FROM sessions" - res <- dbGetQuery(conn = db, query) - dbDisconnect(db) + res <- db_get_request(query) if (nrow(res) > 0) { overlapse <- apply(res, 1, function(session) { @@ -171,13 +167,11 @@ observeEvent(input$addSession, { # complete "sessions" table - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0( "INSERT INTO sessions", " VALUES", " ('", numId, "','", startDate, "','", endDate, "','", input$yearTime, "')" ) - res <- dbExecute(conn = db, query) - dbDisconnect(db) + db_execute_request(query) showNotification("Session added.", type = c("message")) } }) @@ -186,13 +180,11 @@ observeEvent(input$addSession, { observeEvent(input$deleteSession, { if (input$delSession != "") { # delete entry in sessions' table - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0( "DELETE FROM sessions", " WHERE num = ", input$delSession ) - res <- dbExecute(conn = db, query) - dbDisconnect(db) + db_execute_request(query) showNotification("Session removed", type = "message") } }) @@ -220,13 +212,11 @@ observeEvent(input$admin_button_seedYearEfect, { # update data base checkDB <- 1 if (checkOK) { - db <- DBI::dbConnect(RSQLite::SQLite(), dbname = DATA_DB) query <- paste0( "UPDATE constants SET value = ", newSeed, " WHERE item=='seed.year.effect'" ) - checkDB <- DBI::dbExecute(db, query) - DBI::dbDisconnect(db) + db_execute_request(query) } # notification messages @@ -350,10 +340,8 @@ observeEvent(input$updateMaxDiskUsage, { # so that if the admin change the value, it will affect all connected users maxDiskUsage <- input$admin_maxDiskUsage - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("UPDATE constants SET value = '", maxDiskUsage, "' WHERE item = 'max.disk.usage'") - dbExecute(conn = db, query) - dbDisconnect(db) + db_execute_request(query) }) currentMaxDiskUsage <- reactive({ diff --git a/src/server/server_eval.R b/src/server/server_eval.R index 3519bcb..e4e509d 100644 --- a/src/server/server_eval.R +++ b/src/server/server_eval.R @@ -332,10 +332,8 @@ afsEval <- reactive({ # get all individuals - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM plant_material_", breeder) - res <- (dbGetQuery(conn = db, query)) - dbDisconnect(db) + res <- db_get_request(query) # select sample sampleSize <- round(nrow(res) * prop) @@ -429,10 +427,8 @@ genealogy <- reactive({ gene <- lapply(breeders, function(b) { # extract all individuals - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0("SELECT * FROM plant_material_", b) - allInds <- (dbGetQuery(conn = db, query)) - dbDisconnect(db) + allInds <- db_get_request(query) # get submitted individuals inds <- readQryEval()$ind[readQryEval()$breeder == b] diff --git a/src/server/server_id.R b/src/server/server_id.R index 8a4f5e1..4281ac3 100644 --- a/src/server/server_id.R +++ b/src/server/server_id.R @@ -58,11 +58,8 @@ accessGranted <- eventReactive(input$submitPSW, status <- getBreederStatus(DATA_DB, input$breederName) # 2. check given password - db <- dbConnect(SQLite(), dbname = DATA_DB) - tbl <- "breeders" - query <- paste0("SELECT h_psw FROM ", tbl, " WHERE name = '", input$breederName, "'") - hashPsw <- dbGetQuery(conn = db, query)[, 1] - dbDisconnect(db) + query <- paste0("SELECT h_psw FROM breeders WHERE name = '", input$breederName, "'") + hashPsw <- db_get_request(query) if (hashPsw == digest(input$psw, "md5", serialize = FALSE)) { goodPswd <- TRUE @@ -108,9 +105,7 @@ accessGranted <- eventReactive(input$submitPSW, # 4. check db (in case of "corrupted" data-base) if (goodPswd) { - db <- dbConnect(SQLite(), dbname = DATA_DB) - allTbls <- dbListTables(conn = db) - dbDisconnect(db) + allTbls <- db_list_tables() tbl_pltMat <- paste0("plant_material_", input$breederName) if (!tbl_pltMat %in% allTbls) { alert(paste( @@ -161,11 +156,8 @@ budget <- reactive({ input$requestGeno input$id_submitInds if (breeder() != "No Identification") { - db <- dbConnect(SQLite(), dbname = DATA_DB) - tbl <- "log" - query <- paste0("SELECT * FROM ", tbl, " WHERE breeder='", breeder(), "'") - res <- dbGetQuery(conn = db, query) - dbDisconnect(db) + query <- paste0("SELECT * FROM log WHERE breeder='", breeder(), "'") + res <- db_get_request(query) constants <- getBreedingGameConstants() @@ -369,13 +361,9 @@ output$UIdwnlRequest <- renderUI({ ## My plant-material ---- myPltMat <- reactive({ if (input$leftMenu == "id") { - db <- dbConnect(SQLite(), dbname = DATA_DB) tbl <- paste0("plant_material_", breeder()) - stopifnot(tbl %in% dbListTables(db)) query <- paste0("SELECT * FROM ", tbl) - res <- dbGetQuery(conn = db, query) - # disconnect db - dbDisconnect(db) + res <- db_get_request(query) res$avail_from <- strftime(res$avail_from, format = "%Y-%m-%d") res } @@ -399,20 +387,13 @@ output$myPltMatDT <- DT::renderDataTable({ ## Change Password ---- pswChanged <- eventReactive(input$"changePsw", { - db <- dbConnect(SQLite(), dbname = DATA_DB) - tbl <- "breeders" - query <- paste0("SELECT h_psw FROM ", tbl, " WHERE name = '", input$breederName, "'") - hashPsw <- dbGetQuery(conn = db, query)[, 1] - dbDisconnect(db) + query <- paste0("SELECT h_psw FROM breeders WHERE name = '", input$breederName, "'") + hashPsw <- db_get_request(query)[, 1] if (digest(input$prevPsw, "md5", serialize = FALSE) == hashPsw) { newHashed <- digest(input$newPsw, "md5", serialize = FALSE) - db <- dbConnect(SQLite(), dbname = DATA_DB) - tbl <- "breeders" - query <- paste0("UPDATE ", tbl, " SET h_psw = '", newHashed, "' WHERE name = '", breeder(), "'") - dbExecute(conn = db, query) - dbDisconnect(db) - + query <- paste0("UPDATE breeders SET h_psw = '", newHashed, "' WHERE name = '", breeder(), "'") + db_execute_request(query) return(TRUE) } else { return(FALSE) @@ -539,8 +520,6 @@ observeEvent(input$id_submitInds, priority = 10, { breeder = breeder(), ind = inds ) - - db <- dbConnect(SQLite(), dbname = DATA_DB) query <- paste0( "INSERT INTO log(breeder,request_date,task,quantity)", " VALUES ('", breeder(), @@ -548,8 +527,7 @@ observeEvent(input$id_submitInds, priority = 10, { "', 'register', '", nrow(submitDta), "')" ) - res <- dbGetQuery(db, query) - dbDisconnect(db) + res <- db_execute_request(query) b <- budget() write.table(submitDta, diff --git a/tests_UI/test-1.spec.ts b/tests_UI/test-1.spec.ts index 16048d6..c9de98b 100644 --- a/tests_UI/test-1.spec.ts +++ b/tests_UI/test-1.spec.ts @@ -82,6 +82,9 @@ test.describe("PlantBreedGame_UI", () => { await runEvaluation(page, registered_inds); }); + // TODO: add a test for "Admin / GameProgress" the core function is partially checked + // with the evaluation check (when we build the game report) but a + test("delete breeder", async ({ page }) => { await login(page, "admin", psw); await deleteBreeder(page, "test_UI"); @@ -189,6 +192,8 @@ async function addBreeder( await page.getByRole("button", { name: "Add this new breeder" }).click(); await expect(page.getByText("Adding breeder Done!")).toBeVisible(); + + // TODO: check we cannot add already existing breeders (low priority) } async function deleteBreeder(page: Page, breederName: string) { From b6e5faae7528567766f4cb360f2c9183961f09d0 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Wed, 5 Jun 2024 18:59:07 +0900 Subject: [PATCH 10/12] fix: user icon To avoid the error: The `name` provided ('user-o') does not correspond to a known icon --- src/server/server_geno.R | 2 +- src/server/server_id.R | 2 +- src/server/server_pheno.R | 2 +- src/server/server_plant_material.R | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/server/server_geno.R b/src/server/server_geno.R index 19f595a..0dcc651 100644 --- a/src/server/server_geno.R +++ b/src/server/server_geno.R @@ -187,7 +187,7 @@ output$breederBoxGeno <- renderValueBox({ valueBox( value = breeder(), subtitle = paste("Status:", breederStatus()), - icon = icon("user-o"), + icon = icon("user"), color = "yellow" ) }) diff --git a/src/server/server_id.R b/src/server/server_id.R index 4281ac3..d80a17b 100644 --- a/src/server/server_id.R +++ b/src/server/server_id.R @@ -415,7 +415,7 @@ output$breederBoxID <- renderValueBox({ valueBox( value = breeder(), subtitle = paste("Status:", breederStatus()), - icon = icon("user-o"), + icon = icon("user"), color = "yellow" ) }) diff --git a/src/server/server_pheno.R b/src/server/server_pheno.R index 0d4f04c..8070af9 100644 --- a/src/server/server_pheno.R +++ b/src/server/server_pheno.R @@ -178,7 +178,7 @@ output$breederBoxPheno <- renderValueBox({ valueBox( value = breeder(), subtitle = paste("Status:", breederStatus()), - icon = icon("user-o"), + icon = icon("user"), color = "yellow" ) }) diff --git a/src/server/server_plant_material.R b/src/server/server_plant_material.R index 482743d..5b635cd 100644 --- a/src/server/server_plant_material.R +++ b/src/server/server_plant_material.R @@ -195,7 +195,7 @@ output$breederBoxPltMat <- renderValueBox({ valueBox( value = breeder(), subtitle = paste("Status:", breederStatus()), - icon = icon("user-o"), + icon = icon("user"), color = "yellow" ) }) From 26895834d885a660e0bc95717519be07b8485f31 Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Wed, 5 Jun 2024 19:00:16 +0900 Subject: [PATCH 11/12] feat: let the game load without being initialised For that some refactoring had to be done, mainly about the UI loading of the menus that cannot be used if the game is not initialised. --- global.R | 6 - server.R | 34 ++++++ src/fun/func_dbRequests.R | 12 +- src/fun/func_eval.R | 6 +- src/fun/func_geno.R | 9 +- src/fun/func_pheno.R | 8 +- src/fun/func_plant_material.R | 18 ++- src/fun/functions.R | 10 +- src/server/server_admin.R | 2 +- src/server/server_eval.R | 14 ++- src/server/server_geno.R | 6 + src/server/server_id.R | 24 ++-- src/server/server_pheno.R | 6 + src/server/server_plant_material.R | 7 ++ src/ui/ui_admin.R | 28 ----- src/ui/ui_eval.R | 27 ----- src/ui/ui_gameNotInitialised.R | 10 ++ src/ui/ui_geno.R | 140 ++++++++++------------ src/ui/ui_id_askForLogin.R | 29 +++++ src/ui/ui_id_logPage.R | 70 ----------- src/ui/ui_id_loggedIn.R | 184 ++++++++++++++--------------- src/ui/ui_pheno.R | 137 ++++++++++----------- src/ui/ui_plant_material.R | 138 ++++++++++------------ tests_UI/test-1.spec.ts | 28 ++--- ui.R | 109 +++++++++++++---- 25 files changed, 523 insertions(+), 539 deletions(-) delete mode 100644 src/ui/ui_admin.R delete mode 100644 src/ui/ui_eval.R create mode 100644 src/ui/ui_gameNotInitialised.R create mode 100644 src/ui/ui_id_askForLogin.R delete mode 100644 src/ui/ui_id_logPage.R diff --git a/global.R b/global.R index f006dab..4ab8767 100644 --- a/global.R +++ b/global.R @@ -54,9 +54,3 @@ DATA_DB <- file.path(DATA_ROOT, "breeding-game.sqlite") url.repo <- "https://github.com/timflutre/PlantBreedGame" code.version <- getCodeVersion(url.repo) - -stopifnot(all(c("admin", "test") %in% getBreederList(DATA_DB))) -stopifnot(all( - "game master" == getBreederStatus(DATA_DB, "admin"), - "tester" == getBreederStatus(DATA_DB, "test") -)) diff --git a/server.R b/server.R index 5ee45ab..5b8664f 100644 --- a/server.R +++ b/server.R @@ -35,6 +35,40 @@ shinyServer(function(input, output, session) { lastDBupdate = Sys.time() ) + gameInitialised <- function() { + (dir.exists(DATA_ROOT) & + dir.exists(DATA_TRUTH) & + dir.exists(DATA_SHARED) & + dir.exists(DATA_INITIAL_DATA) & + file.exists(DATA_DB)) + } + + observe({ + if (!gameInitialised()) { + alert("Game is not initialised :-(") + + # insertUI("#id_main_ui", where = "beforeBegin", { + # source("src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value + # }) + # removeUI("#id_main_ui") + + # insertUI("#pltmat_main_ui", where = "beforeBegin", { + # source("src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value + # }) + # removeUI("#pltmat_main_ui") + + # insertUI("#pheno_main_ui", where = "beforeBegin", { + # source("src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value + # }) + # removeUI("#pheno_main_ui") + + # insertUI("#geno_main_ui", where = "beforeBegin", { + # source("src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value + # }) + # removeUI("#geno_main_ui") + } + }) + source("src/server/server_information.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_id.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_plant_material.R", local = TRUE, encoding = "UTF-8")$value diff --git a/src/fun/func_dbRequests.R b/src/fun/func_dbRequests.R index 4aa6e0f..a0e292f 100644 --- a/src/fun/func_dbRequests.R +++ b/src/fun/func_dbRequests.R @@ -50,13 +50,13 @@ db_list_tables <- function(dbname = DATA_DB) { return(allTbls) } -getBreederList <- function(dbname) { +getBreederList <- function(dbname = DATA_DB) { query <- paste0("SELECT name FROM breeders") breederNames <- db_get_request(query)[, 1] return(breederNames) } -getBreederStatus <- function(dbname, breeder.name) { +getBreederStatus <- function(breeder.name, dbname = DATA_DB) { query <- paste0( "SELECT status FROM breeders WHERE name = '", breeder.name, "'" ) @@ -111,3 +111,11 @@ getSNPsubset <- function() { subset.snps[["ld"]] <- rownames(read.table(snpcoord_ld_file)) return(subset.snps) } + +getBreedersIndividuals <- function(breeder) { + # return a data-frame of all the breeder's individuals + + tbl <- paste0("plant_material_", breeder) + query <- paste0("SELECT * FROM ", tbl) + return(db_get_request(query)) +} diff --git a/src/fun/func_eval.R b/src/fun/func_eval.R index d6c74e1..5bcf075 100644 --- a/src/fun/func_eval.R +++ b/src/fun/func_eval.R @@ -72,10 +72,8 @@ phenotype4Eval <- function(df, nRep = 50) { flush.console() for (breeder in unique(df$breeder)) { if (breeder != "control") { - tbl <- paste0("plant_material_", breeder) - query <- paste0("SELECT child FROM ", tbl) - res <- db_get_request(query) - stopifnot(all(df$ind[df$breeder == breeder] %in% res$child)) + all_breeder_inds <- getBreedersIndividuals(breeder) + stopifnot(all(df$ind[df$breeder == breeder] %in% all_breeder_inds$child)) } } diff --git a/src/fun/func_geno.R b/src/fun/func_geno.R index 673c026..85533e9 100644 --- a/src/fun/func_geno.R +++ b/src/fun/func_geno.R @@ -81,10 +81,8 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName ## 2. check that the requested individuals already exist flush.console() - tbl <- paste0("plant_material_", breeder) - query <- paste0("SELECT child FROM ", tbl) - res <- db_get_request(query) - stopifnot(all(inds.todo$ind %in% res$child)) + all_breeder_inds <- getBreedersIndividuals(breeder) + stopifnot(all(inds.todo$ind %in% all_breeder_inds$child)) @@ -98,7 +96,6 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName for (i in 1:length(unique(inds.todo$ind))) { ind.id <- unique(inds.todo$ind)[i] - # message(paste0(i, "/", nrow(inds.todo), " ", ind.id)) if (!is.null(progressGeno)) { progressGeno$set( @@ -199,7 +196,7 @@ genotype <- function(breeder, inds.todo, gameTime, progressGeno = NULL, fileName "', '", type, "', '", data.types[type], "')" ) - res <- db_get_request(query) + res <- db_execute_request(query) } } diff --git a/src/fun/func_pheno.R b/src/fun/func_pheno.R index 6fd171f..7882266 100644 --- a/src/fun/func_pheno.R +++ b/src/fun/func_pheno.R @@ -116,10 +116,8 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa ## 2. check that the requested individuals already exist flush.console() - tbl <- paste0("plant_material_", breeder) - query <- paste0("SELECT child FROM ", tbl) - res <- db_get_request(query) - stopifnot(all(inds.todo$ind %in% res$child)) + all_breeder_inds <- getBreedersIndividuals(breeder) + stopifnot(all(inds.todo$ind %in% all_breeder_inds$child)) ## 3. load the haplotypes and convert to genotypes @@ -273,7 +271,7 @@ phenotype <- function(breeder, inds.todo, gameTime, progressPheno = NULL, fileNa "', '", type, "', '", data.types[type], "')" ) - res <- db_get_request(query) + res <- db_execute_request(query) } } diff --git a/src/fun/func_plant_material.R b/src/fun/func_plant_material.R index 32ac113..6f62423 100644 --- a/src/fun/func_plant_material.R +++ b/src/fun/func_plant_material.R @@ -76,12 +76,11 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa parent.ids <- unique(c(crosses.todo$parent1, crosses.todo$parent2)) parent.ids <- parent.ids[!is.na(parent.ids)] child.ids <- crosses.todo$child - tbl <- paste0("plant_material_", breeder) - query <- paste0("SELECT child FROM ", tbl) - res <- db_get_request(query) - stopifnot(all(parent.ids %in% res$child)) - stopifnot(all(!child.ids %in% res$child)) + all_breeder_inds <- getBreedersIndividuals(breeder) + + stopifnot(all(parent.ids %in% all_breeder_inds$child)) + stopifnot(all(!child.ids %in% all_breeder_inds$child)) ## load the haplotypes of all parents @@ -202,6 +201,7 @@ create_plant_material <- function(breeder, crosses.todo, gameTime, progressPltMa (crosses.todo$availableDate), sep = "','", collapse = "'),('" ) + tbl <- paste0("plant_material_", breeder) query <- paste0("INSERT INTO ", tbl, " (parent1, parent2, child, avail_from) VALUES ('", query, "')") db_execute_request(query) @@ -278,14 +278,12 @@ createInvoicePltmat <- function(request.df) { indExist <- function(indList, breeder) { - # function to check if any individuals n indList already exist in the DB + # function to check if any individuals in indList already exist in the DB # indList (character verctor), list of individuals to check # breeder (charracter) breeder name # get requested individuals information - tbl <- paste0("plant_material_", breeder) - query <- paste0("SELECT child FROM ", tbl) - res <- db_get_request(query) + all_breeder_inds <- getBreedersIndividuals(breeder) - return(any(indList %in% res$child)) + return(any(indList %in% all_breeder_inds$child)) } diff --git a/src/fun/functions.R b/src/fun/functions.R index 5fc0e90..7e93cf4 100644 --- a/src/fun/functions.R +++ b/src/fun/functions.R @@ -362,15 +362,9 @@ indAvailable <- function(indList, gameTime, breeder) { # breeder (character) breeder name ## 1. check that the requested individuals exist - tbl <- paste0("plant_material_", breeder) - query <- paste0("SELECT child FROM ", tbl) - res <- db_get_request(query) + all_breeder_inds <- getBreedersIndividuals(breeder) - if (!all(indList %in% res$child)) { - indExist <- FALSE - } else { - indExist <- TRUE - } + indExist <- all(indList %in% all_breeder_inds$child) ## 2. check available date indSQLlist <- paste0("('", paste(indList, collapse = "','"), "')") diff --git a/src/server/server_admin.R b/src/server/server_admin.R index 00267d8..7a83b25 100644 --- a/src/server/server_admin.R +++ b/src/server/server_admin.R @@ -26,7 +26,7 @@ source("src/fun/func_admin.R", local = TRUE, encoding = "UTF-8")$value ## Main UI: ---- output$adminUI <- renderUI({ - if (breederStatus() == "game master") { + if (breederStatus() == "game master" | !gameInitialised()) { source("src/ui/ui_admin_loggedIn.R", local = TRUE, encoding = "UTF-8")$value } else { shinydashboard::box( diff --git a/src/server/server_eval.R b/src/server/server_eval.R index e4e509d..bac254c 100644 --- a/src/server/server_eval.R +++ b/src/server/server_eval.R @@ -27,14 +27,22 @@ source("src/fun/func_eval.R", local = TRUE, encoding = "UTF-8")$value ## Main UI ---- output$evalUI <- renderUI({ + if (!gameInitialised()) { + return( + source("src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value + ) + } + if (breeder() != "No Identification" & breederStatus() != "player") { - source("src/ui/ui_eval_loggedIn.R", local = TRUE, encoding = "UTF-8")$value - } else { + return(source("src/ui/ui_eval_loggedIn.R", local = TRUE, encoding = "UTF-8")$value) + } + + return( shinydashboard::box( width = 12, title = "Content unavailable", div(p("Sorry, you need the 'game-master' status or the 'tester' status to access this.")) ) - } + ) }) diff --git a/src/server/server_geno.R b/src/server/server_geno.R index 0dcc651..729565b 100644 --- a/src/server/server_geno.R +++ b/src/server/server_geno.R @@ -24,6 +24,12 @@ source("src/fun/func_geno.R", local = TRUE, encoding = "UTF-8")$value ###### server for "genotyping" ###### +output$geno_main_UI <- renderUI({ + if (!gameInitialised()) { + return(source("./src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value) + } + return(source("./src/ui/ui_geno.R", local = TRUE, encoding = "UTF-8")$value) +}) ## identification message output$idMessageGeno <- renderUI({ diff --git a/src/server/server_id.R b/src/server/server_id.R index d80a17b..f90b70d 100644 --- a/src/server/server_id.R +++ b/src/server/server_id.R @@ -24,6 +24,17 @@ source("src/fun/func_id.R", local = TRUE, encoding = "UTF-8")$value +## Call ui_id_loggedIn.R ---- +output$id_main_UI <- renderUI({ + if (!gameInitialised()) { + return(source("./src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value) + } + if (accessGranted()) { + return(source("./src/ui/ui_id_loggedIn.R", local = TRUE, encoding = "UTF-8")$value) + } + return(source("./src/ui/ui_id_askForLogin.R", local = TRUE, encoding = "UTF-8")$value) +}) + ## get breeder list and create select input ---- breederList <- reactive({ @@ -50,12 +61,15 @@ accessGranted <- eventReactive(input$submitPSW, # but the javascript "alert" will explain that the server is full. # * A "tester" is the only status allowed to have an empty password. + if (is.null(input$submitPSW)) { # button not yet available + return(FALSE) + } if (input$submitPSW == 0) { # button not pressed return(FALSE) } # 1. get breeder status - status <- getBreederStatus(DATA_DB, input$breederName) + status <- getBreederStatus(input$breederName) # 2. check given password query <- paste0("SELECT h_psw FROM breeders WHERE name = '", input$breederName, "'") @@ -145,7 +159,7 @@ breeder <- reactive({ breederStatus <- reactive({ if (accessGranted()) { - return(getBreederStatus(DATA_DB, input$breederName)) + return(getBreederStatus(input$breederName)) } else { return("No Identification") } @@ -189,12 +203,6 @@ budget <- reactive({ -## Call ui_id_loggedIn.R ---- -output$userAction <- renderUI({ - if (accessGranted()) { - source("src/ui/ui_id_loggedIn.R", local = TRUE, encoding = "UTF-8")$value - } -}) diff --git a/src/server/server_pheno.R b/src/server/server_pheno.R index 8070af9..cfcf0dc 100644 --- a/src/server/server_pheno.R +++ b/src/server/server_pheno.R @@ -23,6 +23,12 @@ source("src/fun/func_pheno.R", local = TRUE, encoding = "UTF-8")$value ## server for "phenotyping" +output$pheno_main_UI <- renderUI({ + if (!gameInitialised()) { + return(source("./src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value) + } + return(source("./src/ui/ui_pheno.R", local = TRUE, encoding = "UTF-8")$value) +}) ## identification message output$idMessagePheno <- renderUI({ diff --git a/src/server/server_plant_material.R b/src/server/server_plant_material.R index 5b635cd..ced6ff2 100644 --- a/src/server/server_plant_material.R +++ b/src/server/server_plant_material.R @@ -25,6 +25,13 @@ source("src/fun/func_plant_material.R", local = TRUE, encoding = "UTF-8")$value ## server for "plant material" +output$pltmat_main_UI <- renderUI({ + if (!gameInitialised()) { + return(source("./src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value) + } + return(source("./src/ui/ui_plant_material.R", local = TRUE, encoding = "UTF-8")$value) +}) + ## identification message output$idMessagePltMat <- renderUI({ if (breeder() == "No Identification") { diff --git a/src/ui/ui_admin.R b/src/ui/ui_admin.R deleted file mode 100644 index 5f0cddc..0000000 --- a/src/ui/ui_admin.R +++ /dev/null @@ -1,28 +0,0 @@ -## Copyright 2015,2016,2017,2018,2019 Institut National de la Recherche Agronomique -## and Montpellier SupAgro. -## -## This file is part of PlantBreedGame. -## -## PlantBreedGame is free software: you can redistribute it and/or modify -## it under the terms of the GNU Affero General Public License as -## published by the Free Software Foundation, either version 3 of the -## License, or (at your option) any later version. -## -## PlantBreedGame is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. -## -## You should have received a copy of the GNU Affero General Public -## License along with PlantBreedGame. If not, see -## . - - -## UI for game's administration - -tabItem( - tabName = "admin", - fluidRow( - uiOutput("adminUI") - ) # close fluidRow -) # close tabItem diff --git a/src/ui/ui_eval.R b/src/ui/ui_eval.R deleted file mode 100644 index 5ef3992..0000000 --- a/src/ui/ui_eval.R +++ /dev/null @@ -1,27 +0,0 @@ -## Copyright 2015,2016,2017,2018,2019 Institut National de la Recherche Agronomique -## and Montpellier SupAgro. -## -## This file is part of PlantBreedGame. -## -## PlantBreedGame is free software: you can redistribute it and/or modify -## it under the terms of the GNU Affero General Public License as -## published by the Free Software Foundation, either version 3 of the -## License, or (at your option) any later version. -## -## PlantBreedGame is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. -## -## You should have received a copy of the GNU Affero General Public -## License along with PlantBreedGame. If not, see -## . - - -## UI for "evaluation" part -tabItem( - tabName = "eval", - fluidRow( - uiOutput("evalUI") - ) # close fluidRow -) # close tabItem diff --git a/src/ui/ui_gameNotInitialised.R b/src/ui/ui_gameNotInitialised.R new file mode 100644 index 0000000..6135ba4 --- /dev/null +++ b/src/ui/ui_gameNotInitialised.R @@ -0,0 +1,10 @@ +shinydashboard::box( + width = 12, title = "Game not initialised", status = "danger", solidHeader = TRUE, + div( + p("The game have not been initialised. It is therefore currently impossible to play."), + p( + 'To initialise the game, go to the "Admin" menu and in the "Game setup" tab.', + "From there you will be able to initialise a new game." + ) + ) +) diff --git a/src/ui/ui_geno.R b/src/ui/ui_geno.R index 58e3de1..46e3249 100644 --- a/src/ui/ui_geno.R +++ b/src/ui/ui_geno.R @@ -19,32 +19,24 @@ # UI of "geno" part - - -tabItem( - tabName = "geno", - fluidRow( - useShinyjs(), - tags$script("Shiny.addCustomMessageHandler( - 'resetValue',function(variableName){ - Shiny.onInputChange(variableName, null);});"), - uiOutput("UIbreederInfoGeno"), - shinydashboard::box( - width = 12, title = "Request genotyping", - div( - id = "geno_info1", - p("In this module you, can request genotyping data."), - p("A laboratory can be used", strong("all year long"), " to perform genotyping. Two SNP chips are available:"), - tags$ul( - tags$li(strong("High-density"), ": ", constants_ui("geno_nb.snps.hd"), " SNP, ", constants_ui("geno_duration.geno.hd"), "-month delay and costs", constants_ui("geno_cost.geno.hd"), " plot (", constants_ui("geno_cost.geno.hd.mendels"), " Mendels )."), - tags$li(strong("Low-density"), ": ", constants_ui("geno_nb.snps.ld"), " SNP, ", constants_ui("geno_duration.geno.ld"), "-month delay and costs", constants_ui("geno_cost.geno.ld"), " plot (", constants_ui("geno_cost.geno.ld.mendels"), " Mendels ).") - ), - p(strong("Single-SNP"), "genotyping can also be performed: ", constants_ui("geno_duration.geno.single"), "-month delay and costs", constants_ui("geno_cost.geno.single"), " plot (", constants_ui("geno_cost.geno.single.mendels"), " Mendels ).") +div( + uiOutput("UIbreederInfoGeno"), + shinydashboard::box( + width = 12, title = "Request genotyping", + div( + id = "geno_info1", + p("In this module you, can request genotyping data."), + p("A laboratory can be used", strong("all year long"), " to perform genotyping. Two SNP chips are available:"), + tags$ul( + tags$li(strong("High-density"), ": ", constants_ui("geno_nb.snps.hd"), " SNP, ", constants_ui("geno_duration.geno.hd"), "-month delay and costs", constants_ui("geno_cost.geno.hd"), " plot (", constants_ui("geno_cost.geno.hd.mendels"), " Mendels )."), + tags$li(strong("Low-density"), ": ", constants_ui("geno_nb.snps.ld"), " SNP, ", constants_ui("geno_duration.geno.ld"), "-month delay and costs", constants_ui("geno_cost.geno.ld"), " plot (", constants_ui("geno_cost.geno.ld.mendels"), " Mendels ).") ), - div( - id = "geno_info2", - p("The request file for this module should be similar to the following example:"), - tags$pre(HTML(" + p(strong("Single-SNP"), "genotyping can also be performed: ", constants_ui("geno_duration.geno.single"), "-month delay and costs", constants_ui("geno_cost.geno.single"), " plot (", constants_ui("geno_cost.geno.single.mendels"), " Mendels ).") + ), + div( + id = "geno_info2", + p("The request file for this module should be similar to the following example:"), + tags$pre(HTML("
@@ -66,62 +58,52 @@ tabItem(
ind\t task\tsnp01877\t
")), - p(tags$ul( - tags$li("The file should be in", code(".txt"), "format with", strong("tabulations"), "separator and ", strong(code("UTF-8"), "encoding.")), - tags$li("All columns (", code("ind"), ", ", code("task"), " and ", code("details"), ") are compulsory."), - tags$li("The ", code("task"), " column should contain 'geno'"), - tags$li("The ", code("details"), " column should contain 'hd' (for a high-density chip), 'ld' (for a low-density chip) or the SNP identifier (for single SNP genotyping)."), - tags$li("Individuals should be available."), - tags$li("Individuals should not be duplicated within each task."), - tags$li("Lines starting with ", code("#"), " will be ignored.") - )) + p(tags$ul( + tags$li("The file should be in", code(".txt"), "format with", strong("tabulations"), "separator and ", strong(code("UTF-8"), "encoding.")), + tags$li("All columns (", code("ind"), ", ", code("task"), " and ", code("details"), ") are compulsory."), + tags$li("The ", code("task"), " column should contain 'geno'"), + tags$li("The ", code("details"), " column should contain 'hd' (for a high-density chip), 'ld' (for a low-density chip) or the SNP identifier (for single SNP genotyping)."), + tags$li("Individuals should be available."), + tags$li("Individuals should not be duplicated within each task."), + tags$li("Lines starting with ", code("#"), " will be ignored.") + )) + ) + ), + shinydashboard::box( + width = 12, title = "Choose an instruction file for genotyping:", + div( + id = "geno_file", + uiOutput("idMessageGeno"), + fileInput( + inputId = "file.geno", + label = NULL, + multiple = FALSE, + accept = c(".txt", ".tsv") ) - ), - shinydashboard::box( - width = 12, title = "Choose an instruction file for genotyping:", + ) + ), + shinydashboard::tabBox( + width = 12, title = "Info", id = "geno_tabset", side = "right", selected = "Check", + tabPanel( + "Request", div( - id = "geno_file", - uiOutput("idMessageGeno"), - fileInput( - inputId = "file.geno", - label = NULL, - multiple = FALSE, - accept = c(".txt", ".tsv") - ) - ) - ), - shinydashboard::tabBox( - width = 12, title = "Info", id = "geno_tabset", side = "right", selected = "Check", - tabPanel( - "Request", - div( - uiOutput("submitGenoRequest") - ), - div( - uiOutput("genoRequestResultUI") - ) + uiOutput("submitGenoRequest") ), - tabPanel( - "Data", - dataTableOutput(outputId = "qryGeno") - ), - tabPanel( - "Summary", - tableOutput("GenoInvoice") - ), - # verbatimTextOutput("GenoSmy"), - # verbatimTextOutput("GenoStr")), - - tabPanel( - "Check", - verbatimTextOutput("GenoUploaded") + div( + uiOutput("genoRequestResultUI") ) ), - if (debugDisplay) { - shinydashboard::box( - width = 12, title = "Debug", - verbatimTextOutput("GenoDebug") - ) - } - ) # close fluidRow -) # close tabItem + tabPanel( + "Data", + dataTableOutput(outputId = "qryGeno") + ), + tabPanel( + "Summary", + tableOutput("GenoInvoice") + ), + tabPanel( + "Check", + verbatimTextOutput("GenoUploaded") + ) + ) +) diff --git a/src/ui/ui_id_askForLogin.R b/src/ui/ui_id_askForLogin.R new file mode 100644 index 0000000..87c5ac4 --- /dev/null +++ b/src/ui/ui_id_askForLogin.R @@ -0,0 +1,29 @@ +shinydashboard::box( + width = 12, title = NULL, + div( + style = "vertical-align: top; margin-top:10px; min-width: 20%;", id = "id_5", + p("Depending on your status, you are granted with different permissions:"), + tags$ul( + tags$li(strong("game-master (such as breeder 'admin'):"), "has the highest privileges. Has access to the \"Admin\" and \"Evaluation\" tabs. Data files available without any time restriction."), + tags$li(strong("tester (such as breeder 'test'):"), "used to test the game without needing a password. Has access to the \"Evaluation\" tab. Data files available without any time restriction."), + tags$li(strong("player:"), "used when playing in a common session. Has access neither to the \"Admin\" nor \"Evaluation\" tabs. Data files available under time restriction.") + ) + ), + br(), + div( + style = "display: inline-block; vertical-align:top; width: 30%; min-height: 100%;", id = "id_1", + breeder_list_ui("login_breeder_list") + ), + div( + style = "display: inline-block; vertical-align:top; min-width: 5%; min-height:: 100%;", id = "id_2", + br() + ), + div( + style = "display: inline-block; vertical-align:top; width: 30%; min-height:: 100%;", id = "id_3", + passwordInput("psw", "Password") + ), + div( + style = "vertical-align: top; min-width: 20%;", id = "id_4", + actionButton("submitPSW", "Log in", style = "background-color:#00A65A; color: white") + ) +) diff --git a/src/ui/ui_id_logPage.R b/src/ui/ui_id_logPage.R deleted file mode 100644 index a5c772e..0000000 --- a/src/ui/ui_id_logPage.R +++ /dev/null @@ -1,70 +0,0 @@ -## Copyright 2015,2016,2017,2018,2019 Institut National de la Recherche Agronomique -## and Montpellier SupAgro. -## -## This file is part of PlantBreedGame. -## -## PlantBreedGame is free software: you can redistribute it and/or modify -## it under the terms of the GNU Affero General Public License as -## published by the Free Software Foundation, either version 3 of the -## License, or (at your option) any later version. -## -## PlantBreedGame is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. -## -## You should have received a copy of the GNU Affero General Public -## License along with PlantBreedGame. If not, see -## . - - - -# UI of "identification" part - - -# UI -tabItem( - tabName = "id", - fluidRow( - uiOutput("UIbreederInfoID"), - div( - id = "logInDiv", - shinydashboard::box( - width = 12, title = NULL, - div( - style = "vertical-align: top; margin-top:10px; min-width: 20%;", id = "id_5", - p("Depending on your status, you are granted with different permissions:"), - tags$ul( - tags$li(strong("game-master (such as breeder 'admin'):"), "has the highest privileges. Has access to the \"Admin\" and \"Evaluation\" tabs. Data files available without any time restriction."), - tags$li(strong("tester (such as breeder 'test'):"), "used to test the game without needing a password. Has access to the \"Evaluation\" tab. Data files available without any time restriction."), - tags$li(strong("player:"), "used when playing in a common session. Has access neither to the \"Admin\" nor \"Evaluation\" tabs. Data files available under time restriction.") - ) - ), - br(), - div( - style = "display: inline-block; vertical-align:top; width: 30%; min-height: 100%;", id = "id_1", - breeder_list_ui("login_breeder_list") - ), - div( - style = "display: inline-block; vertical-align:top; min-width: 5%; min-height:: 100%;", id = "id_2", - br() - ), - div( - style = "display: inline-block; vertical-align:top; width: 30%; min-height:: 100%;", id = "id_3", - passwordInput("psw", "Password") - ), - div( - style = "vertical-align: top; min-width: 20%;", id = "id_4", - actionButton("submitPSW", "Log in", style = "background-color:#00A65A; color: white") - ) - ) - ), - uiOutput("userAction"), - if (debugDisplay) { - shinydashboard::box( - width = 12, title = "Debug", - verbatimTextOutput("IdDebug") - ) - } - ) # close fluidRow -) # close tabItem diff --git a/src/ui/ui_id_loggedIn.R b/src/ui/ui_id_loggedIn.R index 0c6f85f..fbdf4c9 100644 --- a/src/ui/ui_id_loggedIn.R +++ b/src/ui/ui_id_loggedIn.R @@ -22,111 +22,111 @@ ## This file contain the UI code for logged user for the id tab ## this file is sourced in "server_id.R" in a renderUI() function ############################ - - - -shinydashboard::tabBox( - width = 12, title = paste0("My account"), - tabPanel( - "My files", - div( - style = "display: inline-block; vertical-align:top; width: 50%;", +div( + uiOutput("UIbreederInfoID"), + shinydashboard::tabBox( + width = 12, title = paste0("My account"), + tabPanel( + "My files", div( - h3("Phenotyping data:"), - selectInput("phenoFile", "", choices = phenoFiles(), width = "75%"), - uiOutput("UIdwnlPheno") + style = "display: inline-block; vertical-align:top; width: 50%;", + div( + h3("Phenotyping data:"), + selectInput("phenoFile", "", choices = phenoFiles(), width = "75%"), + uiOutput("UIdwnlPheno") + ), + div( + h3("Genotyping data:"), + selectInput("genoFile", "", choices = genoFiles(), width = "75%"), + uiOutput("UIdwnlGeno") + ) ), div( - h3("Genotyping data:"), - selectInput("genoFile", "", choices = genoFiles(), width = "75%"), - uiOutput("UIdwnlGeno") + style = "display: inline-block; vertical-align:top; width: 49%;", + div( + h3("Plant material data:"), + selectInput("pltMatFile", "", choices = pltMatFiles(), width = "75%"), + uiOutput("UIdwnlPltMat") + ), + div( + h3("Other:"), + p( + "You can download here:", + tags$ul( + tags$li("SNP coordinates of the HD and LD chips"), + tags$li("List of controls"), + tags$li("Examples of requests files"), + tags$li("List of your requests") + ) + ), + selectInput("requestFile", "", choices = requestFiles(), width = "75%"), + uiOutput("UIdwnlRequest") + ) ) ), - div( - style = "display: inline-block; vertical-align:top; width: 49%;", + tabPanel( + "My plant material", + dataTableOutput("myPltMatDT") + ), + tabPanel( + "Change my password", div( - h3("Plant material data:"), - selectInput("pltMatFile", "", choices = pltMatFiles(), width = "75%"), - uiOutput("UIdwnlPltMat") + style = "display: inline-block; vertical-align:top; width: 30%; min-height: 100%;", + passwordInput("prevPsw", "Previous Password") ), div( - h3("Other:"), - p( - "You can download here:", - tags$ul( - tags$li("SNP coordinates of the HD and LD chips"), - tags$li("List of controls"), - tags$li("Examples of requests files"), - tags$li("List of your requests") - ) - ), - selectInput("requestFile", "", choices = requestFiles(), width = "75%"), - uiOutput("UIdwnlRequest") - ) - ) - ), - tabPanel( - "My plant material", - dataTableOutput("myPltMatDT") - ), - tabPanel( - "Change my password", - div( - style = "display: inline-block; vertical-align:top; width: 30%; min-height: 100%;", - passwordInput("prevPsw", "Previous Password") - ), - div( - style = "display: inline-block; vertical-align:top; min-width: 5%; min-height:: 100%;", - p() - ), - div( - style = "display: inline-block; vertical-align:top; width: 30%; min-height:: 100%;", - passwordInput("newPsw", "New Password") - ), - div( - style = "display: inline-block; vertical-align: top; min-width: 100%;", - tags$head( - tags$style(HTML("#changePsw{background-color:gray; color: white}")) + style = "display: inline-block; vertical-align:top; min-width: 5%; min-height:: 100%;", + p() ), - actionButton("changePsw", "Change my password!") - ), - div( - style = "vertical-align: top; min-width: 20%;", id = "id_4", - uiOutput("UIpswChanged") - ) - ), - tabPanel( - "Register final individuals", - div( - style = "display: inline-block; vertical-align:top; width: 40%;", div( - h3("Individuals submission:"), - p("You can specify here the individuals you want to submit for the final evaluation."), - p( - "A maximum of ", - strong(constants_ui("home_maxEvalInds"), "individuals"), - "can be registered." - ), - p("The registration fee is ", strong(constants_ui("home_cost.register.mendels"), "Mendels"), "per genotype. No refund are possible, thank-you for your understanding.") + style = "display: inline-block; vertical-align:top; width: 30%; min-height:: 100%;", + passwordInput("newPsw", "New Password") ), div( - selectInput("id_evalInds", - HTML("Select your best individuals*:"), - choices = myPltMat()$child, - multiple = TRUE + style = "display: inline-block; vertical-align: top; min-width: 100%;", + tags$head( + tags$style(HTML("#changePsw{background-color:gray; color: white}")) ), - actionButton("id_submitInds", "Submit"), - p(tags$sup("*"), "The drop-down menu is limited to 1000 propositions. Write the name of your individuals to find them.") - ) - ), - div( - style = "display: inline-block; vertical-align:top; width: 50%;", + actionButton("changePsw", "Change my password!") + ), div( - h4("Your submitted individuals:"), - dataTableOutput("submittedIndsDT"), - p("Click on the individuals to delete them."), - actionButton("id_delSubmitInds", "Delete") + style = "vertical-align: top; min-width: 20%;", id = "id_4", + uiOutput("UIpswChanged") ) ), - ) -) # end shinydashboard::tabBox + tabPanel( + "Register final individuals", + div( + style = "display: inline-block; vertical-align:top; width: 40%;", + div( + h3("Individuals submission:"), + p("You can specify here the individuals you want to submit for the final evaluation."), + p( + "A maximum of ", + strong(constants_ui("home_maxEvalInds"), "individuals"), + "can be registered." + ), + p("The registration fee is ", strong(constants_ui("home_cost.register.mendels"), "Mendels"), "per genotype. No refund are possible, thank-you for your understanding.") + ), + div( + selectInput("id_evalInds", + HTML("Select your best individuals*:"), + choices = myPltMat()$child, + multiple = TRUE + ), + actionButton("id_submitInds", "Submit"), + p(tags$sup("*"), "The drop-down menu is limited to 1000 propositions. Write the name of your individuals to find them.") + ) + ), + div( + style = "display: inline-block; vertical-align:top; width: 50%;", + div( + h4("Your submitted individuals:"), + dataTableOutput("submittedIndsDT"), + p("Click on the individuals to delete them."), + actionButton("id_delSubmitInds", "Delete") + ) + ), + ) + ) # end shinydashboard::tabBox +) diff --git a/src/ui/ui_pheno.R b/src/ui/ui_pheno.R index fd7c55f..7488da3 100644 --- a/src/ui/ui_pheno.R +++ b/src/ui/ui_pheno.R @@ -20,31 +20,25 @@ # UI of "pheno" part -tabItem( - tabName = "pheno", - fluidRow( - useShinyjs(), - uiOutput("UIbreederInfoPheno"), - tags$script("Shiny.addCustomMessageHandler( - 'resetValue',function(variableName){ - Shiny.onInputChange(variableName, null);});"), - shinydashboard::box( - width = 12, title = "Request phenotyping", - div( - id = "pheno_info1", - p("In this module, you can request phenotyping data."), - p( - "One experimental site, Agrom-sur-Lez (AZ), is available with ", strong(constants_ui("pheno_nb.plots"), " plots."), - " Planting a plot should be requested ", strong("before ", constants_ui("pheno_max.upload.pheno.field")), ".", - " The data are then available ", constants_ui("pheno_duration.pheno.field"), " months after, on ", strong(constants_ui("pheno_pheno.data.availability.date")), ".", - " The cost of a single plot (seeding, phenotyping of the three traits and harvesting) is ", strong(constants_ui("pheno_cost.pheno.field"), " Mendels.") - ), - p("A", strong("greenhouse"), " can also be used all year long to assess the resistance to", HTML("P.psychedelica."), "This request takes ", strong(constants_ui("pheno_duration.pheno.patho"), "months"), " and costs ", strong(constants_ui("pheno_cost.pheno.patho.mendels"), " Mendels"), " (which represents", constants_ui("pheno_cost.pheno.patho"), " plot).") +div( + uiOutput("UIbreederInfoPheno"), + shinydashboard::box( + width = 12, title = "Request phenotyping", + div( + id = "pheno_info1", + p("In this module, you can request phenotyping data."), + p( + "One experimental site, Agrom-sur-Lez (AZ), is available with ", strong(constants_ui("pheno_nb.plots"), " plots."), + " Planting a plot should be requested ", strong("before ", constants_ui("pheno_max.upload.pheno.field")), ".", + " The data are then available ", constants_ui("pheno_duration.pheno.field"), " months after, on ", strong(constants_ui("pheno_pheno.data.availability.date")), ".", + " The cost of a single plot (seeding, phenotyping of the three traits and harvesting) is ", strong(constants_ui("pheno_cost.pheno.field"), " Mendels.") ), - div( - id = "pheno_info2", - p("The request file for this module should be similar to the following example:"), - tags$pre(HTML(" + p("A", strong("greenhouse"), " can also be used all year long to assess the resistance to", HTML("P.psychedelica."), "This request takes ", strong(constants_ui("pheno_duration.pheno.patho"), "months"), " and costs ", strong(constants_ui("pheno_cost.pheno.patho.mendels"), " Mendels"), " (which represents", constants_ui("pheno_cost.pheno.patho"), " plot).") + ), + div( + id = "pheno_info2", + p("The request file for this module should be similar to the following example:"), + tags$pre(HTML("
@@ -61,61 +55,54 @@ tabItem(
ind\t task\t1\t
")), - p(tags$ul( - tags$li("The file should be in", code(".txt"), "format with", strong("tabulations"), "separator and ", strong(code("UTF-8"), "encoding.")), - tags$li("All columns (", code("ind"), ", ", code("task"), ", and ", code("details"), ") are compulsory."), - tags$li("The ", code("task"), " column should contain 'pheno-field' (for experimental site phenotyping) or 'pheno-patho' (for greenhouse phenotyping)"), - tags$li("If 'task=pheno-field', the ", code("details"), " column should contain the number of plots (the total number of requested plots should not exceed the total available:", strong(constants_ui("pheno_nb.plots_2"), " plots."), ")"), - # WIP ---- blocked here as `outputs` can only be used once ! >< - tags$li("If 'task=pheno-patho', the ", code("details"), " column should contain the number of replicates"), - tags$li("Individuals should be available."), - tags$li("Individuals should not be duplicated within each task."), - tags$li("Lines starting with ", code("#"), " will be ignored.") - )) + p(tags$ul( + tags$li("The file should be in", code(".txt"), "format with", strong("tabulations"), "separator and ", strong(code("UTF-8"), "encoding.")), + tags$li("All columns (", code("ind"), ", ", code("task"), ", and ", code("details"), ") are compulsory."), + tags$li("The ", code("task"), " column should contain 'pheno-field' (for experimental site phenotyping) or 'pheno-patho' (for greenhouse phenotyping)"), + tags$li("If 'task=pheno-field', the ", code("details"), " column should contain the number of plots (the total number of requested plots should not exceed the total available:", strong(constants_ui("pheno_nb.plots_2"), " plots."), ")"), + # WIP ---- blocked here as `outputs` can only be used once ! >< + tags$li("If 'task=pheno-patho', the ", code("details"), " column should contain the number of replicates"), + tags$li("Individuals should be available."), + tags$li("Individuals should not be duplicated within each task."), + tags$li("Lines starting with ", code("#"), " will be ignored.") + )) + ) + ), + shinydashboard::box( + width = 12, title = "Choose an instruction file for phenotyping:", + div( + id = "pheno_file", + uiOutput("idMessagePheno"), + fileInput( + inputId = "file.pheno", + label = NULL, + multiple = FALSE, + accept = c(".txt", ".tsv") ) - ), - shinydashboard::box( - width = 12, title = "Choose an instruction file for phenotyping:", + ) + ), + shinydashboard::tabBox( + width = 12, title = "Info", id = "pheno_tabset", side = "right", selected = "Check", + tabPanel( + "Request", div( - id = "pheno_file", - uiOutput("idMessagePheno"), - fileInput( - inputId = "file.pheno", - label = NULL, - multiple = FALSE, - accept = c(".txt", ".tsv") - ) - ) - ), - shinydashboard::tabBox( - width = 12, title = "Info", id = "pheno_tabset", side = "right", selected = "Check", - tabPanel( - "Request", - div( - uiOutput("submitPhenoRequest") - ), - div( - uiOutput("phenoRequestResultUI") - ) + uiOutput("submitPhenoRequest") ), - tabPanel( - "Data", - dataTableOutput(outputId = "qryPheno") - ), - tabPanel( - "Summary", - tableOutput("PhenoInvoice") - ), - tabPanel( - "Check", - verbatimTextOutput("PhenoUploaded") + div( + uiOutput("phenoRequestResultUI") ) ), - if (debugDisplay) { - shinydashboard::box( - width = 12, title = "Debug", - verbatimTextOutput("PhenoDebug") - ) - } + tabPanel( + "Data", + dataTableOutput(outputId = "qryPheno") + ), + tabPanel( + "Summary", + tableOutput("PhenoInvoice") + ), + tabPanel( + "Check", + verbatimTextOutput("PhenoUploaded") + ) ) ) diff --git a/src/ui/ui_plant_material.R b/src/ui/ui_plant_material.R index 3ebf01a..97362d8 100644 --- a/src/ui/ui_plant_material.R +++ b/src/ui/ui_plant_material.R @@ -19,31 +19,24 @@ # UI of "cross" part - -tabItem( - tabName = "plant_mat", - fluidRow( - useShinyjs(), - tags$script("Shiny.addCustomMessageHandler( - 'resetValue',function(variableName){ - Shiny.onInputChange(variableName, null);});"), - uiOutput("UIbreederInfoPltMat"), - shinydashboard::box( - width = 12, title = "Request plant material", - div( - id = "cross_info1", - p("In this module, you can request new plant materials."), - p("A greenhouse can be used", strong("all year long"), " to perform crosses:"), - tags$ul( - tags$li(strong("Allofecundation"), ": ", constants_ui("pltmat_duration.allof"), "-month delay and costs", constants_ui("pltmat_cost.allof"), " plot (", constants_ui("pltmat_cost.allof.mendels"), " Mendels )."), - tags$li(strong("Autofecundation"), ": ", constants_ui("pltmat_duration.autof"), "-month delay and costs", constants_ui("pltmat_cost.autof"), " plot (", constants_ui("pltmat_cost.autof.mendels"), " Mendels ).") - ), - p("A laboratory can also be used to perform ", strong("haplodiploidisation"), ". It has a ", constants_ui("pltmat_duration.haplodiplo"), "-month delay, costs ", constants_ui("pltmat_cost.haplodiplo"), " plot (", constants_ui("pltmat_cost.haplodiplo.mendels"), " Mendels ), and a maximum of ", constants_ui("pltmat_max.nb.haplodiplos"), " can be requested at once.") +div( + uiOutput("UIbreederInfoPltMat"), + shinydashboard::box( + width = 12, title = "Request plant material", + div( + id = "cross_info1", + p("In this module, you can request new plant materials."), + p("A greenhouse can be used", strong("all year long"), " to perform crosses:"), + tags$ul( + tags$li(strong("Allofecundation"), ": ", constants_ui("pltmat_duration.allof"), "-month delay and costs", constants_ui("pltmat_cost.allof"), " plot (", constants_ui("pltmat_cost.allof.mendels"), " Mendels )."), + tags$li(strong("Autofecundation"), ": ", constants_ui("pltmat_duration.autof"), "-month delay and costs", constants_ui("pltmat_cost.autof"), " plot (", constants_ui("pltmat_cost.autof.mendels"), " Mendels ).") ), - div( - id = "cross_info2", - p("The request file for this module should be similar to the following example:"), - tags$pre(HTML(" + p("A laboratory can also be used to perform ", strong("haplodiploidisation"), ". It has a ", constants_ui("pltmat_duration.haplodiplo"), "-month delay, costs ", constants_ui("pltmat_cost.haplodiplo"), " plot (", constants_ui("pltmat_cost.haplodiplo.mendels"), " Mendels ), and a maximum of ", constants_ui("pltmat_max.nb.haplodiplos"), " can be requested at once.") + ), + div( + id = "cross_info2", + p("The request file for this module should be similar to the following example:"), + tags$pre(HTML("
@@ -69,61 +62,52 @@ tabItem(
parent1\t parent2\thaplodiploidization
")), - p(tags$ul( - tags$li("The file should be in", code(".txt"), "format with", strong("tabulations"), "separator and ", strong(code("UTF-8"), "encoding.")), - tags$li("Each row corresponds to a child."), - tags$li("Only columns", code("parent1"), ", ", code("parent2"), ", and ", code("child"), " are compulsory."), - tags$li("Only the ", code("parent2"), " column can be empty (which means haplodiploidization request)."), - tags$li("Individual names should only use ", code("[a-z], [A-Z], [0-9], [._-]"), " (no space, comma, etc)."), - tags$li("Individual names should be unique."), - tags$li("Lines starting with ", code("#"), " will be ignored.") - )) + p(tags$ul( + tags$li("The file should be in", code(".txt"), "format with", strong("tabulations"), "separator and ", strong(code("UTF-8"), "encoding.")), + tags$li("Each row corresponds to a child."), + tags$li("Only columns", code("parent1"), ", ", code("parent2"), ", and ", code("child"), " are compulsory."), + tags$li("Only the ", code("parent2"), " column can be empty (which means haplodiploidization request)."), + tags$li("Individual names should only use ", code("[a-z], [A-Z], [0-9], [._-]"), " (no space, comma, etc)."), + tags$li("Individual names should be unique."), + tags$li("Lines starting with ", code("#"), " will be ignored.") + )) + ) + ), + shinydashboard::box( + width = 12, title = "Choose an instruction file for plant material:", + div( + id = "cross_file", + uiOutput("idMessagePltMat"), + fileInput( + inputId = "file.plmat", + label = NULL, + multiple = FALSE, + accept = c(".txt", ".tsv") ) - ), - shinydashboard::box( - width = 12, title = "Choose an instruction file for plant material:", + ) + ), + shinydashboard::tabBox( + width = 12, title = "Info", id = "cross_tabset", side = "right", selected = "Check", + tabPanel( + "Request", div( - id = "cross_file", - uiOutput("idMessagePltMat"), - fileInput( - inputId = "file.plmat", - label = NULL, - multiple = FALSE, - accept = c(".txt", ".tsv") - ) - ) - ), - shinydashboard::tabBox( - width = 12, title = "Info", id = "cross_tabset", side = "right", selected = "Check", - tabPanel( - "Request", - div( - uiOutput("submitPlmatRequest") - ), - div( - uiOutput("plmatRequestResultUI") - ) + uiOutput("submitPlmatRequest") ), - tabPanel( - "Data", - dataTableOutput(outputId = "qryPlmat") - ), - tabPanel( - "Summary", - tableOutput("PltmatInvoice") - ), - # verbatimTextOutput("plmatSmy"), - # verbatimTextOutput("plmatStr")), - tabPanel( - "Check", - verbatimTextOutput("plmatUploaded") + div( + uiOutput("plmatRequestResultUI") ) ), - if (debugDisplay) { - shinydashboard::box( - width = 12, title = "Debug", - verbatimTextOutput("plmatDebug") - ) - } - ) # close fluidRow -) # close tabItem + tabPanel( + "Data", + dataTableOutput(outputId = "qryPlmat") + ), + tabPanel( + "Summary", + tableOutput("PltmatInvoice") + ), + tabPanel( + "Check", + verbatimTextOutput("plmatUploaded") + ) + ) +) diff --git a/tests_UI/test-1.spec.ts b/tests_UI/test-1.spec.ts index c9de98b..be0df3e 100644 --- a/tests_UI/test-1.spec.ts +++ b/tests_UI/test-1.spec.ts @@ -82,8 +82,8 @@ test.describe("PlantBreedGame_UI", () => { await runEvaluation(page, registered_inds); }); - // TODO: add a test for "Admin / GameProgress" the core function is partially checked - // with the evaluation check (when we build the game report) but a + // TODO: add a test for "Admin / GameProgress" the core function is partially checked + // with the evaluation check (when we build the game report) but a test("delete breeder", async ({ page }) => { await login(page, "admin", psw); @@ -225,10 +225,10 @@ async function requestPlantMaterial( .getByRole("textbox", { name: "Browse..." }) .setInputFiles("./tests/requestExamples/" + reqFile); - await page.getByRole("tab", { name: "Check" }).click(); + await page.getByRole("link", { name: "Check" }).click(); await expect(page.locator("#plmatUploaded")).toContainText("GOOD"); - await page.getByRole("tab", { name: "Summary" }).click(); + await page.getByRole("link", { name: "Summary" }).click(); await expect( page.locator("#PltmatInvoice").getByRole("cell", { name: "Task" }), ).toBeVisible(); @@ -242,7 +242,7 @@ async function requestPlantMaterial( page.locator("#PltmatInvoice").locator("th").filter({ hasText: "Total" }), ).toBeVisible(); - await page.getByRole("tab", { name: "Data" }).click(); + await page.getByRole("link", { name: "Data" }).click(); await expect( page .locator("#qryPlmat") @@ -264,7 +264,7 @@ async function requestPlantMaterial( .getByLabel("explanations: activate to sort column ascending"), ).toBeVisible(); - await page.getByRole("tab", { name: "Request" }).click(); + await page.getByRole("link", { name: "Request", exact: true }).click(); await expect(page.getByRole("button", { name: "Yes, I do!" })).toBeEnabled(); await page.getByRole("button", { name: "Yes, I do!" }).click(); await expect(page.getByText("Create Plant Material: Done !")).toBeVisible({ @@ -305,10 +305,10 @@ async function requestPhenotyping( .getByRole("textbox", { name: "Browse..." }) .setInputFiles("./tests/requestExamples/" + reqFile); - await page.getByRole("tab", { name: "Check" }).click(); + await page.getByRole("link", { name: "Check" }).click(); await expect(page.locator("#PhenoUploaded")).toContainText("GOOD"); - await page.getByRole("tab", { name: "Summary" }).click(); + await page.getByRole("link", { name: "Summary" }).click(); await expect( page.locator("#PhenoInvoice").getByRole("cell", { name: "Task" }), ).toBeVisible(); @@ -322,7 +322,7 @@ async function requestPhenotyping( page.locator("#PhenoInvoice").locator("th").filter({ hasText: "Total" }), ).toBeVisible(); - await page.getByRole("tab", { name: "Data" }).click(); + await page.getByRole("link", { name: "Data" }).click(); await expect( page .locator("#qryPheno") @@ -339,7 +339,7 @@ async function requestPhenotyping( .getByLabel("details: activate to sort column ascending"), ).toBeVisible(); - await page.getByRole("tab", { name: "Request" }).click(); + await page.getByRole("link", { name: "Request", exact: true }).click(); await expect(page.getByRole("button", { name: "Yes, I do!" })).toBeEnabled(); await page.getByRole("button", { name: "Yes, I do!" }).click(); await expect(page.getByText("Process Pheno request: Done")).toBeVisible({ @@ -366,10 +366,10 @@ async function requestGenotyping( .getByRole("textbox", { name: "Browse..." }) .setInputFiles("./tests/requestExamples/" + reqFile); - await page.getByRole("tab", { name: "Check" }).click(); + await page.getByRole("link", { name: "Check" }).click(); await expect(page.locator("#GenoUploaded")).toContainText("GOOD"); - await page.getByRole("tab", { name: "Summary" }).click(); + await page.getByRole("link", { name: "Summary" }).click(); await expect( page.locator("#GenoInvoice").getByRole("cell", { name: "Task" }), ).toBeVisible(); @@ -383,7 +383,7 @@ async function requestGenotyping( page.locator("#GenoInvoice").locator("th").filter({ hasText: "Total" }), ).toBeVisible(); - await page.getByRole("tab", { name: "Data" }).click(); + await page.getByRole("link", { name: "Data" }).click(); await expect( page .locator("#qryGeno") @@ -400,7 +400,7 @@ async function requestGenotyping( .getByLabel("details: activate to sort column ascending"), ).toBeVisible(); - await page.getByRole("tab", { name: "Request" }).click(); + await page.getByRole("link", { name: "Request", exact: true }).click(); await expect(page.getByRole("button", { name: "Yes, I do!" })).toBeEnabled(); await page.getByRole("button", { name: "Yes, I do!" }).click(); await expect(page.getByText("Process Geno request: Done")).toBeVisible({ diff --git a/ui.R b/ui.R index da0adac..20a4c1a 100644 --- a/ui.R +++ b/ui.R @@ -81,45 +81,106 @@ shinyUI( # dashboard body dashboardBody( + useShinyjs(), ## javascript function tags$head( tags$script(src = "busyServer.js"), + tags$script("Shiny.addCustomMessageHandler( + 'resetValue',function(variableName){ + Shiny.onInputChange(variableName, null);});"), tags$link(rel = "stylesheet", type = "text/css", href = "style.css"), tags$link(href = "https://fonts.googleapis.com/css?family=Nunito", rel = "stylesheet") ), tabItems( + # ---- How to play ? ---- source("src/ui/ui_information.R", local = TRUE, encoding = "UTF-8" )$value, - source("src/ui/ui_id_logPage.R", - local = TRUE, - encoding = "UTF-8" - )$value, - source("src/ui/ui_plant_material.R", - local = TRUE, - encoding = "UTF-8" - )$value, - source("src/ui/ui_pheno.R", - local = TRUE, - encoding = "UTF-8" - )$value, - source("src/ui/ui_geno.R", - local = TRUE, - encoding = "UTF-8" - )$value, - source("src/ui/ui_eval.R", - local = TRUE, - encoding = "UTF-8" - )$value, + + # ---- Identification / Home ---- + tabItem( + tabName = "id", + fluidRow( + uiOutput("id_main_UI"), + if (debugDisplay) { + shinydashboard::box( + width = 12, title = "Debug", + verbatimTextOutput("IdDebug") + ) + } + ) + ), + + # ---- Plant Matrial menu ---- + tabItem( + tabName = "plant_mat", + fluidRow( + uiOutput("pltmat_main_UI"), + if (debugDisplay) { + shinydashboard::box( + width = 12, title = "Debug", + verbatimTextOutput("plmatDebug") + ) + } + ) + ), + + # ---- Phenotyping ---- + tabItem( + tabName = "pheno", + fluidRow( + uiOutput("pheno_main_UI"), + if (debugDisplay) { + shinydashboard::box( + width = 12, title = "Debug", + verbatimTextOutput("PhenoDebug") + ) + } + ) + ), + + # ---- Genotyping ---- + tabItem( + tabName = "geno", + fluidRow( + uiOutput("geno_main_UI"), + if (debugDisplay) { + shinydashboard::box( + width = 12, title = "Debug", + verbatimTextOutput("GenoDebug") + ) + } + ) + ), + # source("src/ui/ui_geno.R", + # local = TRUE, + # encoding = "UTF-8" + # )$value, + + # ---- Evaluation ---- + tabItem( + tabName = "eval", + fluidRow( + uiOutput("evalUI") + ) + ), + + # ---- Theory ---- source("src/ui/ui_theory.R", local = TRUE, encoding = "UTF-8" )$value, - source("src/ui/ui_admin.R", - local = TRUE, - encoding = "UTF-8" - )$value, + + # ---- Admin ---- + tabItem( + tabName = "admin", + fluidRow( + uiOutput("adminUI") + ) + ), + + # ---- About ---- source("src/ui/ui_about.R", local = TRUE, encoding = "UTF-8" From 169c13693f7db0214fecb695055a37d811e766fc Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Mon, 10 Jun 2024 18:41:42 +0900 Subject: [PATCH 12/12] feat: game initialisation from the application With this feature, the admin can initialise (or re-initialise) the game from the app directly. --- README.md | 41 ++- src/fun/func_dbRequests.R | 145 ++++++++++ src/server/server_admin.R | 102 ++++++- src/ui/ui_admin_loggedIn.R | 576 ++++++++++++++++++++----------------- tests_UI/test-1.spec.ts | 5 + 5 files changed, 574 insertions(+), 295 deletions(-) diff --git a/README.md b/README.md index 5b10887..5b8a827 100755 --- a/README.md +++ b/README.md @@ -47,20 +47,7 @@ The package can also be installed after cloning the git repository: git clone git@github.com: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`). diff --git a/src/fun/func_dbRequests.R b/src/fun/func_dbRequests.R index a0e292f..ef55b21 100644 --- a/src/fun/func_dbRequests.R +++ b/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.")) + } +} diff --git a/src/server/server_admin.R b/src/server/server_admin.R index 7a83b25..bd107d0 100644 --- a/src/server/server_admin.R +++ b/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() +}) diff --git a/src/ui/ui_admin_loggedIn.R b/src/ui/ui_admin_loggedIn.R index 852fa31..39ce06e 100644 --- a/src/ui/ui_admin_loggedIn.R +++ b/src/ui/ui_admin_loggedIn.R @@ -23,316 +23,352 @@ ## this file is sourced in "server_admin.R" in a renderUI() function ############################ -list( - shinydashboard::tabBox( - width = 12, title = "Admin", id = "admin_tabset", side = "left", - tabPanel( - "Manage sessions", + + +if (gameInitialised()) { + manage_sessions_tab_content <- div( + div( + style = "margin-bottom:50px;", + h3("Current sessions:"), + tableOutput("sessionsTable") + ), + div( # add New session div( - style = "margin-bottom:50px;", - h3("Current sessions:"), - tableOutput("sessionsTable") - ), - div( # add New session + style = "margin-bottom: 20px;", # inputs + h3("Add a new session:"), div( - style = "margin-bottom: 20px;", # inputs - h3("Add a new session:"), - div( - style = "display: inline-block; vertical-align:top; width: 33%; min-width:300px;", # start - h4("Start"), - tags$table( - style = "width: 300px; border-collapse: collapse;", # start table 1 - tags$td( - style = "width: 34%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - dateInput("startDate", "date", - width = "100px" - ) - ), - tags$td( - style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - numericInput("startHour", "hour", - value = 9, min = 0, max = 23, step = 1, - width = "75px" - ) - ), - tags$td( - style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - numericInput("startMin", "minute", - value = 0, min = 0, max = 59, step = 1, - width = "75px" - ) + style = "display: inline-block; vertical-align:top; width: 33%; min-width:300px;", # start + h4("Start"), + tags$table( + style = "width: 300px; border-collapse: collapse;", # start table 1 + tags$td( + style = "width: 34%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + dateInput("startDate", "date", + width = "100px" ) - ) # end table 1 - ), # end div "start" - - div( - style = "display: inline-block; vertical-align:top; width: 33%; min-width:300px;", # end - h4("End"), - tags$table( - style = "width: 300px; border-collapse: collapse;", # start table 2 - tags$td( - style = "width: 34%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - dateInput("endDate", "date", - width = "100px" - ) - ), - tags$td( - style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - numericInput("endHour", "hour", - value = 9, min = 0, max = 23, step = 1, - width = "75px" - ) - ), - tags$td( - style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - numericInput("endMin", "minute", - value = 0, min = 0, max = 59, step = 1, - width = "75px" - ) + ), + tags$td( + style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + numericInput("startHour", "hour", + value = 9, min = 0, max = 23, step = 1, + width = "75px" ) - ) # end table 2 - ), # end div "end" - - div( - style = "display: inline-block; vertical-align:top; width:33%; min-width:300px;", # year time - h4("Year time"), - tags$table( - style = "border-collapse: collapse;", # start table 3 - tags$td( - style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - numericInput("yearTime", "Duration of one year (in minutes)", value = 60, min = 0, max = Inf, step = 1) + ), + tags$td( + style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + numericInput("startMin", "minute", + value = 0, min = 0, max = 59, step = 1, + width = "75px" ) - ) # end table 3 - ) # end div "year time" - ), # end div inputs - - div( - style = "display: inline-block; vertical-align:top; width:25%; margin-bottom: 50px; padding-left: 10px;", # button - actionButton("addSession", "Add this new session") - ) # end div "button" - ), # end div "add New session" - - - - div( - style = "margin-bottom:100px;", # delete session - h3("Delete sessions:"), - tags$table( - style = "width: 100%; border-collapse: collapse;", - tags$td( - style = "width: 50%; vertical-align: bottom; padding: 10px;", - selectInput("delSession", "Session's number", - choices = c("", sessionsList()$num), - selected = "", width = "100%" - ) - ), - tags$td( - style = "width: 50%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - actionButton("deleteSession", "DO NOT click! (unless you are sure to delete this session)", - width = "100%", style = "margin-bottom: 0px;", - style = "background-color:#ff3333; color:white;" ) - ) - ) - ) # end div "delete session" - ), # end tabPanel sessions managment - - - - - + ) # end table 1 + ), # end div "start" - tabPanel( - "Manage breeders", - div( # add New breeders - h3("Add a new breeder:"), - tags$head( - tags$style(HTML(".shiny-input-container{margin-bottom: 0px;} - .selectize-control{margin-bottom: 0px;}")) - ), - tags$table( - style = "width: 100%; border-collapse: collapse;", - tags$tr( - tags$td( - style = "width: 25%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - textInput("newBreederName", "Breeder's name", - placeholder = "Only a-z, A-Z, 0-9 and '_' are allowed", - width = "100%" - ) - ), + div( + style = "display: inline-block; vertical-align:top; width: 33%; min-width:300px;", # end + h4("End"), + tags$table( + style = "width: 300px; border-collapse: collapse;", # start table 2 tags$td( - style = "width: 25%; vertical-align: bottom; padding: 10px;", - selectInput("newBreederStatus", "Status", - choices = c("player", "tester", "game master"), - width = "100%" + style = "width: 34%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + dateInput("endDate", "date", + width = "100px" ) ), tags$td( - style = "width: 25%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - passwordInput("newBreederPsw", "Password", - width = "100%" + style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + numericInput("endHour", "hour", + value = 9, min = 0, max = 23, step = 1, + width = "75px" ) ), tags$td( - style = "width: 25%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - actionButton("addNewBreeder", "Add this new breeder", - width = "100%", style = "margin-bottom: 0px;" + style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + numericInput("endMin", "minute", + value = 0, min = 0, max = 59, step = 1, + width = "75px" ) ) - ) - ) # end tags$table - ), # end div "add new breeder" + ) # end table 2 + ), # end div "end" + div( + style = "display: inline-block; vertical-align:top; width:33%; min-width:300px;", # year time + h4("Year time"), + tags$table( + style = "border-collapse: collapse;", # start table 3 + tags$td( + style = "width: 33%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + numericInput("yearTime", "Duration of one year (in minutes)", value = 60, min = 0, max = Inf, step = 1) + ) + ) # end table 3 + ) # end div "year time" + ), # end div inputs - div( # delete breeders - h3("Delete a breeder:"), - tags$table( - style = "width: 100%; border-collapse: collapse;", + div( + style = "display: inline-block; vertical-align:top; width:25%; margin-bottom: 50px; padding-left: 10px;", # button + actionButton("addSession", "Add this new session") + ) # end div "button" + ), # end div "add New session" + + + + div( + style = "margin-bottom:100px;", # delete session + h3("Delete sessions:"), + tags$table( + style = "width: 100%; border-collapse: collapse;", + tags$td( + style = "width: 50%; vertical-align: bottom; padding: 10px;", + selectInput("delSession", "Session's number", + choices = c("", sessionsList()$num), + selected = "", width = "100%" + ) + ), + tags$td( + style = "width: 50%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + actionButton("deleteSession", "DO NOT click! (unless you are sure to delete this session)", + width = "100%", style = "margin-bottom: 0px;", + style = "background-color:#ff3333; color:white;" + ) + ) + ) + ) # end div "delete session" + ) + + manage_breeders_tab_content <- div( + div( # add New breeders + h3("Add a new breeder:"), + tags$head( + tags$style(HTML(".shiny-input-container{margin-bottom: 0px;} + .selectize-control{margin-bottom: 0px;}")) + ), + tags$table( + style = "width: 100%; border-collapse: collapse;", + tags$tr( + tags$td( + style = "width: 25%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + textInput("newBreederName", "Breeder's name", + placeholder = "Only a-z, A-Z, 0-9 and '_' are allowed", + width = "100%" + ) + ), tags$td( - style = "width: 50%; vertical-align: bottom; padding: 10px;", - breeder_list_ui("admin_breeder_list_for_deletion"), + style = "width: 25%; vertical-align: bottom; padding: 10px;", + selectInput("newBreederStatus", "Status", + choices = c("player", "tester", "game master"), + width = "100%" + ) + ), + tags$td( + style = "width: 25%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + passwordInput("newBreederPsw", "Password", + width = "100%" + ) ), tags$td( - style = "width: 50%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", - actionButton("deleteBreeder", "DO NOT click! (unless you are sure to delete this breeder)", - width = "100%", style = "margin-bottom: 0px;", - style = "background-color:#ff3333; color:white;" + style = "width: 25%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + actionButton("addNewBreeder", "Add this new breeder", + width = "100%", style = "margin-bottom: 0px;" ) ) ) - ) # end div "delete breeders" - ), # end tabPanel "Add/Delete Breeders" + ) # end tags$table + ), # end div "add new breeder" - tabPanel( - "Manage constants", - # tabPanel to manage some game constants - - # see.year.effct - div( - id = "admin_seedYearEffect", - style = "margin: 0px 0px 40px 0px;", - - # input: - div( - id = "admin_div_numInput_seedYearEfect", - style = "display: inline-block; - vertical-align: top;", - numericInput("admin_seedYearEfect", "seed.year.effect", - value = 4321, - min = 0, - max = NA, - step = 1 - ) - ), - - # button to request update: - div( - id = "admin_div_button_seedYearEfect", - style = "display: inline-block; - vertical-align: top; - padding-top: 25px", # button align with numInput - actionButton("admin_button_seedYearEfect", "update seed.year.effect") + div( # delete breeders + h3("Delete a breeder:"), + tags$table( + style = "width: 100%; border-collapse: collapse;", + tags$td( + style = "width: 50%; vertical-align: bottom; padding: 10px;", + breeder_list_ui("admin_breeder_list_for_deletion"), ), - - # current value: - div( - id = "admin_currentSYE", - "Current", code("seed.year.effect"), ":", textOutput("admin_currentSYE", container = span) + tags$td( + style = "width: 50%; vertical-align: bottom; padding: 10px; padding-bottom: 13.8px;", + actionButton("deleteBreeder", "DO NOT click! (unless you are sure to delete this breeder)", + width = "100%", style = "margin-bottom: 0px;", + style = "background-color:#ff3333; color:white;" + ) ) - ) # end div "admin_seedYearEffect" - ), # end tabPanel "Manage constants" - - + ) + ) # end div "delete breeders" + ) + manage_constants_tab_content <- div( + div( + id = "admin_seedYearEffect", + style = "margin: 0px 0px 40px 0px;", - - - tabPanel( - "Disk usage", + # input: div( - id = "admin_diskU_data", + id = "admin_div_numInput_seedYearEfect", style = "display: inline-block; - vertical-align:top; - width: 33%; - min-width:300px;", - h3("Disk usage:"), - tableOutput("sizeDataFolder") + vertical-align: top;", + numericInput("admin_seedYearEfect", "seed.year.effect", + value = 4321, + min = 0, + max = NA, + step = 1 + ) ), + + # button to request update: div( - id = "admin_diskU_input", + id = "admin_div_button_seedYearEfect", style = "display: inline-block; - vertical-align:top; - width: 66%;", - p("To prevent over disk usage on your server, you can specifiy here the maximum size for all game data.", - style = "margin-top:20px;" - ), - p("In case the size of all data exceeds this threshold, players will not be allowed to connect any more, and you will have to delete haplotypes of some breeders."), - p(textOutput("InfoCurrentMaxDiskUsage")), - div( - style = "width: 50%; - display: inline-block; - vertical-align: top;", - numericInput("admin_maxDiskUsage", - label = "Maximum disk usage (in Gb)", - value = 10, - min = 2 - ) + vertical-align: top; + padding-top: 25px", # button align with numInput + actionButton("admin_button_seedYearEfect", "update seed.year.effect") + ), + + # current value: + div( + id = "admin_currentSYE", + "Current", code("seed.year.effect"), ":", textOutput("admin_currentSYE", container = span) + ) + ) # end div "admin_seedYearEffect" + ) + + disk_usage_tab_content <- div( + div( + id = "admin_diskU_data", + style = "display: inline-block; + vertical-align:top; + width: 33%; + min-width:300px;", + h3("Disk usage:"), + tableOutput("sizeDataFolder") + ), + div( + id = "admin_diskU_input", + style = "display: inline-block; + vertical-align:top; + width: 66%;", + p("To prevent over disk usage on your server, you can specifiy here the maximum size for all game data.", + style = "margin-top:20px;" + ), + p("In case the size of all data exceeds this threshold, players will not be allowed to connect any more, and you will have to delete haplotypes of some breeders."), + p(textOutput("InfoCurrentMaxDiskUsage")), + div( + style = "width: 50%; + display: inline-block; + vertical-align: top;", + numericInput("admin_maxDiskUsage", + label = "Maximum disk usage (in Gb)", + value = 10, + min = 2 + ) + ), + div( + style = "width: 30%; + padding-top: 26px; + display: inline-block; + vertical-align: top;", + actionButton("updateMaxDiskUsage", + label = "Update" + ) + ) + ) # end div "admin_diskU_input" + ) + + + game_progress_tab_content <- div( + fluidRow( + div( + class = "col-sm-12 col-md-12 col-lg-12", + selectInput( + inputId = "admin_progressTrait", + label = "Trait", + choices = c("Trait 1", "Trait 2"), + selected = "Trait 1" ), - div( - style = "width: 30%; - padding-top: 26px; - display: inline-block; - vertical-align: top;", - actionButton("updateMaxDiskUsage", - label = "Update" - ) + actionButton( + inputId = "admin_progressButton", + label = "Refresh !", + icon = icon("refresh"), + style = "background-color: #00a65a; + color: #ffffff;" ) - ) # end div "admin_diskU_input" - ), # end tabPanel "Disk usage" + ), + div( + class = "col-sm-12 col-md-12 col-lg-6", + plotlyOutput("admin_plotAllIndGameProgress") %>% withSpinner() + ), + div( + class = "col-sm-12 col-md-12 col-lg-6", + plotlyOutput("admin_plotMaxIndGameProgress") %>% withSpinner() + ), + div( + class = "col-sm-12 col-md-12 col-lg-6", + plotlyOutput("admin_boxPlotGameProgress") %>% withSpinner() + ), + div( + class = "col-sm-12 col-md-12 col-lg-6", + breeder_list_ui("admin_breeder_list_gameProgress"), + plotlyOutput("admin_T1T2GameProgress") %>% withSpinner() + ) + ) # end fluidRow + ) + + +} else { + game_not_initialised_msg <- div( + h3("Game not initialised"), + p("The game have not been initialised. It is therefore currently impossible to play.") + ) + manage_sessions_tab_content <- game_not_initialised_msg + manage_breeders_tab_content <- game_not_initialised_msg + manage_constants_tab_content <- game_not_initialised_msg + disk_usage_tab_content <- game_not_initialised_msg + game_progress_tab_content <- game_not_initialised_msg +} + + +game_initialisation_tab_content <- div( + p("By pressing the button below, you can initialise the game."), + p("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."), + div( + h2("Information:"), + p("Some breeders accounts will be automatically created:"), + tags$ul( + tags$li(code("Admin"), "with the default password", code("1234")), + tags$li(code("Tester"), "(this breeder do not have a password, you can leave the password field empty to connect)") + ) + ), + uiOutput("initialisation_button") +) - #----- Game progress ----- - # This tab displays the progression of the players. +list( + shinydashboard::tabBox( + width = 12, title = "Admin", id = "admin_tabset", side = "left", + tabPanel( + "Manage sessions", + manage_sessions_tab_content + ), + tabPanel( + "Manage breeders", + manage_breeders_tab_content + ), + tabPanel( + "Manage constants", + manage_constants_tab_content + ), + tabPanel( + "Disk usage", + disk_usage_tab_content + ), tabPanel( "Game progress", - fluidRow( - div( - class = "col-sm-12 col-md-12 col-lg-12", - selectInput( - inputId = "admin_progressTrait", - label = "Trait", - choices = c("Trait 1", "Trait 2"), - selected = "Trait 1" - ), - actionButton( - inputId = "admin_progressButton", - label = "Refresh !", - icon = icon("refresh"), - style = "background-color: #00a65a; - color: #ffffff;" - ) - ), - div( - class = "col-sm-12 col-md-12 col-lg-6", - plotlyOutput("admin_plotAllIndGameProgress") %>% withSpinner() - ), - div( - class = "col-sm-12 col-md-12 col-lg-6", - plotlyOutput("admin_plotMaxIndGameProgress") %>% withSpinner() - ), - div( - class = "col-sm-12 col-md-12 col-lg-6", - plotlyOutput("admin_boxPlotGameProgress") %>% withSpinner() - ), - div( - class = "col-sm-12 col-md-12 col-lg-6", - breeder_list_ui("admin_breeder_list_gameProgress"), - plotlyOutput("admin_T1T2GameProgress") %>% withSpinner() - ) - ) # end fluidRow - ) # end tabPanel "Game progress" - ) # close tabBox -) # close list + game_progress_tab_content + ), + tabPanel( + "Game Initialisation", + game_initialisation_tab_content + ) + ) +) diff --git a/tests_UI/test-1.spec.ts b/tests_UI/test-1.spec.ts index be0df3e..e46655a 100644 --- a/tests_UI/test-1.spec.ts +++ b/tests_UI/test-1.spec.ts @@ -130,6 +130,11 @@ test.describe("PlantBreedGame_UI", () => { await runEvaluation(page, registered_inds); }); + + // TODO add tests related to game initialisation + + // TODO add tests where several requests are made with the same file + // this is a edge case that could happend }); async function login(page: Page, username: string, password: string) {