Skip to content
GitLab
Commit 100a5486 authored by Jean-Francois Rey's avatar Jean-Francois Rey ☕
Browse files

shiny editable 

add col incrementation parameter
add default value parameters
parent b7fc59fa
Hide whitespace changes
Inline Side-by-side
inst/shiny-landsepi/global.R
View file @ 100a5486
......@@ -414,18 +414,18 @@ PercentageInput <- function(inputId, label, value) {
#################################################################
### Tooltip message
#################################################################
SIGMOID_SIGMA <- "sigma parameter of the sigmoid contamination function"
SIGMOID_KAPPA <- "kappa parameter of the sigmoid contamination function"
INFECTIOUS_PERIOD_VAR <- "variance of the infectious period duration"
INFECTIOUS_PERIOD_EXP <- "maximal expected duration of the infectious period"
LATENT_PERIOD_VAR <- " variance of the latent period duration"
LATENT_PERIOD_EXP <- "minimal expected duration of the latent period"
PROPAGULE_PROD_RATE <- "maximal expected effective propagule production rate of an infectious host per time step"
INFECTION_RATE <- "maximal expected infection rate of a propagule on a healthy host"
SURVIVAL_PROB <- "probability for a propagule to survive the off-season"
INOCULUM <- "initial probability for the first host (whose index is 0) to be infectious (i.e. state I) at the beginning of the simulation."
GENERATE_LANDSCAPE <- "Generates a landscape composed of fields where croptypes are allocated with controlled proportions and spatio-temporal aggregation."
SIGMOID_SIGMA <- "Sigma parameter of the sigmoid contamination function"
SIGMOID_KAPPA <- "Kappa parameter of the sigmoid contamination function"
INFECTIOUS_PERIOD_VAR <- "Variance of the infectious period duration"
INFECTIOUS_PERIOD_EXP <- "Maximal expected infectious period duration"
LATENT_PERIOD_VAR <- "Variance of the latent period duration"
LATENT_PERIOD_EXP <- "Minimal expected latent period duration"
PROPAGULE_PROD_RATE <- "Maximal expected effective propagule production rate per timestep and per infectious individual"
INFECTION_RATE <- "Maximal expected infection rate of a propagule on a healthy individual"
SURVIVAL_PROB <- "Off-season survival probability of a propagule"
INOCULUM <- "Initial probability for the first host (usually parameterised as a susceptible cultivar) to be infectious (state I) at the beginning of the simulation"
GENERATE_LANDSCAPE <- "Generates a landscape composed of fields where croptypes are allocated with controlled proportions and spatio-temporal aggregation"
RUN_SIMULATION <- "Run the simulation, depending of the parameters it can be long"
STOP_SIMULATION <- "Force to stop the simulation"
EXPORT_SIMULATION <- "Download a GPKG containing most of the parameters"
ROTATION_PERIOD <- "Croptypes rotation period in years. Will switch between 0 and 1 croptypes and 0 and 2 croptypes each period time. 0 mean no rotation."
\ No newline at end of file
ROTATION_PERIOD <- "Croptypes rotation period in years. Will switch between 0 and 1 croptypes and 0 and 2 croptypes each period time. 0 mean no rotation"
\ No newline at end of file
inst/shiny-landsepi/modules/editableDT.R
View file @ 100a5486
......@@ -52,7 +52,10 @@ editableDTUI <- function(id) {
# Param canRM reactiveVal TRUE add delete button otherwise not
# Param rownames TRUE if show rownames FALSE otherwise
# Param tooltips header tooltips message
editableDTServer <- function(id, DTdata, disableCol = shiny::reactiveVal(c()), canRm = shiny::reactiveVal(TRUE), rownames = FALSE, tooltips = NULL) {
# Param row.default a default row (when adding a new line) depending of row.cols if not all cols existing
# Param row.colsid list of columns that apply row.default
# Param row.inc list of columns to incremente value at new line
editableDTServer <- function(id, DTdata, disableCol = shiny::reactiveVal(c()), canRm = shiny::reactiveVal(TRUE), rownames = FALSE, tooltips = NULL, row.default = NULL, row.colsid = NULL, row.inc = NULL) {
moduleServer(
id,
function(input, output, session) {
......@@ -92,11 +95,11 @@ editableDTServer <- function(id, DTdata, disableCol = shiny::reactiveVal(c()), c
escape = FALSE,
server = TRUE,
#extensions = list('FixedColumns'=NULL, 'Buttons'=NULL),
extensions = list( 'Buttons'=NULL),
extensions = list( 'FixedColumns'=NULL, 'Buttons'=NULL),
options = list(
dom = if (canRm()) { 'tB'} else "t",
scrollX = TRUE,
#fixedColumns = 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'});
......@@ -168,6 +171,16 @@ editableDTServer <- function(id, DTdata, disableCol = shiny::reactiveVal(c()), c
}
newline <- matrix(rep(c("0"), nbcol), byrow = TRUE, ncol = nbcol)
# if default value exists
if( !is.null(row.default) ){
if( is.null(row.colsid)) newline <- row.default
else {
j <- 1
lapply(row.colsid, FUN = function(x){newline[x] <<- row.default[j];j<<-j+1;})
}
}
#print(newline)
newline[nbcol] <- as.character(
shiny::actionButton(
paste("button", nrow(rv$data)+1, sep = "_"),
......@@ -178,7 +191,21 @@ editableDTServer <- function(id, DTdata, disableCol = shiny::reactiveVal(c()), c
)
newline <- as.data.frame(newline)
colnames(newline) <- namecol
# incremente cols
if( !is.null(row.inc) ) {
lapply(row.inc, function(x){
if( is.na(as.numeric(newline[x])) ) {newline[x] <<- paste0(newline[x],nrow(rv$data)+1)}
else{
val <- max(sort(as.numeric(rv$data[,x]))) +1
newline[x] <<- val
}
})
}
sapply(1:nbcol, function(i){class(newline[,i]) <<- class(rv$data[,i]); mode(newline[,i]) <<- mode(rv$data[,i]); })
#print(sapply(newline,mode))
#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))
......@@ -188,7 +215,7 @@ editableDTServer <- function(id, DTdata, disableCol = shiny::reactiveVal(c()), c
# 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)
DT::replaceData(data = rv$data, resetPaging = FALSE, rownames=rownames)
# }
})
......@@ -208,7 +235,7 @@ editableDTServer <- function(id, DTdata, disableCol = shiny::reactiveVal(c()), c
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)
DT::replaceData(data = rv$data, resetPaging = FALSE, rownames=rownames)
}
}
)
......
inst/shiny-landsepi/server.R
View file @ 100a5486
......@@ -128,6 +128,13 @@ server <- function(input, output, session) {
}
return(invisible(TRUE))
}
## Print Rotation labels
setRotationText <- function(list_name=NULL) {
text <- paste0("<u>1st rotation</u> : 0 (<b>",list_name[1],"</b>) and 1 (<b>",list_name[2],"</b>) croptypes")
text <- paste0(text, "<br/><u>2st rotation</u> : 0 (<b>",list_name[1],"</b>) and 2 (<b>",list_name[3],"</b>) croptypes")
text
}
#############################################################################
# Observe EVENT
......@@ -170,6 +177,7 @@ server <- function(input, output, session) {
advanced_mode(!advanced_mode())
if (advanced_mode()) {
printVerbose("enable mode edition", level=3)
removeCssClass("Mode","btn-default")
shinyjs::disable(id = "demo")
shinyjs::enable(id = "rotationPeriod")
shinyjs::enable(id = "patho_infection_rate")
......@@ -186,6 +194,7 @@ server <- function(input, output, session) {
}
else {
printVerbose("disable mode edition", level=3)
addCssClass("Mode","btn-default")
shinyjs::disable(id = "rotationPeriod")
shinyjs::enable(id = "demo")
shinyjs::disable(id = "patho_infection_rate")
......@@ -806,6 +815,8 @@ server <- function(input, output, session) {
else if (input$demo == "PY") {
shiny::updateSelectInput(session, "aggregLevel", selected = "low")
}
output$rotationText <- renderUI({HTML(setRotationText(simul_params@Croptypes[,2]))})
})
###################
......@@ -829,7 +840,10 @@ server <- function(input, output, session) {
}),
canRm = advanced_mode,
rownames = FALSE,
tooltips = c("Croptypes ID (start at 0)","Croptypes Name")
tooltips = c("Croptypes ID (start at 0)","Croptypes Name"),
row.default = simul_params@Croptypes[1,c(1,2)],
row.cols = 1:2,
row.inc = c(1,2)
)
##### croptypes table modification #####
......@@ -860,6 +874,7 @@ server <- function(input, output, session) {
can_gen_landscape$croptypeID <<- FALSE
}
else {
output$rotationText <- renderUI({HTML(setRotationText(croptypesTable$data[, 2]))})
simul_params <<- setCroptypes(simul_params, croptypesTable$data[, 1:(ncol(croptypesTable$data) - 2)])
can_run_simul$croptypes <<- TRUE
can_gen_landscape$croptypeID <<- TRUE
......@@ -884,7 +899,9 @@ server <- function(input, output, session) {
}),
canRm = advanced_mode,
rownames = FALSE,
tooltips = c("Cultivars Names")
tooltips = c("Cultivars Names"),
row.default = simul_params@Cultivars[1,],
row.inc = c(1)
)
##### cultivars table modification #####
......@@ -975,6 +992,7 @@ server <- function(input, output, session) {
}
else {
simul_params@CultivarsGenes <- cultivars_genesTable$data
print(simul_params@CultivarsGenes)
simul_params_cultivarsgenes(simul_params@CultivarsGenes)
can_run_simul$cultivarsgenes <<- TRUE
}
......@@ -998,7 +1016,9 @@ server <- function(input, output, session) {
}),
canRm = advanced_mode,
rownames = FALSE,
tooltips = c("Genes Names")
tooltips = c("Genes Names"),
row.default = simul_params@Genes[1,],
row.inc = c(1)
)
##### Genes table modification #####
......@@ -1025,6 +1045,7 @@ server <- function(input, output, session) {
# remove line -> remove genes in cultivars genes
if (genesTable$col == 0 && nrow(simul_params@Genes) > nrow(genesTable$data)) {
simul_params@CultivarsGenes <<- simul_params@CultivarsGenes[, -c(genesTable$row), drop = FALSE]
printVerbose(paste0("set Cultivars Genes",simul_params@CultivarsGenes))
}
# add line -> add a genes in cultivars genes
if (nrow(simul_params@Genes) < nrow(genesTable$data)) {
......
inst/shiny-landsepi/ui.R
View file @ 100a5486
......@@ -26,6 +26,7 @@ landscapeTab <- {
selected = 1,
)
),
shinyBS::bsTooltip("landscape",title="Landscape Shapefile", placement = "bottom", trigger="hover"),
column(
width = 6,
shiny::selectInput(
......@@ -40,6 +41,7 @@ landscapeTab <- {
)
)
),
shinyBS::bsTooltip("aggregLevel",title="Level of spatial aggregation of the landscape", placement = "bottom", trigger="hover"),
hr(),
shiny::fluidRow(
tags$div(lang="en",
......@@ -58,10 +60,9 @@ landscapeTab <- {
),
shinyBS::bsTooltip("rotationPeriod",title=ROTATION_PERIOD, placement = "bottom", trigger="hover"),
column(
width = 3,
width = 8,
align = "left",
p("1st rotation : 0 and 1 croptypes"),
p("2nd rotation : 0 and 2 croptypes")
htmlOutput("rotationText")
)
),
hr(),
......@@ -75,6 +76,7 @@ landscapeTab <- {
max = 50
)
),
shinyBS::bsTooltip("nYear",title="Number of cropping seasons (e.g. years)", placement = "bottom", trigger="hover"),
column(
width = 4,
IntegerInput(
......@@ -84,6 +86,7 @@ landscapeTab <- {
max = 365
)
),
shinyBS::bsTooltip("nTSpY",title="Number of time steps per cropping season (e.g. days)", placement = "bottom", trigger="hover"),
column(
width = 4,
IntegerInput(
......@@ -140,7 +143,7 @@ pathogenTab <- {
width = 4,
shiny::numericInput(
inputId = "patho_survival_prob",
label = "Prob. for propagule to survive the off-season",
label = "Off-season survival probability",
value = 0.0001,
min = 0.0001,
max = 1.0,
......@@ -157,7 +160,7 @@ pathogenTab <- {
# ),
shiny::numericInput(
inputId = "patho_infection_rate",
label = "Max expected infection rate of a propagule on a healthy host",
label = "Maximal : infection rate of a propagule",
value = 0.4,
min = 0.0,
max = 2.0,
......@@ -166,7 +169,7 @@ pathogenTab <- {
shinyBS::bsTooltip("patho_infection_rate",title=INFECTION_RATE, placement = "right", trigger="hover"),
shiny::numericInput(
inputId = "patho_propagule_prod_rate",
label = "Max expected effective propagule production rate of an infectious host per time step",
label = "Maximal : propagule production rate",
value = 3.125,
min = 0.0,
step = 0.4
......@@ -177,7 +180,7 @@ pathogenTab <- {
width = 4,
shiny::numericInput(
inputId = "patho_latent_period_exp",
label = "Min expected duration of the latent period",
label = "Minimal : latent period duration",
value = 10,
min = 0,
max = 100,
......@@ -186,7 +189,7 @@ pathogenTab <- {
shinyBS::bsTooltip("patho_latent_period_exp",title=LATENT_PERIOD_EXP, placement = "left", trigger="hover"),
shiny::numericInput(
inputId = "patho_latent_period_var",
label = "Variance of the latent period duration",
label = "Variance : latent period duration",
value = 9,
min = 0.0,
max = 100,
......@@ -195,7 +198,7 @@ pathogenTab <- {
shinyBS::bsTooltip("patho_latent_period_var",title=LATENT_PERIOD_VAR, placement = "left", trigger="hover"),
shiny::numericInput(
inputId = "patho_infectious_period_exp",
label = "Max expected duration of the infectious period",
label = "Maximal : infectious period duration",
value = 24,
min = 0,
max = 365,
......@@ -204,7 +207,7 @@ pathogenTab <- {
shinyBS::bsTooltip("patho_infectious_period_exp",title=INFECTIOUS_PERIOD_EXP, placement = "left", trigger="hover"),
shiny::numericInput(
inputId = "patho_infectious_period_var",
label = "Variance of the infectious period duration",
label = "Variance : infectious period duration",
value = 105,
min = 0,
step = 1
......@@ -215,7 +218,7 @@ pathogenTab <- {
width = 4,
shiny::numericInput(
inputId = "patho_sigmoid_kappa",
label = "Kappa parameter of the sigmoid contamination function",
label = "Kappa : sigmoid contamination function",
value = 5.333,
min = 0.0001,
max = 10,
......@@ -224,7 +227,7 @@ pathogenTab <- {
shinyBS::bsTooltip("patho_sigmoid_kappa",title=SIGMOID_KAPPA, placement = "left", trigger="hover"),
shiny::numericInput(
inputId = "patho_sigmoid_sigma",
label = "Sigma parameter of the sigmoid contamination function",
label = "Sigma : sigmoid contamination function",
value = 3,
min = 0.0,
max = 100,
......@@ -265,6 +268,7 @@ inputUi <- {
),
align = "center"
),
shinyBS::bsTooltip("demo",title="Load existing parameters or click Advanced Mode", placement = "bottom", trigger="hover"),
shiny::tabsetPanel(id = "inputtabpanel", landscapeTab, cultivarTab, pathogenTab),
width = 12,
align = "center"
......@@ -312,8 +316,11 @@ ui <- {
shiny::br(),
fluidRow(
actionButton("showInputside", label = "", icon = icon("wpforms")),
shinyBS::bsTooltip("showInputside",title="Only show parameters", placement = "bottom", trigger="hover"),
actionButton("showBothside", label = "", icon = icon("columns")),
shinyBS::bsTooltip("showBothside",title="Show both, parameters and outputs", placement = "bottom", trigger="hover"),
actionButton("showOutputside", label = "", icon = icon("chart-line") ),
shinyBS::bsTooltip("showOutputside",title="Only show outputs", placement = "bottom", trigger="hover"),
align="center"
),
shiny::br(),
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment

Mentions Légales et CGU