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 couples")
} else {
paste0("Effectif total")
}
})
## Outputs / show CI
output$hide_show_CI <- eventReactive({
input$run
},{
if(input$run > 0) TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_show_CI", suspendWhenHidden = FALSE)
## Outputs / text results
output$hide_results <- eventReactive({
input$run
},{
if(input$run > 0) TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_results", suspendWhenHidden = FALSE)
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
## Graph choices
output$hide_graph_choice <- eventReactive({
input$run
},{
if(input$run > 0) TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_graph_choice", suspendWhenHidden = FALSE)
## Graph result : PDF
output$hide_graph_PDF <- eventReactive({
input$run
input$choose_graph
},{
if(input$run > 0 & input$choose_graph == "show_PDF") TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_graph_PDF", suspendWhenHidden = FALSE)
## Graph result : ECDF
output$hide_graph_ECDF <- eventReactive({
input$run
input$choose_graph
},{
if(input$run > 0 & input$choose_graph == "show_ECDF") TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_graph_ECDF", suspendWhenHidden = FALSE)
## Side bar : risk A / quantile of CDF
output$hide_risk_A <- eventReactive({
input$run
input$choose_graph
},{
if(input$run > 0 & input$choose_graph == "show_ECDF") TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_risk_A", suspendWhenHidden = FALSE)
## Graph result : impact_time
output$hide_graph_impact_time <- eventReactive({
input$run
input$choose_graph
},{
if(input$run > 0 & input$choose_graph == "show_impact_time") TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_graph_impact_time", suspendWhenHidden = FALSE)
## Graph result : demog_proj
output$hide_graph_demog_proj <- eventReactive({
input$run
input$choose_graph
},{
if(input$run > 0 & input$choose_graph == "show_demog_proj") TRUE else FALSE
}, ignoreInit = TRUE)
outputOptions(output, "hide_graph_demog_proj", 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" ))
)
)
})
#####
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
########################
## 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
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
} # 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 couples")

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({