-- WIP --

timflutre · Dec 5, 2024 · 7ad61b4 · 7ad61b4
1 parent a50a0e4
commit 7ad61b4
Show file tree

Hide file tree

Showing 11 changed files with 473 additions and 213 deletions.
diff --git a/flake.lock b/flake.lock
diff --git a/flake.nix b/flake.nix
@@ -43,6 +43,7 @@
           uuid
           shinyTree
           prettyunits
+          reactable
 
           (pkgs.rPackages.buildRPackage {
             name = "rutilstimflutre";

diff --git a/global.R b/global.R
@@ -30,6 +30,7 @@ source("./src/fun/func_dbRequests.R", local = TRUE, encoding = "UTF-8")
 source("./src/fun/module_gameInit_params.R", local = TRUE, encoding = "UTF-8")
 source("./src/fun/func_gameInit_validation.R", local = TRUE, encoding = "UTF-8")
 source("./src/fun/func_ui_util.R", local = TRUE, encoding = "UTF-8")
+source("./src/fun/module_data-filtering.R", local = TRUE, encoding = "UTF-8")
 
 ## -------------------------------------------------------------------
 ## parameters

diff --git a/src/fun/func_admin.R b/src/fun/func_admin.R
@@ -52,8 +52,6 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) {
     stop("breeder already exist")
   }
 
-
-
   #### add breeder in the "breeders" table of database:
   if (!is.null(progressNewBreeder)) {
     progressNewBreeder$set(
@@ -63,60 +61,7 @@ addNewBreeder <- function(breederName, status, psw, progressNewBreeder = NULL) {
   }
   hashed.psw <- digest(psw, "md5", serialize = FALSE)
 
-  tbl <- "breeders"
-  query <- paste0(
-    "INSERT INTO ", tbl, " VALUES",
-    " ('", breederName, "','", status, "','", hashed.psw, "')"
-  )
-  db_execute_request(query)
-
-
-
-
-  #### create "plant_material_newBreeder"
-  if (!is.null(progressNewBreeder)) {
-    progressNewBreeder$set(
-      value = 3,
-      detail = "create \"plant_material\" table"
-    )
-  }
-  tbl <- paste0("plant_material_", breederName)
-  query <- paste0(
-    "CREATE TABLE ", tbl,
-    " (parent1 TEXT",
-    ", parent2 TEXT",
-    ", child TEXT PRIMARY KEY",
-    ", avail_from TEXT)"
-  )
-  db_execute_request(query)
-
-
-
-  #### fill "plant_material_newBreeder"
-  if (!is.null(progressNewBreeder)) {
-    progressNewBreeder$set(
-      value = 4,
-      detail = "fill \"plant_material\" table"
-    )
-  }
-  coll.ids <- gsub("_haplos.RData", "", initIndsHaplo)
-  query <- paste0(
-    "INSERT INTO ", tbl,
-    " (parent1, parent2, child, avail_from)",
-    " VALUES",
-    " ('", paste(gsub("Coll", "ind", coll.ids),
-      rep(NA, length(coll.ids)),
-      coll.ids,
-      rep(
-        paste0(getBreedingGameConstants()$first.year, "-01-01 00:00:00"),
-        length(coll.ids)
-      ),
-      sep = "','", collapse = "'),('"
-    ),
-    "')"
-  )
-  db_execute_request(query)
-
+  db_add_breeder(breederName, status, hashed.psw)
 
   #### create folders of the new breeder:
   if (!is.null(progressNewBreeder)) {

diff --git a/src/fun/func_data-viz.R b/src/fun/func_data-viz.R
@@ -127,7 +127,7 @@ data_viz_server <- function(id, plot_data) {
         filter <- "none"
       }
       DT::datatable(data,
-        filter = filter,
+        # filter = filter, # No filter because it can conflict with the manually implemented filters can be worked on later
         style = "bootstrap4",
         options = list(
           language = list(emptyTable = 'Empty'),

diff --git a/src/fun/func_dbRequests.R b/src/fun/func_dbRequests.R
@@ -152,7 +152,7 @@ db_execute_safe <- function(query, dbname = getOption("DATA_DB"), ...) {
 
 #' add data to a table from a data.frame.
 #' The data.frame must have have a structure matching the table
-db_add_data <- function(table, data, append = TRUE, overwrite = FALSE, dbname = DATA_DB, ...) {
+db_add_data <- function(table, data) {
   conn <- connect_to_db()
   out <- tryCatch({
     db_col_names <- paste(colnames(data), collapse = ", ")
@@ -604,10 +604,24 @@ db_get_individual <- function(ind_id = NULL,
                               cross_type = NULL,
                               request_name = NULL,
                               n_pheno_min = NULL,
-                              n_geno_min = NULL) {
                               n_geno_min = NULL,
-                              control = NULL) {
-  base_query <- "SELECT * FROM v_plant_material WHERE 1=1"
+                              control = NULL,
+                              public_columns = FALSE) {
+
+  columns <- "*"
+  if (public_columns) {
+    columns_to_keep_as <- c(
+      "name" = "Name",
+      "parent1_name" = "Parent 1",
+      "parent2_name" = "Parent 2",
+      "avail_from" = "Available date",
+      "cross_type" = "Crossing type",
+      "request_name" = "From plant material request",
+      "control" = "Is control"
+    )
+    columns <- paste(c(names(columns_to_keep_as)), collapse = ", ")
+  }
+  base_query <- paste("SELECT", columns, "FROM v_plant_material WHERE 1=1")
 
   breeder_condition <- ""
   if (!is.null(breeder)) {
@@ -619,15 +633,20 @@ db_get_individual <- function(ind_id = NULL,
     condition("AND", "id", "IN", ind_id),
     breeder_condition,
     condition("AND", "name", "IN", name),
-    condition("AND", "parent1", "IN", parent1),
-    condition("AND", "parent2", "IN", parent2),
+    condition("AND", "parent1_name", "IN", parent1),
+    condition("AND", "parent2_name", "IN", parent2),
     condition("AND", "cross_type", "IN", cross_type),
     condition("AND", "request_name", "IN", request_name),
     condition("AND", "n_pheno", ">=", n_pheno_min),
     condition("AND", "n_geno", ">=", n_geno_min),
     condition("AND", "control", "=", control)
   )
-  db_get(query)
+  individuals <- db_get(query)
+
+  if (public_columns) {
+    colnames(individuals) <- columns_to_keep_as
+  }
+  individuals
 }
 
 
@@ -757,9 +776,22 @@ db_get_phenotypes <- function(id = NULL,
                               t3 = NULL,
                               pathogen = NULL,
                               year = NULL,
-                              initial_data_only = NULL
-                              ) {
-  base_query <- "SELECT * FROM v_phenotypes WHERE 1=1"
+                              initial_data_only = NULL,
+                              public_columns = FALSE) {
+  columns <- "*"
+  if (public_columns) {
+    columns <- paste(c(
+      "ind",
+      "control_ind",
+      "year",
+      "plot",
+      "pathogen",
+      "trait1",
+      "trait2",
+      "trait3"
+    ), collapse = ", ")
+  }
+  base_query <- paste("SELECT", columns, "FROM v_phenotypes WHERE 1=1")
 
   breeder_condition <- ""
   if (!is.null(breeder)) {
@@ -796,6 +828,27 @@ db_get_phenotypes <- function(id = NULL,
 }
 
 
+db_get_pheno_summary <- function(breeder) {
+  query <- "
+    SELECT
+       MIN(trait1) AS minT1,
+       MAX(trait1) AS maxT1,
+       MIN(trait2) AS minT2,
+       MAX(trait2) AS maxT2,
+       MIN(year) AS minYear,
+       MAX(year) AS maxYear
+    FROM
+       v_phenotypes
+    WHERE 1=1
+  "
+  query <- paste(
+    query,
+    condition("AND", "breeder", "IN", c(breeder, "@ALL"))
+  )
+  as.list(db_get(query))
+}
+
+
 ## genotype requests ----
 
 db_add_geno_req_data <- function(req_id, request_data) {
@@ -885,6 +938,13 @@ db_get_genotypes <- function(id = NULL,
   db_get(query)
 }
 
+db_get_genotypes_data_list <- function(breeder) {
+  query <- paste(
+    "SELECT result_file  FROM v_genotypes WHERE 1=1",
+    condition("AND", "breeder", "IN", c(breeder, "@ALL")),
+    "GROUP BY result_file")
+  db_get(query)[,1]
+}
 
 
 

diff --git a/src/fun/func_id.R b/src/fun/func_id.R
@@ -19,34 +19,6 @@
 
 
 ## functions for the "id part"
-getDataFileList <- function(type, breeder) {
-  # function to get the list of data file of the breeder
-  # type (char) type of data (pheno or geno)
-  # breeder (char) name of the breeder
-
-  stopifnot(type %in% c("pheno", "geno", "pltMat", "request"))
-
-  dirPath <- file.path(DATA_SHARED, breeder)
-  dataFile <- list.files(dirPath)
-  dataFile <- c(dataFile, list.files(DATA_INITIAL_DATA))
-
-  ## Get the ids of the files
-  if (type == "pheno") {
-    matchId <- as.logical(lapply(dataFile, FUN = grepl, pattern = "Result_pheno"))
-  } else if (type == "geno") {
-    matchId <- matchId <- as.logical(lapply(dataFile, FUN = grepl, pattern = "Result_geno"))
-  } else if (type == "pltMat") {
-    matchId <- matchId <- as.logical(lapply(dataFile, FUN = grepl, pattern = "IndList_"))
-  } else if (type == "request") {
-    matchId <- as.logical(lapply(dataFile, FUN = grepl, pattern = "(^Request)|(^example_request_)|(^controls.txt$)|(^snp_coords_)"))
-  }
-
-
-  return(as.list(dataFile[matchId]))
-}
-
-
-
 
 availToDwnld <- function(fileName, gameTime) {
   # function to check if files are available to download