Commit 59552c1b authored by Jean-Francois Rey's avatar Jean-Francois Rey
Browse files

Merge branch 'shinyv2' into 'master'

Béta version 2 shiny app

See merge request CSIRO-INRA/landsepi_dev!10
parents 0b71a993 cba72f77
......@@ -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
......@@ -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))),
......
# 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)}))
}
)
}
This diff is collapsed.
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",