Béta version 2 shiny app

.gitlab-ci.yml

@@ -141,7 +141,7 @@ buildDocker:
   after_script:
     - docker logout $CI_REGISTRY
   rules:
-    - if: $CI_COMMIT_BRANCH == "master"
+    - if: '$CI_COMMIT_BRANCH == $CI_DEFAULT_BRANCH'
 
 deploy:
   image: debian
@@ -150,7 +150,7 @@ deploy:
     name: shinyproxy
     url: https://shiny.biosp.inrae.fr/
   rules:
-    - if: $CI_COMMIT_BRANCH == "master"
+    - if: '$CI_COMMIT_BRANCH == $CI_DEFAULT_BRANCH'
   before_script:
     - apt-get update && apt-get install -y sshpass openssh-client
     - export SSHPASS=$DEPLOY_PWD
@@ -171,5 +171,5 @@ pages:
     paths:
       - public
   rules:
-    - if: '$CI_COMMIT_BRANCH == "master"'
+    - if: '$CI_COMMIT_BRANCH == $CI_DEFAULT_BRANCH'
       when: always

inst/shiny-landsepi/global.R

@@ -9,11 +9,14 @@ library(grid)
 library(future)
 library(promises)
 library(tools)
+library(shinyalert)
 
 
 library("landsepiDev")
 data(package = "landsepiDev")
 
+source("modules/editableDT.R")
+
 ## del all file and directory of a path
 cleanDir <- function(path) {
   files <- dir(path, full.names=TRUE, no..=TRUE)
@@ -30,6 +33,158 @@ setwd(paste0(ROOT_PATH,"/www/tmp/"))
 
 cleanDir(paste0(ROOT_PATH,"/www/tmp/"))
 
+## User mode
+advanced_mode <- reactiveVal(FALSE)
+
+## Croptypes proportions in landscape
+croptypes_proportions <- c(1)
+
+## simul params reactive for view
+## use to update view 
+simul_params_croptypes <- shiny::reactiveVal()
+simul_params_cultivars <- shiny::reactiveVal()
+simul_params_cultivarsgenes <- shiny::reactiveVal()
+simul_params_genes <- shiny::reactiveVal()
+
+##################################################################
+# Functions
+##################################################################
+
+## Show message
+## id : message id
+## selectorafter : id element to place message after
+## message : the message
+showErrorMessage <- function(id="errorMessage", selectorafter = "#", message = "a message") {
+  shiny::insertUI(
+    selector = selectorafter,
+    where = "afterEnd",
+    ui = tags$div(
+      id = id,
+      class = "alert alert-danger",
+      paste0(message)
+      )
+    )
+}
+
+## Check croptypes Table
+# col :
+#  1 : ID
+#  2 : Name
+#  3:ncol : cultivars
+#  ncol+1 : Landscape proportions
+checkCroptypesTable <- function(data) {
+  isok <- TRUE
+  ## croptype ID
+  shiny::removeUI(selector = "#croptypeIdError")
+  if( sum(is.na(as.numeric(data[,"croptypeID"]))) != 0 || length(unique(data[,"croptypeID"])) != length(data[,"croptypeID"]) ) {
+    showErrorMessage(id = "croptypeIdError", selectorafter= "#generateLandscape",
+                     message = "Croptype Id have to be a unique numeric")
+    isok <- FALSE
+  }
+  
+  ## croptype name
+  shiny::removeUI(selector = "#croptypeNameError")
+  if( sum(as.character(data[,"croptypeName"]) == "") != 0 | sum(grepl("^\\s*$",as.character(data[,"croptypeName"]))) != 0) {
+    
+    showErrorMessage(id = "croptypeNameError", selectorafter= "#generateLandscape",
+                     message = "Croptype name have to be a string")
+    #shinyjs::disable(id = "generateLandscape")
+  }
+  
+  ## croptypes cultivars proportions
+    shiny::removeUI(selector = "#croptypeError")
+    ## no cultivars
+    if( ncol(data) <= 2) {
+      showErrorMessage( id = "croptypeError", selectorafter = "#generateLandscape",
+                        message = paste0("There is no cultivars defined"))
+      isok <- FALSE
+    }
+    else{
+      value <- as.matrix(data[,c(3:ncol(data))], nrow = nrow(data) )
+      
+      if( sum(as.numeric(value) < 0.0) != 0 | sum(as.numeric(value) > 1.0) != 0 ) {
+        showErrorMessage( id = "croptypeError", selectorafter = "#generateLandscape",
+                          message = paste0("The Cultivars proportions in a Croptype should be between 0 and 1 (0% and 100%)"))
+        isok <- FALSE
+      }
+      else {
+        sum_prop <- sapply(1:nrow(value), FUN = function(i) { !isTRUE(all.equal(sum(as.numeric(value[i,])),1))}) 
+        #message(sum_prop)
+        if (sum(sum_prop) != 0 ) {
+          showErrorMessage(id = "croptypeError", selectorafter = "#generateLandscape",
+                           message =  paste0("The Cultivars proportions in a Croptype should be equal to 1 (100%)"))
+          isok <- FALSE
+        }
+      }
+    }
+    
+  return(invisible(isok))
+  
+}
+
+## Check croptypes Table
+# col :
+#  1 : Name
+#  2:ncol : parameters
+checkCultivarsTable <- function(data) {
+  isok <- TRUE
+  
+  if( sum(as.character(data[,1]) == "") != 0 | sum(grepl("^\\s*$",as.character(data[,1]))) != 0) {
+    
+    showErrorMessage(id = "cultivarsNameError", selectorafter= "#generateLandscape",
+                     message = "Cultivars name have to be a string")
+    #shinyjs::disable(id = "generateLandscape")
+  }
+  
+  
+  return(invisible(isok))
+  
+}
+
+
+## Check Cultivars Genes Table
+# col :
+#  rownames : Cultivars Name
+#  1:ncol : Genes names
+# value 0 or 1
+checkCultivarsGenesTable <- function(data){
+  isok <- TRUE
+  
+  return(invisible(isok))
+}
+
+## Check Genes Table
+# col :
+#  1 : Genes name Name
+#  2:ncol : Genes parameters
+checkGenesTable <- function(data){
+  isok <- TRUE
+  
+  if( sum(as.character(data[,1]) == "") != 0 | sum(grepl("^\\s*$",as.character(data[,1]))) != 0) {
+    
+    showErrorMessage(id = "GenesNameError", selectorafter= "#generateLandscape",
+                     message = "Genes name have to be a string")
+    #shinyjs::disable(id = "generateLandscape")
+  }
+  
+  return(invisible(isok))
+}
+
+
+### CheckAll Tables
+### Will check tables value visible by user
+checkAllTables <- function(){
+  isok <- TRUE
+  
+  isok <- isok && checkCroptypesTable(simul_params_croptypes())
+  isok <- isok && checkCultivarsTable(simul_params_cultivars())
+  isok <- isok && checkCultivarsGenesTable(simul_params_cultivarsgenes())
+  isok <- isok && checkGenesTable(simul_params_genes())
+  
+  return(isok)
+}
+
+
 loadDemoMO <- function(params){
   gene1 <- loadGene(name="MG 1", type="majorGene")
   gene2 <- loadGene(name="MG 2", type="majorGene")
@@ -156,8 +311,65 @@ PercentageInput <- function(inputId, label, value) {
   )
 }
 
+
+genCroptypesTable <- function(dt, proportions, mode = FALSE) {
+  #proportions <- rep(round(1/nrow(dt), 2),nrow(dt))
+  sum_prop <- sum(proportions)
+  if (!isTRUE(all.equal(sum_prop,1)) || is.na(sum_prop)) {
+    proportions[1] <- proportions[1] + 0.01  
+  }
+  
+  
+  if( mode == 0 ) {
+    disableCols = names(dt)
+  }
+  else disablesCols = c()
+  
+  
+  croptypesTable <- editableDTServer(
+    id = "croptypes",
+    DTdata = shiny::reactive(cbind(dt, data.frame(Proportions=proportions))),
+    disableCol = disableCols,
+    canRm = mode
+  )
+  
+  shiny::observeEvent(croptypesTable$value,
+                      {
+                        message("Croptypes update")
+                        
+                        if (sum(is.na(croptypesTable$value))) {
+                           return(1)
+                        }
+                        
+                        
+                        message("i ",croptypesTable$data)
+                        message("i ",croptypesTable$value)
+                        message("i ",croptypesTable$row)
+                        message("j", croptypesTable$col)
+                      
+                        # Proportions col
+                        if(croptypesTable$col == 6 ) {
+                          message("prop inda ", croptypesTable$data[,"Proportions"])
+                          croptypes_proportions <<- croptypesTable$data[,"Proportions"]
+                          ProportionValidation()
+                        }
+                        
+                            # shinyalert::shinyalert(
+                            #   title = "Erreur",
+                            #   text = error$message,
+                            #   closeOnEsc = TRUE)
+                      
+                      },
+                      ignoreNULL = TRUE,
+                      ignoreInit = TRUE
+  )
+  
+  return(croptypesTable)
+}
+
+
 # Take a table of 3 croptype with 3 cultivars and render it
-RenderCroptypes <- function(dt) {
+RenderCroptypesold <- function(dt) {
   DT::renderDT(
     dt,
     editable = list(target = "row", disable = list(columns = c(0, 10))),

inst/shiny-landsepi/modules/editableDT.R

+# Module DT editable #
+# Permet d'afficher un tableau
+# et d'editer les valeurs
+#
+# ui.R : editableDTUI("montableau")
+# server.R :
+# mon_tableau_modifie <- callModule(editableDT, id = "montableau", DTdata = mon_tableau, disableCol = c("colonnes","non","modifiable"))
+# observeEvent(mon_tableau_modifie$data, { message("mon tableau a ete modifie") })
+#
+####
+## !!! ATTENTION !!!
+## DT input$ retourne les indices de colonnes en commençant par 0
+## Cela est du au faite qu'on n'affiche pas le nom de la ligne rownames = FALSE
+## donc l'indice 2 dans R sera à 1 pour DT
+####
+
+# Ajout un bouton de suppression a chaque ligne du DT
+# Param df le data.frame
+# Param id un id pour le boutton
+# Param mns le ns du module avec l'event id "module_clickbutton"
+deleteButton <- function(df, id, mns, ...) {
+  f <- function(i) {
+    as.character(
+      shiny::actionButton(
+        paste(id, i, sep = "_"),
+        label = NULL,
+        icon = shiny::icon("trash"),
+        onclick = paste0('Shiny.setInputValue(\"', mns, '\", this.id, {priority: \"event\"})')
+      )
+    )
+  }
+
+  deleteCol <- character(0)
+  if (nrow(df) > 0) {
+    deleteCol <- unlist(lapply(seq_len(nrow(df)), f))
+  }
+
+  return(data.frame(delete = deleteCol))
+}
+
+
+
+# UI Part
+editableDTUI <- function(id) {
+  ns <- shiny::NS(id)
+  DT::DTOutput(outputId = ns("tableEDT"))
+}
+
+# Server Part
+# Param DTdata a reactive data.frame
+# Param disableCol reactiveVal for colnames not editable
+# Param canRM reactiveVal TRUE add delete button otherwise not
+# Param rownames TRUE if show rownames FALSE otherwise
+editableDTServer <- function(id, DTdata, disableCol = shiny::reactiveVal(c()), canRm = shiny::reactiveVal(TRUE), rownames = FALSE) {
+  moduleServer(
+    id,
+    function(input, output, session) {
+      ns <- session$ns
+    
+      # la donnee devient reactive pour pouvoir la retourner et l'invalider
+      # en gros on peut utiliser rv en sortie de editableDT
+      # et surveiller rv$data coté serveur pour voir les modifs
+      # rv <- shiny::reactiveValues(data = isolate({DTdata()}), value = "", row = NA, col = NA)
+      rv <- shiny::reactiveValues(data = NULL, value = NULL, row = NA, col = NA)
+      # render DT pour UI
+      output$tableEDT <- DT::renderDT(
+        {
+          #rv$data <- DTdata()
+          if (canRm()) {
+            rv$data <- cbind(DTdata(), deleteButton(DTdata(), "button", ns("deletePressed")))
+          } else {
+            rv$data <- DTdata()
+          }
+        },
+        rownames = rownames,
+        ## if show rownames cols indice start at 0
+        ## otherwise it start at 1
+        editable = { if( rownames ) {
+          if(canRm()) temp = list(target = "cell", disable = list(columns = c(0,(match(disableCol(), names(DTdata()))), ncol(DTdata())+1)))
+          else temp = list(target = "cell", disable = list(columns = c(0,match(disableCol(), names(DTdata())))))
+        }
+        else {
+          if(canRm()) temp = list(target = "cell", disable = list(columns = c((match(disableCol(), names(DTdata()))-1), ncol(DTdata()))))
+          else temp = list(target = "cell", disable = list(columns = c(match(disableCol(), names(DTdata()))-1)))
+        }
+          #print(temp)
+          temp
+          },
+          #editable = list(target = "cell"),
+        selection = "none",
+        escape = FALSE,
+        server = TRUE,
+        #extensions = list('FixedColumns'=NULL, 'Buttons'=NULL),
+        extensions = list( 'Buttons'=NULL),
+        options = list(
+          dom = if (canRm()) { 'tB'} else "t",
+          scrollX = TRUE,
+          #fixedColumns = TRUE,
+          buttons = list(list( extend = "collection", text="Add line", icon = shiny::icon("plus"),
+                                action = DT::JS(paste0("function ( e, dt, node, config ) {
+                                      Shiny.setInputValue('",id,"-addLine","', true,{priority: 'event'});
+                                   }"))))
+        )
+      )
+
+    
+      # Le proxy pour les MAJ
+      proxy <- DT::dataTableProxy(outputId = "tableEDT", session = session)
+    
+      # Une cellule est édité
+      shiny::observeEvent(input$tableEDT_cell_edit, {
+        #message(input$tableEDT_cell_edit)
+    
+        thecell <- input$tableEDT_cell_edit
+
+        isolate({
+          i <- thecell$row
+          if(rownames){
+            j <- thecell$col
+            if(j == 0) rownames(rv$data)[i] <- thecell$value
+            else rv$data[i, j] <-  DT::coerceValue(thecell$value, rv$data[i, j])
+            rv$value <- thecell$value
+            rv$row <- i
+            rv$col <- j
+          }
+          else {
+            j <- thecell$col + 1 ### ATTENTION DT retourne les indices de columns en JS ca commence à 0
+            rv$data[i, j] <- DT::coerceValue(thecell$value, rv$data[i, j])
+            rv$value <- rv$data[i, j]
+            rv$row <- i
+            rv$col <- j
+          }
+        })
+        
+        # on met à jour rv$data pour être à jour coté serveur
+        # shiny::isolate({
+        #   rv$data[i, j] <- DT::coerceValue(thecell$value, rv$data[i, j])
+        #   rv$value <- rv$data[i, j]
+        #   rv$row <- i
+        #   rv$col <- j
+        # })
+        ## force reactive value return
+        #shiny::observe({ rv$value <- rv$data[i, j]})
+        # on met a jour le tableau cote client (normalement il n'y a pas de changement mais ca sera à jour)
+        # DT::replaceData(proxy = proxy, data = rv$data(), resetPaging = FALSE, rownames = FALSE)
+      })
+    
+      # On assume que du moment qu'on peut ajouter une ligne on peut en supprimer une via la 
+      # colonne delete
+      shiny::observeEvent(input$addLine, {
+        print("addLine")
+
+        nbcol <-  ncol( rv$data)
+        namecol <- colnames(rv$data)
+        if(! 'delete' %in% names(rv$data) )
+        {
+          nbcol <-  nbcol+1
+          namecol <- c(colnames(rv$data),"delete")
+        }
+        newline <- matrix(rep(c("999"), nbcol), byrow = TRUE, ncol = nbcol)
+        colnames(newline) <- namecol
+        newline[nbcol] <- as.character(
+          shiny::actionButton(
+            paste("button", nrow(rv$data)+1, sep = "_"),
+            label = NULL,
+            icon = shiny::icon("trash"),
+            onclick = paste0('Shiny.setInputValue(\"', ns("deletePressed"), '\", this.id, {priority: \"event\"})')
+          )
+        )
+        #DT::addRow(proxy,newline) # addRow bug, du coup on met a jour tout le tableau "server=FALSE"
+        shiny::isolate(rv$data <- rbind(rv$data, newline))
+        print(rv$data)
+        # if (canRm() == TRUE) {
+        #   proxy %>%
+        #     DT::replaceData(data = cbind(rv$data, deleteButton(rv$data, "button", ns("deletePressed"))), resetPaging = FALSE, rownames = FALSE)
+        # } else {
+          proxy %>%
+            DT::replaceData(data = rv$data, resetPaging = TRUE, rownames=rownames)
+        # }
+      })
+    
+      shiny::observeEvent(input$deletePressed, {
+        id <- as.integer(sub(".*_([0-9]+)", "\\1", input$deletePressed))
+        shinyalert::shinyalert(
+          paste0("!!! Remove line ",id,"!!!"),
+          "Are you sure ?",
+          closeOnEsc = FALSE,
+          showCancelButton = TRUE,
+          callbackR = function(x) {
+            if (x == TRUE) {
+              rv$row <- id
+              rv$value <- rv$data[rv$row, ]
+              rv$data <- rv$data[-rv$row, ,drop = FALSE]
+              rv$col <- 0
+              
+              shiny::isolate(rv$data <- cbind(rv$data[,-ncol(rv$data), drop=FALSE], deleteButton(rv$data, "button", ns("deletePressed"))))
+              proxy %>%
+                DT::replaceData(data = rv$data, resetPaging = TRUE, rownames=rownames)
+            }
+          }
+        )
+      })
+      
+      return(rv)
+      #return(reactive({c(rv$data, rv$row, rv$col, rv$value)}))
+    }
+  )
+}

inst/shiny-landsepi/ui.R

 library(shiny)
 library(DT)
 library(shinyjs)
+library(shinyalert)
 
 # UI
 ######################################################################################
@@ -42,40 +43,25 @@ landscapeTab <- {
     hr(),
     shiny::fluidRow(
       tags$div(lang="en",
-               column(
-                 width = 3,
-                 PercentageInput(
-                   inputId = "prop0",
-                   label = "C0 proportion",
-                   value =  0.33
-                 )
-               ),
-               column(
-                 width = 3,
-                 PercentageInput(
-                   inputId = "prop1",
-                   label = "C1 proportion",
-                   value =  0.33
-                 )
-               ),
-               column(
-                 width = 3,
-                 PercentageInput(
-                   inputId = "prop2",
-                   label = "C2 proportion",
-                   value =  0.34
-                 )
-               )
+                 h3("Croptypes"),
+                 editableDTUI(id = "croptypes")
       ),
+      hr(),
       column(
-        width = 3,
+        width = 4,
         IntegerInput(
           inputId = "rotationPeriod",
           label = "Rotation period (years)",
           value = 1,
           max = 50
         )
-      )
+      ),
+      column(
+        width = 3,
+        align = "left",
+        p("1st rotation : 0 and 1"),
+        p("2nd rotation : 0 and 2")
+        )
     ),
     hr(),
     shiny::fluidRow(
@@ -112,15 +98,146 @@ landscapeTab <- {
 ######################################################################################
 cultivarTab <- {
   shiny::tabPanel(
-    "Croptypes and Cultivars",
-    DT::DTOutput(outputId = "croptypes"),
-    hr(),
-    DT::DTOutput(outputId = "cultivars")
+    "Cultivars and genes",
+    h3("Cultivars"),
+    editableDTUI(id = "cultivars"),
+    h3("Cultivars and Genes"),
+    editableDTUI(id = "cultivarsgenes"),
+    h3("Genes"),
+    editableDTUI(id = "genes"),
+  )
+}
+
+######################################################################################
+pathogenTab <- {
+  shiny::tabPanel(
+    "Pathogen",
+    shiny::div(
+      shiny::selectInput(
+        inputId = "defaultPathogen",
+        label = "Default Pathogens",
+        choices = list(
+          "Rust" = "Rust"
+        ),
+        width = "25%"
+      ),
+      align = "center"
+    ),
+    shiny::fluidRow(
+      shiny::numericInput(
+        inputId = "inoculum",
+        label = "Initial Prob. for the first host to be infectious",
+        value = 0.0001,
+        min = 0.0,
+        max = 1.0,
+        step = 0.0001
+      )
+    ),
+    shiny::fluidRow(
+      column(
+        width = 4,
+        shiny::numericInput(
+          inputId = "patho_survival_prob",
+          label = "Prob. for propagule to survive the off-season",
+          value = 0.0001,
+          min = 0.0001,
+          max = 1.0,
+          step = 0.0001
+        ),
+        shiny::numericInput(
+          inputId = "patho_repro_sex_prob",
+          label = "Prob. for an infectious host to reporduce via sex rather than clonal",
+          value = 0,
+          min = 0.0,
+          max = 1.0,
+          step = 0.10
+        ),
+        shiny::numericInput(
+          inputId = "patho_infection_rate",
+          label