Newer
Older
###################################################
## Fixed parameters in the server environment
##-------------------------------------------------
## Load species list
species_data <- read.csv("./inst/ShinyApp/species_list.csv", sep = ",")
## Load survival and fecundities data
data_sf <- read.csv("./inst/ShinyApp/survivals_fecundities_species.csv", sep = ",")#, encoding = "UTF-8")
# We define theta = 1 (same as in PBR) - for simplicity, given large uncertainty of real shape of density-dependence in nature
fixed_theta = 1
# Coefficient of environmental variation (SD)
## Environnmental variance set at 8%, based on values found for birds in the literature:
## (Saeher & Engen 2002) : between 7% et 14 ==> average : 10%
## (Sther et al. 2005) : between 2.5% et 10% ==> average : 6%
coeff_var_environ = sqrt(0.08) # SD ~28%
# Coverage probability used for lower/upper interval input values
CP = 0.99
# Values of pop_growth (assumed), when the "trend" option is chosen
growth_weak <- 1.05
growth_average <- 1.10
growth_strong <- 1.15
decline_weak <- 0.97
decline_average <- 0.94
decline_strong <- 0.91
pop_stable <- 1
trend_se <- 0.05 # SE to use for pop_growth, when the "trend" option is chosen
##############################################
## Hide/Show : level 1
## Fatalities
output$hide_fatalities <- eventReactive({
input$button_fatalities
},{
if(input$button_fatalities%%2 == 1) TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_fatalities", suspendWhenHidden = FALSE)
## Population Size
output$hide_pop_size <- eventReactive({
input$button_pop_size
},{
if(input$button_pop_size%%2 == 1) TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_pop_size", suspendWhenHidden = FALSE)
## Population Growth
output$hide_pop_growth <- eventReactive({
input$button_pop_growth
},{
if(input$button_pop_growth%%2 == 1) TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_pop_growth", suspendWhenHidden = FALSE)
## Carrying capacity
output$hide_carrying_cap <- eventReactive({
input$button_carrying_cap
},{
if(input$button_carrying_cap%%2 == 1) TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_carrying_cap", suspendWhenHidden = FALSE)
# Display Carrying capacity Unit Info
output$carrying_cap_unit_info <- renderText({
if(input$pop_size_unit == "Npair"){
paste0("Nombre de couple")
} else {
paste0("Effectif total")
}
})
## Outputs / Results
output$hide_results <- eventReactive({
input$run
},{
if(input$run > 0) TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_results", suspendWhenHidden = FALSE)
##############################################
## Hide/Show : level 2
#------------
# Hide all
#------------
shinyjs::hide("fatalities_mean")
shinyjs::hide("fatalities_se")

thierrychambert
committed
shinyjs::hide("fatalities_lower")
shinyjs::hide("fatalities_upper")
shinyjs::hide("fatalities_number_expert")
shinyjs::hide("farm_number_cumulated")
shinyjs::hide("fatalities_mat_cumulated")
shinyjs::hide("fatalities_vec_scenario")
shinyjs::hide("pop_size_lower")
shinyjs::hide("pop_size_upper")
shinyjs::hide("pop_size_mean")
shinyjs::hide("pop_size_se")
shinyjs::hide("pop_size_number_expert")
shinyjs::hide("pop_growth_lower")
shinyjs::hide("pop_growth_upper")
shinyjs::hide("pop_growth_mean")
shinyjs::hide("pop_growth_se")
shinyjs::hide("pop_growth_number_expert")
shinyjs::hide("pop_trend")
shinyjs::hide("pop_trend_strength")
shinyjs::hide("carrying_capacity_lower")
shinyjs::hide("carrying_capacity_upper")
shinyjs::hide("carrying_capacity_mean")
shinyjs::hide("carrying_capacity_se")
shinyjs::hide("carrying_cap_number_expert")
shinyjs::hide("carrying_cap_mat_expert")
shinyjs::hide("carrying_cap_run_expert")

thierrychambert
committed
shinyjs::hide("vr_mat_number_age_classes")

thierrychambert
committed
shinyjs::hide("age_class_show")
#------------
# Show some
#------------
# Show inputs for fatalities part
# Show inputs for single farm option (non-cumulated impacts)
if(input$analysis_choice == "single_farm"){
if(input$fatalities_input_type == "itvl"){

thierrychambert
committed
shinyjs::show("fatalities_lower")
shinyjs::show("fatalities_upper")
if(input$fatalities_input_type == "val"){
shinyjs::show("fatalities_mean")
shinyjs::show("fatalities_se")
}
shinyjs::show("fatalities_number_expert")
# Show inputs for cumulated impacts option
shinyjs::hide("fatalities_input_type")
shinyjs::show("farm_number_cumulated")
shinyjs::show("fatalities_mat_cumulated")
# Show inputs for multiple scenario
if(input$analysis_choice == "multi_scenario"){
shinyjs::hide("fatalities_input_type")
shinyjs::show("fatalities_vec_scenario")
}
# Show inputs for population size part
if(input$button_pop_size%%2 == 1){
shinyjs::show("pop_size_input_type")
if(input$pop_size_input_type == "itvl"){
shinyjs::show("pop_size_lower")
shinyjs::show("pop_size_upper")
}
shinyjs::show("pop_size_mean")
shinyjs::show("pop_size_se")
}
shinyjs::show("pop_size_number_expert")
# Show inputs for population trend/growth part
if(input$button_pop_growth%%2 == 1){
shinyjs::show("pop_growth_input_type")
if(input$pop_growth_input_type == "itvl"){
shinyjs::show("pop_growth_lower")
shinyjs::show("pop_growth_upper")
}
shinyjs::show("pop_growth_mean")
shinyjs::show("pop_growth_se")
}
shinyjs::show("pop_growth_number_expert")
if(input$pop_trend != "stable"){
shinyjs::show("pop_trend_strength")
}
# Show inputs for carrying capacity part
if(input$button_carrying_cap%%2 == 1){
shinyjs::show("carrying_cap_input_type")
if(input$carrying_cap_input_type == "itvl"){
shinyjs::show("carrying_capacity_lower")
shinyjs::show("carrying_capacity_upper")
}
if(input$carrying_cap_input_type == "val"){
shinyjs::show("carrying_capacity_mean")
shinyjs::show("carrying_capacity_se")
}
if(input$carrying_cap_input_type == "eli_exp"){
shinyjs::show("carrying_cap_number_expert")
shinyjs::show("carrying_cap_mat_expert")
shinyjs::show("carrying_cap_run_expert")
}
}
# Show inputs vital rates part

thierrychambert
committed
shinyjs::show("vr_mat_number_age_classes")

thierrychambert
committed
# Show radiobutton (output) for plot_traj graph
if(input$run > 0){
shinyjs::show("age_class_show")
}
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
##############################################
## Reactive values
out <- reactiveValues(run = NULL, run_time = NULL, msg = NULL)

thierrychambert
committed
rv <- reactiveValues(distAVG = NULL, dist = NULL)

thierrychambert
committed
ready <- reactiveValues(fatalities = TRUE, pop_size = TRUE, pop_growth = TRUE, carrying_capacity = TRUE)
nsim = NULL,
cumulated_impacts = FALSE,
fatalities_mean_nb = NULL,
fatalities_se = NULL,
fatalities_se_nb = NULL,
onset_time = NULL,
onset_year = NULL,
pop_size_mean = NULL,
pop_size_se = NULL,
pop_growth_mean = NULL,
pop_growth_mean_use = NULL,
pop_growth_se = NULL,
s_calib0 = NULL,
f_calib0 = NULL,
s_calibrated = NULL,
f_calibrated = NULL,
vr_calibrated = NULL,
carrying_capacity_mean = NULL,
carrying_capacity_se = NULL,
theta = NULL,
model_demo = NULL,
coeff_var_environ = NULL,
fatal_constant = NULL,
fatalities_eli_result = NULL,
pop_size_eli_result = NULL,
pop_growth_eli_result = NULL,
carrying_cap_eli_result = NULL
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
##############################################
## Define some functions
##-------------------------------------------
# Get lambda from +/-X% growth rate
make_lambda <- function(pop_growth) 1 + (pop_growth/100)
#####
#####
##------------------------------------------
## Update elicitation matrices
##------------------------------------------
###############################
## Cumulated Impacts Matrix
##-----------------------------
observeEvent({
input$farm_number_cumulated
}, {
req(input$farm_number_cumulated > 0)
current_mat <- input$fatalities_mat_cumulated
n_farm <- input$farm_number_cumulated
if(n_farm > nrow(current_mat)){
fill_mat <- c(as.vector(t(current_mat)), rep(NA,(3*(n_farm-nrow(current_mat)))))
}else{
fill_mat <- as.vector(t(current_mat[1:n_farm,]))
}
updateMatrixInput(session, inputId = "fatalities_mat_cumulated",
value = matrix(fill_mat, nrow = n_farm, ncol = 3, byrow = TRUE,
dimnames = list(paste("Parc", c(1:n_farm)),
c("Moyenne",
"Erreur-type",
########################
## Fatalities Matrix
##----------------------
observeEvent({
input$fatalities_number_expert
}, {
req(input$fatalities_number_expert > 0)
current_mat <- input$fatalities_mat_expert
n_experts <- input$fatalities_number_expert
if(n_experts > nrow(current_mat)){
fill_mat <- c(as.vector(t(current_mat)), rep(NA,(5*(n_experts-nrow(current_mat)))))
}else{
fill_mat <- as.vector(t(current_mat[1:n_experts,]))
}
updateMatrixInput(session, inputId = "fatalities_mat_expert",
value = matrix(fill_mat, nrow = n_experts, ncol = 5, byrow = TRUE,
dimnames = list(paste0("#", 1:n_experts),
c("Poids", "Min", "Best", "Max", "% IC" ))
)
)
})
#####
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
########################
## Pop Size Matrix
##----------------------
observeEvent({
input$pop_size_number_expert
}, {
req(input$pop_size_number_expert > 0)
current_mat <- input$pop_size_mat_expert
n_experts <- input$pop_size_number_expert
if(n_experts > nrow(current_mat)){
fill_mat <- c(as.vector(t(current_mat)), rep(NA,(5*(n_experts-nrow(current_mat)))))
}else{
fill_mat <- as.vector(t(current_mat[1:n_experts,]))
}
updateMatrixInput(session, inputId = "pop_size_mat_expert",
value = matrix(fill_mat, nrow = n_experts, ncol = 5, byrow = TRUE,
dimnames = list(paste0("#", 1:n_experts),
c("Poids", "Min", "Best", "Max", "% IC" ))
)
)
})
#####
########################
## Pop Growth Matrix
##----------------------
observeEvent({
input$pop_growth_number_expert
}, {
req(input$pop_growth_number_expert > 0)
current_mat <- input$pop_growth_mat_expert
n_experts <- input$pop_growth_number_expert
if(n_experts > nrow(current_mat)){
fill_mat <- c(as.vector(t(current_mat)), rep(NA,(5*(n_experts-nrow(current_mat)))))
}else{
fill_mat <- as.vector(t(current_mat[1:n_experts,]))
}
updateMatrixInput(session, inputId = "pop_growth_mat_expert",
value = matrix(fill_mat, nrow = n_experts, ncol = 5, byrow = TRUE,
dimnames = list(paste0("#", 1:n_experts),
c("Poids", "Min", "Best", "Max", "% IC" ))
)
)
})
#####
############################
## Carrying Capacity Matrix
##--------------------------
observeEvent({
input$carrying_cap_number_expert
}, {
req(input$carrying_cap_number_expert > 0)
current_mat <- input$carrying_cap_mat_expert
n_experts <- input$carrying_cap_number_expert
if(n_experts > nrow(current_mat)){
fill_mat <- c(as.vector(t(current_mat)), rep(NA,(5*(n_experts-nrow(current_mat)))))
}else{
fill_mat <- as.vector(t(current_mat[1:n_experts,]))
}
updateMatrixInput(session, inputId = "carrying_cap_mat_expert",
value = matrix(fill_mat, nrow = n_experts, ncol = 5, byrow = TRUE,
dimnames = list(paste0("#", 1:n_experts),
c("Poids", "Min", "Best", "Max", "% IC" ))
)
)
})
#####
#####
##--------------------------------------------
##--------------------------------------------
# Function to run the elication analysis
func_eli <- function(mat_expert){
t_mat_expert <- t(mat_expert)
vals <- t_mat_expert[2:4,] %>% apply(., 2, sort)
Cp <- t_mat_expert[5,] %>% sapply(., min, 0.99) %>% sapply(., max, 0.2)
weights <- t_mat_expert[1,]
out <- tryCatch(
elicitation(vals, Cp, weights), error = function(e)

thierrychambert
committed
return(NULL)
#message("Erreur : certaines valeurs dans la matrice d'experts n'ont pas de sens")
)
if(!is.null(out)){
OUT <- list(out = out, mean = out$mean_smooth, SE = sqrt(out$var_smooth))
}else{

thierrychambert
committed
OUT <- list(out = NA, mean = NA, SE = NA)
}
return(OUT)
}
# Function to plot the elication analysis output
plot_expert <- function(out, show_se = TRUE, ...){
plot_elicitation(out, ylab = "", xlab = "Valeur du paramtre", cex.lab = 1.2, yaxt = "n")
mtext(text = "Densit de probabilit", side = 2, line = 2, cex = 1.2)
y2 <- dgamma(x = out$mean_smooth, shape = out$shape_smooth, rate = out$rate_smooth)
xx <- qgamma(p = c(0.01,0.99), shape = out$shape_smooth, rate = out$rate_smooth)
clip(xx[1], xx[2], -100, y2)
abline(v = out$mean_smooth, lwd = 3, col = "darkblue")
mtext(text = paste("Moyenne = ", round(out$mean_smooth,2)), side = 3, line = 2.5, cex = 1.2, adj = 0)
if(show_se) mtext(text = paste("Erreur-type = ", round(sqrt(out$var_smooth), 2)), side = 3, line = 1, cex = 1.2, adj = 0)
}
## Fatalities
##----------------------
observeEvent({
input$fatalities_run_expert
}, {
if( all(!is.na(input$fatalities_mat_expert)) ) {
param$fatalities_eli_result <- func_eli(input$fatalities_mat_expert)
output$title_distri_plot <- renderText({ "Mortalits annuelles" })
output$distri_plot <- renderPlot({ plot_expert(param$fatalities_eli_result$out) })
} else {
print("missing value")
} # end if
}) # end observeEvent
## Population size
##----------------------
observeEvent({
input$pop_size_run_expert
}, {
if(all(!is.na(input$pop_size_mat_expert))) {
## run elicitation analysis
param$pop_size_eli_result <- func_eli(input$pop_size_mat_expert)
output$title_distri_plot <- renderText({ "Taille de population" })
output$distri_plot <- renderPlot({ plot_expert(param$pop_size_eli_result$out) })
} else {
print("missing value")
} # end if
}) # end observeEvent
## Population growth
##----------------------
observeEvent({
input$pop_growth_run_expert
},{
if(all(!is.na(input$pop_growth_mat_expert))){
lambda_mat_expert <- input$pop_growth_mat_expert
lambda_mat_expert[,2:4] <- make_lambda(lambda_mat_expert[,2:4])
param$pop_growth_eli_result <- func_eli(lambda_mat_expert)
output$title_distri_plot <- renderText({ "Taux de croissance de la population" })
output$distri_plot <- renderPlot({ plot_expert(param$pop_growth_eli_result$out) })
} else {
print("missing value")
} # end if
}) # end observeEvent
## Carrying capacity
##----------------------
observeEvent({
input$carrying_cap_run_expert
},{
if(all(!is.na(input$carrying_cap_mat_expert))) {
## run elicitation analysis
param$carrying_cap_eli_result <- func_eli(input$carrying_cap_mat_expert)

thierrychambert
committed
if(!is.na(param$carrying_cap_eli_result$out)){
output$title_distri_plot <- renderText({ "Capacit de charge" })
output$distri_plot <- renderPlot({ plot_expert(param$carrying_cap_eli_result$out, show_se = FALSE) })

thierrychambert
committed
}else {
output$title_distri_plot <- renderText({ "Erreur : certaines valeurs dans la matrice d'experts n'ont pas de sens" })
output$title_distri_plot <- renderText({ "Des valeurs sont manquantes dans la table 'experts'" })
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
#####
#####
##--------------------------------------------
## Display parameter distribution
##--------------------------------------------
# Function to plot a gamma distribution
plot_gamma <- function(mu, se, show_mode = TRUE, show_mean = TRUE, show_se = TRUE, ...){
## Define shape and scale parameter of gamma distribution
shape = (mu/se)^2
scale = se^2/mu
par(mar = c(5, 4, 6, 2))
curve(dgamma(x, shape=shape, scale=scale), from = max(0,mu-3*se), to = mu+3*se, lwd = 3, col = "darkblue", yaxt = "n",
ylab = "", xlab = "Valeur du paramtre", cex.lab = 1.2)
mtext(text = "Densit de probabilit", side = 2, line = 2, cex = 1.2)
# show mode
MU <- (shape-1)*scale
y_MU <- dgamma(x = MU, shape = shape, scale = scale)
xx <- qgamma(p = c(0.01,0.99), shape = shape, scale = scale)
clip(xx[1], xx[2], -100, y_MU)
abline(v = MU, lwd = 3, col = "darkblue")
# show mean
y_mu <- dgamma(x = mu, shape = shape, scale = scale)
clip(xx[1], xx[2], -100, y_mu)
abline(v = mu, lwd = 2, col = "darkblue", lty = 2)
if(show_mode) mtext(text = paste("Mode = ", round(MU, 2)), side = 3, line = 4, cex = 1.2, adj = 0)
if(show_mean) mtext(text = paste("Moyenne = ", round(mu, 2)), side = 3, line = 2.5, cex = 1.2, adj = 0)
if(show_se) mtext(text = paste("Erreur-type = ", round(se, 3)), side = 3, line = 1, cex = 1.2, adj = 0)

thierrychambert
committed
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
} # end function plot_gamma
plot_gamma_cumulated_impacts <- function(mu, se, nparc, ...){
## Define shape and scale parameter of gamma distribution
shape = (mu/se)^2
scale = se^2/mu
## Define x and y lim
xx = yy = list()
for(j in 1:nparc){
xx[[j]] = seq(from = max(0,mu[j]-4*se[j]), to = mu[j]+4*se[j], length.out = 1e3)
yy[[j]] = dgamma(xx[[j]], shape=shape[j], scale=scale[j])
}
ylim = c(min(unlist(yy)), max(unlist(yy))*1.4)
xlim = c(min(unlist(xx)), max(unlist(xx)))
## Plot
j=1
curve(dgamma(x, shape=shape[j], scale=scale[j]),
from = max(0,mu[j]-4*se[j]), to = mu[j]+4*se[j], n = 1e4,
xlim = xlim, ylim = ylim,
lwd = 3, col = j, yaxt = "n", xaxt = "n",
#xaxp = c(round(xlim[1]), round(xlim[2]), n = 10),
ylab = "", xlab = "Valeur du paramtre", cex.lab = 1.2)
axis(side = 1, at = seq(round(xlim[1]), round(xlim[2]),
by = max(round((round(xlim[2])-round(xlim[1]))/10),1) ))
mtext(text = "Densit de probabilit", side = 2, line = 2, cex = 1.2)
y1 <- dgamma(x = mu[j], shape = shape[j], scale = scale[j])
segments(x0 = mu[j], y0 = 0, y1 = y1, lty = 2, lwd = 3, col = j)
points(x = mu[j], y = y1, pch = 19, cex = 1.5, col = j)
for(j in 2:nparc){
curve(dgamma(x, shape=shape[j], scale=scale[j]),
from = max(0,mu[j]-4*se[j]), to = mu[j]+4*se[j], n = 1e4,
lwd = 3, col = j, yaxt = "n",
ylab = "", xlab = "Valeur du paramtre", cex.lab = 1.2, add = TRUE)
y1 <- dgamma(x = mu[j], shape = shape[j], scale = scale[j])
segments(x0 = mu[j], y0 = 0, y1 = y1, lty = 2, lwd = 3, col = j)
points(x = mu[j], y = y1, pch = 19, cex = 1.5, col = j)
}
legend(x = xlim[1], y = ylim[2], legend = paste("Parc", 1:nparc),
lwd = 3, col = 1:nparc, text.col = 1:nparc, cex = 1.5,
bty = "n", horiz = TRUE)
} # end function plot_gamma_cumulated_impacts
########################
## Fatalities
##----------------------
observeEvent({
input$analysis_choice
input$button_fatalities
input$fatalities_input_type
input$fatalities_run_expert
input$farm_number_cumulated
input$fatalities_mat_cumulated
},{
## 1. When analysis = single farm
if(input$analysis_choice == "single_farm"){
# Show from input values: if button is ON and input_type is set on "value" or "itvl" (thus not "eli_exp")
if(input$button_fatalities%%2 == 1 & input$fatalities_input_type != "eli_exp"){
output$title_distri_plot <- renderText({ "Mortalits annuelles" })
req(param$fatalities_mean, param$fatalities_se > 0)
if(input$fatalities_input_type == "itvl"){
req(input$fatalities_lower, input$fatalities_upper)
plot_gamma(mu = tail(param$fatalities_mean, -1), se = tail(param$fatalities_se, -1))
}else{
req(input$fatalities_mean, input$fatalities_se)
plot_gamma(mu = tail(param$fatalities_mean, -1), se = tail(param$fatalities_se, -1))
}
})
} else {
# Show from elicitation expert: if button is ON and input_type is set on "expert elicitation"
if(input$button_fatalities%%2 == 1 & input$fatalities_input_type == "eli_exp"){
if(!is.null(param$fatalities_eli_result)){
output$title_distri_plot <- renderText({ "Mortalits annuelles" })
output$distri_plot <- renderPlot({ plot_expert(param$fatalities_eli_result$out) })
} else {
output$title_distri_plot <- NULL
output$distri_plot <- NULL
}
# Hide otherwise (when button is OFF)
}else{
output$title_distri_plot <- NULL
output$distri_plot <- NULL
}
}
## 2. When analysis = cumulated impacts
if(input$analysis_choice == "cumulated"){
output$title_distri_plot <- renderText({ "Mortalits annuelles par parc (impacts cumuls)" })
# Plot: note we use the "NULL + delay" sequence only to avoid error message in R console
output$distri_plot <- NULL
delay(5,
output$distri_plot <- renderPlot({
req(all(!is.na(input$fatalities_mat_cumulated[,1])), all(input$fatalities_mat_cumulated[,2] > 0))
plot_gamma_cumulated_impacts(mu = input$fatalities_mat_cumulated[,1],
se = input$fatalities_mat_cumulated[,2],
nparc = input$farm_number_cumulated)
})
)
}else{
## 3. When analysis = multi_scenarios
output$title_distri_plot <- renderText({ "Pas de graphe (pas d'incertitude dans le cas 'mulitple scnarios')" })
output$distri_plot <- NULL
} # end "else"

thierrychambert
committed
} # end "if"
########################
## Population size
##----------------------
observeEvent({
input$button_pop_size
},{
# Show from input values: if button is ON and input_type is set on "value"
if(input$button_pop_size%%2 == 1 & input$pop_size_input_type != "eli_exp"){
output$title_distri_plot <- renderText({ "Taille initiale de la population" })
output$distri_plot <- renderPlot({
req(param$pop_size_mean, param$pop_size_se > 0)
plot_gamma(mu = param$pop_size_mean, se = param$pop_size_se)
})
} else {
# Show from elicitation expert: if button is ON and input_type is set on "expert elicitation"
if(input$button_pop_size%%2 == 1 & input$pop_size_input_type == "eli_exp"){
if(!is.null(param$pop_size_eli_result)){
output$title_distri_plot <- renderText({ "Taille initiale de la population" })
output$distri_plot <- renderPlot({ plot_expert(param$pop_size_eli_result$out) })
} else {
output$title_distri_plot <- NULL
output$distri_plot <- NULL
}
# Hide otherwise (when button is OFF)
}else{
output$title_distri_plot <- NULL
output$distri_plot <- NULL
}
########################
## Population growth
##----------------------
observeEvent({
input$pop_growth_input_type
input$button_pop_growth
},{
# Show from input values: if button is ON and input_type is set on "value" or "interval"
if(input$button_pop_growth%%2 == 1 & input$pop_growth_input_type != "eli_exp" & input$pop_growth_input_type != "trend"){
output$title_distri_plot <- renderText({ "Taux de croissance de la population" })
output$distri_plot <- renderPlot({
req(param$pop_growth_mean, param$pop_growth_se > 0)
plot_gamma(mu = param$pop_growth_mean, se = param$pop_growth_se)
})
} else {
# Show from elicitation expert: if button is ON and input_type is set on "expert elicitation"
if(input$button_pop_growth%%2 == 1 & input$pop_growth_input_type == "eli_exp"){
if(!is.null(param$pop_growth_eli_result)){
output$title_distri_plot <- renderText({ "Taux de croissance de la population" })
output$distri_plot <- renderPlot({ plot_expert(param$pop_growth_eli_result$out) })
} else {
output$title_distri_plot <- NULL
output$distri_plot <- NULL
}
# Hide otherwise (when button is OFF)
}else{
output$title_distri_plot <- NULL
output$distri_plot <- NULL
}
}
}, ignoreInit = FALSE)
########################
## Carrying capacity
##----------------------
observeEvent({
input$carrying_cap_input_type
input$button_carrying_cap
},{
# Show from input values: if button is ON and input_type is set on "value"
if(input$button_carrying_cap%%2 == 1 & input$carrying_cap_input_type != "eli_exp"){
output$title_distri_plot <- renderText({ "Capacit de charge" })
output$distri_plot <- renderPlot({
req(param$carrying_capacity_mean, param$carrying_capacity_se > 0)
plot_gamma(mu = param$carrying_capacity_mean, se = param$carrying_capacity_se)
})
} else {
# Show from elicitation expert: if button is ON and input_type is set on "expert elicitation"
if(input$button_carrying_cap%%2 == 1 & input$carrying_cap_input_type == "eli_exp"){
if(!is.null(param$carrying_cap_eli_result)){

thierrychambert
committed
if(!is.na(param$carrying_cap_eli_result$out)){
output$title_distri_plot <- renderText({ "Capacit de charge" })
output$distri_plot <- renderPlot({ plot_expert(param$carrying_cap_eli_result$out) })

thierrychambert
committed
}else{
output$title_distri_plot <- renderText({ "Erreur" })
output$distri_plot <- NULL
}
} else {
output$title_distri_plot <- NULL
output$distri_plot <- NULL
}
# Hide otherwise (when button is OFF)
}else{
output$title_distri_plot <- NULL
output$distri_plot <- NULL
}
}
}, ignoreInit = FALSE)
#####
#####
##-------------------------------------------------
## Display parameter values (on the side panel)
##-------------------------------------------------
#################################
##-------------------------------
## UNIT
output$fatalities_unit_info <- renderText({
if(!is.null(input$fatalities_unit)){
if(input$fatalities_unit == "h"){
paste0("Taux de mortalit")
} else {
paste0("Nombre de mortalits")
}
}
})
## Values
output$fatalities_mean_info <- renderText({
if(input$fatalities_unit == "h") add_perc <- "%" else add_perc <- ""
paste0(c("Moyenne : ",
paste0(tail(param$fatalities_mean, -1), add_perc, collapse = ", ")
), collapse = "")
})
output$fatalities_se_info <- renderText({
if(input$fatalities_unit == "h") add_perc <- "%" else add_perc <- ""
paste0(c("Erreur-type : ",
paste0(tail(param$fatalities_se, -1), add_perc, collapse = ", ")
), collapse = "")
})

thierrychambert
committed
#################################
## Poplutation size
##-------------------------------
## UNIT

thierrychambert
committed
output$pop_size_unit_info <- renderText({
if(!is.null(param$pop_size_unit)){
if(param$pop_size_unit == "Npair"){
paste0("Nombre de couple")

thierrychambert
committed
paste0("Effectif total")

thierrychambert
committed
output$pop_size_mean_info <- renderText({ paste0("Moyenne : ", param$pop_size_mean) })
output$pop_size_se_info <- renderText({ paste0("Erreur-type : ", param$pop_size_se) })
## Show Popsize by age (table)
# Function to create the table
make_mat_popsizes <- function(data_sf, species, pop_size, pop_size_unit, survivals, fecundities){
nam <- data_sf %>%
unlist %>%
as.vector
matrix(round(pop_vector(pop_size = pop_size, pop_size_type = pop_size_unit, s = survivals, f = fecundities)),
nrow = 1,
dimnames = list("Effectifs", nam)
)
}
# Display the table (Note : the "delay" piece is just there to avoid an error message - time for parameters to be "loaded in")
output$pop_size_by_age <- renderTable({
if(any(is.na(param$survivals)) | any(is.na(param$fecundities))){
matrix("Valeurs de survies et/ ou de fcondits manquantes",
nrow = 1, dimnames = list(NULL, "Erreur"))
}else{
make_mat_popsizes(data_sf = data_sf, species = input$species_choice, pop_size = param$pop_size_mean,
pop_size_unit = input$pop_size_unit, s = param$s_calib0, f = param$f_calib0)
} # end if
},
width = "500px",
rownames = FALSE,
digits = 0)
)
#################################
## Population growth
##-------------------------------

thierrychambert
committed
output$pop_growth_mean_info <- renderText({ paste0("Moyenne : ", param$pop_growth_mean) })
output$pop_growth_se_info <- renderText({ paste0("Erreur-type : ", param$pop_growth_se) })
#################################

thierrychambert
committed
## Carrying capacity
##-------------------------------
# UNIT (like pop size)
## UNIT
output$carrying_capacity_unit_info <- renderText({
if(!is.null(param$pop_size_unit)){
if(input$carrying_cap_input_type == "no_K"){
"Pas de capacit de charge (K = infini)"
}else{
if(param$pop_size_unit == "Npair"){
paste0("Nombre de couple")
} else {
paste0("Effectif total")
}
}
}
})
## VALUES
output$carrying_capacity_mean_info <- renderText({
if(input$carrying_cap_input_type == "no_K"){
NULL
paste0("Moyenne : ", param$carrying_capacity_mean)

thierrychambert
committed
output$carrying_capacity_se_info <- renderText({
if(input$carrying_cap_input_type == "no_K"){
NULL
}else{
paste0("Erreur-type : ", param$carrying_capacity_se)
#################################
##-------------------------------
# Function to create the matrix
make_mat_vr <- function(data_sf, species){
out_mat <- data_sf %>%
select(classes_age, survie, fecondite)
return(out_mat)
}

thierrychambert
committed
# Update the vital rate matrix (mat_fill_vr) when changing the number of age classes
observeEvent({