Newer
Older
##############################################
## 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")
}
})
##############################################
## 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("farm_number_cumulated")
shinyjs::hide("fatalities_mat_cumulated")
shinyjs::hide("pop_size_mean")
shinyjs::hide("pop_size_se")
shinyjs::hide("pop_size_mat_expert")
shinyjs::hide("pop_growth_mean")
shinyjs::hide("pop_growth_se")
shinyjs::hide("pop_growth_mat_expert")
shinyjs::hide("pop_trend")
shinyjs::hide("pop_trend_strength")
shinyjs::hide("carrying_capacity")
shinyjs::hide("carrying_cap_mat_expert")
shinyjs::hide("carrying_cap_run_expert")
#------------
# Show some
#------------
# Show inputs for fatalities part
# Show inputs for none cumulated impacts scenario
if(input$analysis_choice == "scenario"){
shinyjs::show("fatalities_input_type")
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")
}
}
}
# Show inputs for cumulated scenario
if(input$analysis_choice == "cumulated"){
shinyjs::hide("fatalities_input_type")
shinyjs::show("farm_number_cumulated")
shinyjs::show("fatalities_mat_cumulated")
# Show inputs for population size part
if(input$button_pop_size%%2 == 1){
shinyjs::show("pop_size_mean")
shinyjs::show("pop_size_se")
}
# Show inputs for population trend/growth part
if(input$button_pop_growth%%2 == 1){
shinyjs::show("pop_growth_input_type")
shinyjs::show("pop_growth_mean")
shinyjs::show("pop_growth_se")
}
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 == "val"){
shinyjs::show("carrying_capacity")
}
if(input$carrying_cap_input_type == "eli_exp"){
shinyjs::show("carrying_cap_mat_expert")
shinyjs::show("carrying_cap_run_expert")
}
}
# Show inputs vital rates part
}) # en observe show/hide
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
##############################################
## Reactive values
thierrychambert
committed
out <- reactiveValues(run = NULL, msg = NULL)
ready <- reactiveValues(fatalities = TRUE, pop_size = TRUE, pop_growth = TRUE, carrying_capacity = TRUE)
nsim = NULL,
cumulated_impacts = FALSE,
fatalities_se = NULL,
onset_time = NULL,
onset_year = NULL,
pop_size_mean = NULL,
pop_size_se = NULL,
pop_growth_mean = NULL,
pop_growth_se = NULL,
fecundities = NULL,
survivals = NULL,
s_calibrated = NULL,
f_calibrated = NULL,
vr_calibrated = NULL,
theta = NULL,
model_demo = NULL,
time_horzion = 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
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
#####
################################################
## Update the vital rate matrix (mat_fill_vr)
## when changing species in the list
##----------------------------------------------
# Function to create the matrix
create.matrice <- function(data_sf, species){
out_mat <- data_sf %>%
filter(species == data_sf$Nom_espece) %>%
select(classes_age, survie, fecondite)
return(out_mat)
# Update the vital rate matrix (mat_fill_vr) when changing species in the list
input$species_choice
}, {
if(input$species_choice == "Espce gnrique") {} else {
tab_species <- create.matrice(data_sf = data_sf, species = input$species_choice)
if(all(is.na(tab_species))) {
updateMatrixInput(session, inputId = "mat_fill_vr",
value = matrix(data = NA,
nrow = 4,
ncol = 2,
dimnames = list(c("Juv 1", "Juv 2", "Juv 3", "Adulte"), c("Survie", "Fcondit"))))
} else {
number_age_class <- nrow(tab_species)
ages <- tab_species$classes_age
survivals <- tab_species$survie
fecundities <- tab_species$fecondite
updateMatrixInput(session, inputId = "mat_fill_vr",
value = matrix(data = c(survivals, fecundities),
nrow = number_age_class,
ncol = 2,
dimnames = list(ages, c("Survie", "Fcondit"))))
} # end if 2
} # end if 1
}) # end observeEvent species_list
#####
##############################################
## Update matrix cumulated impact
##-------------------------------------------
observeEvent({
input$farm_number_cumulated
}, {
nfarm <- input$farm_number_cumulated
init_cumul_new <- init_cumul[1:nfarm,]
updateMatrixInput(session, inputId = "fatalities_mat_cumulated",
value = matrix(init_cumul_new, nrow = nfarm, ncol = 3, byrow = FALSE,
dimnames = list(paste("Parc", c(1:nfarm)),
c("Moyenne",
"Erreur-type",
#####
##--------------------------------------------
##--------------------------------------------
# Function to run the elication analysis
func_eli <- function(mat_expert){
t_mat_expert <- t(mat_expert)
vals <- t_mat_expert[2:4,]
Cp <- t_mat_expert[5,]
weights <- t_mat_expert[1,]
out <- elicitation(vals, Cp, weights)
return(list(out = out, mean = out$mean_smooth, SE = sqrt(out$var_smooth)))
}
# 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))) {
## run elicitation analysis
param$pop_growth_eli_result <- func_eli(input$pop_growth_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)
output$title_distri_plot <- renderText({ "Capacit de charge" })
output$distri_plot <- renderPlot({ plot_expert(param$carrying_cap_eli_result$out, show_se = FALSE) })
} else {
print("missing value")
} # end if
}) # end observeEvent
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
#####
#####
##--------------------------------------------
## 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+4*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, 1)), side = 3, line = 4, cex = 1.2, adj = 0)
if(show_mean) mtext(text = paste("Moyenne = ", round(mu, 1)), side = 3, line = 2.5, cex = 1.2, adj = 0)
if(show_se) mtext(text = paste("Erreur-type = ", round(se, 2)), side = 3, line = 1, cex = 1.2, adj = 0)
thierrychambert
committed
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
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
} # 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
},{
if(input$analysis_choice != "cumulated"){
# 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" })
output$distri_plot <- renderPlot({
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
}
}
thierrychambert
committed
# When analysis = cumulated impacts
}else{
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({
plot_gamma_cumulated_impacts(mu = input$fatalities_mat_cumulated[,1],
thierrychambert
committed
se = input$fatalities_mat_cumulated[,2],
nparc = input$farm_number_cumulated)
thierrychambert
committed
} # end "if"
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
########################
## Population size
##----------------------
observeEvent({
input$pop_size_input_type
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 == "val"){
output$title_distri_plot <- renderText({ "Taille initiale de la population" })
output$distri_plot <- renderPlot({ plot_gamma(mu = input$pop_size_mean, se = input$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
}
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
########################
## 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"
if(input$button_pop_growth%%2 == 1 & input$pop_growth_input_type == "val"){
output$title_distri_plot <- renderText({ "Taux de croissance de la population" })
output$distri_plot <- renderPlot({ plot_gamma(mu = input$pop_growth_mean, se = input$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 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)){
output$title_distri_plot <- renderText({ "Capacit de charge" })
output$distri_plot <- renderPlot({ plot_expert(param$carrying_cap_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)
#####
#####
##-------------------------------------------------
## Display parameter values (on the side panel)
##-------------------------------------------------
#################################
##-------------------------------
output$fatalities_mean_info <- renderText({
paste0(c("Moyenne : ",
paste0(c(tail(param$fatalities_mean, -1)), collapse = ", ")
), collapse = "")
})
output$fatalities_se_info <- renderText({
paste0(c("Erreur-type : ",
paste0(c(tail(param$fatalities_se, -1)), 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) })
#################################
## 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)
thierrychambert
committed
# Source info "unit"
if(is.null(param$pop_size_unit)){
unit1 <- input$pop_size_unit
}else{
unit1 <- param$pop_size_unit
}
thierrychambert
committed
thierrychambert
committed
if(unit1 == "Npair"){
info1 <- paste0("Nombre de couple")
thierrychambert
committed
info1 <- paste0("Effectif total")
thierrychambert
committed
paste0(info1, " : ", param$carrying_capacity)
#################################
##-------------------------------
#####
##--------------------------------------------
## Select parameter values for simulations
##--------------------------------------------
thierrychambert
committed
# Functions to calculate mean and SD from lower & upper values
get_mu <- function(lower, upper) (lower + upper)/2
get_sd <- function(lower, upper, coverage) ((abs(upper - lower)/2))/qnorm(1-((1-coverage)/2))
#################################
## Cumulated impacts or not ?
##-------------------------------
observeEvent({
input$run
}, {
if(input$analysis_choice == "scenario"){
param$cumulated_impacts = FALSE
} else {
param$cumulated_impacts = TRUE
} # end if
}) # end observeEvent
#################################
## Fatalities
##-------------------------------
observe({
# Case 1 : Not cumulated effects (if1)
if(input$analysis_choice == "scenario"){
# Case 1.1 : Values from expert elicitation (if2)
if(input$fatalities_input_type == "eli_exp"){
if(!(is.null(param$fatalities_eli_result))){
param$fatalities_mean <- c(0, round(param$fatalities_eli_result$mean, 2))
param$onset_time <- NULL
thierrychambert
committed
param$fatalities_se <- c(0, round(param$fatalities_eli_result$SE, 3))
ready$fatalities <- TRUE
} else {
ready$fatalities <- FALSE
}
} else {
if(input$fatalities_input_type == "val"){
# Case 1.2 : Values directly provided as mean & SE
param$fatalities_mean <- c(0, input$fatalities_mean)
param$onset_time <- NULL
param$fatalities_se <- c(0, input$fatalities_se)
ready$fatalities <- TRUE
}else{
# Case 1.3 : Values directly provided as lower/upper interval
thierrychambert
committed
param$fatalities_mean <- c(0, round(get_mu(lower = input$fatalities_lower, upper = input$fatalities_upper), 2))
thierrychambert
committed
param$fatalities_se <- c(0, round(get_sd(lower = input$fatalities_lower, upper = input$fatalities_upper, coverage = CP), 3))
} # end (if2)
# Case 2 : Cumulated effects (if-else 1)
} else {
ready$fatalities <- TRUE
param$fatalities_mean <- c(0, input$fatalities_mat_cumulated[,1])
param$fatalities_se <- c(0, input$fatalities_mat_cumulated[,2])
param$onset_year <- c(min(input$fatalities_mat_cumulated[,3]), input$fatalities_mat_cumulated[,3])
param$onset_time <- param$onset_year - min(param$onset_year) + 1
} # end (if1)
}) # end observe
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
#################################
## Population size
##-------------------------------
observe({
# Case 1 : Values from expert elicitation
if(input$pop_size_input_type == "eli_exp"){
if(!(is.null(param$pop_size_eli_result))){
param$pop_size_mean <- round(param$pop_size_eli_result$mean)
param$pop_size_se <- round(param$pop_size_eli_result$SE)
ready$pop_size <- TRUE
} else {
ready$pop_size <- FALSE
}
# Case 2 : Values directly provided (i.e., not from expert elicitation)
} else {
ready$pop_size <- TRUE
param$pop_size_mean <- input$pop_size_mean
param$pop_size_se <- input$pop_size_se
}
param$pop_size_unit <- input$pop_size_unit
})
#################################
## Population growth
##-------------------------------
observe({
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
# Case 1 : Values from expert elicitation
if(input$pop_growth_input_type == "eli_exp"){
if(!(is.null(param$pop_growth_eli_result))){
param$pop_growth_mean <- round(min(1 + param$rMAX_species, round(param$pop_growth_eli_result$mean, 2)), 2)
param$pop_growth_se <- round(param$pop_growth_eli_result$SE, 2)
ready$pop_growth <- TRUE
} else {
ready$pop_growth <- FALSE
}
} else {
# Case 2 : Trend information
if(input$pop_growth_input_type == "trend"){
ready$pop_growth <- TRUE
if(input$pop_trend == "growth") {
if(input$pop_trend_strength == "weak") {
param$pop_growth_mean <- 1.01
} else if(input$pop_trend_strength == "average"){
param$pop_growth_mean <- 1.03
} else {
param$pop_growth_mean <- 1.06
}
} else if(input$pop_trend == "decline"){
if(input$pop_trend_strength == "weak") {
param$pop_growth_mean <- 0.99
} else if(input$pop_trend_strength == "average"){
param$pop_growth_mean <- 0.97
} else {
param$pop_growth_mean <- 0.94
}
} else {
param$pop_growth_mean <- 1
}
param$pop_growth_se <- 0
# Case 3 : Values directly provided (i.e., not from expert elicitation)
} else {
ready$pop_growth <- TRUE
param$pop_growth_mean <- round(min(1 + param$rMAX_species, input$pop_growth_mean), 2)
param$pop_growth_se <- input$pop_growth_se
}
}
})
#################################
## Carrying capacity
##------------------------------
observe({
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
if(input$carrying_cap_input_type == "eli_exp"){
if(!(is.null(param$carrying_cap_eli_result))){
param$carrying_capacity <- round(param$carrying_cap_eli_result$mean)
ready$carrying_capacity <- TRUE
} else {
ready$carrying_capacity <- FALSE
}
} else {
ready$carrying_capacity <- TRUE
param$carrying_capacity <- input$carrying_capacity
}
})
#############################################
## Survivals, fecundities and rMAX_species
##-------------------------------------------
observeEvent({
input$run
}, {
param$survivals <- input$mat_fill_vr[,1]
param$fecundities <- input$mat_fill_vr[,2]
param$rMAX_species <- rMAX_spp(surv = tail(param$survivals,1), afr = min(which(param$fecundities != 0)))
}) # end observeEvent
#####
#############################################
## Calibration of survivals & fecundities
##-------------------------------------------
observeEvent({
input$run
},{
param$vr_calibrated <- calibrate_params(
inits = init_calib(s = param$survivals, f = param$fecundities, lam0 = param$pop_growth_mean),
f = param$fecundities, s = param$survivals, lam0 = param$pop_growth_mean
)
param$s_calibrated <- head(param$vr_calibrated, length(param$survivals))
param$f_calibrated <- tail(param$vr_calibrated, length(param$fecundities))
})
#####
############################################################
## Observe parameter values to be used in simulations run
##----------------------------------------------------------
observe({
param # required to ensure up-to-date values are run
# simple inputs
param$nsim <- input$nsim
param$fatal_constant <- input$fatal_constant
# fixed in global environment (for now)
param$theta = theta
param$time_horzion = time_horzion
param$coeff_var_environ = coeff_var_environ
}) # end observe
#####
#####
##-----------------------------------------------------------------------------------
## RUN SIMULATIONS
##-----------------------------------------------------------------------------------
observeEvent({
input$run
}, {
thierrychambert
committed
if(ready$fatalities & ready$pop_size & ready$pop_growth & ready$carrying_capacity){
withProgress(message = 'Simulation progress', value = 0, {
out$run <- run_simul_shiny(nsim = param$nsim,
cumulated_impacts = param$cumulated_impacts,
thierrychambert
committed
fatalities_mean = param$fatalities_mean,
fatalities_se = param$fatalities_se,
onset_time = param$onset_time,
thierrychambert
committed
pop_size_mean = param$pop_size_mean,
pop_size_se = param$pop_size_se,
pop_size_type = param$pop_size_unit,
thierrychambert
committed
pop_growth_mean = param$pop_growth_mean,
pop_growth_se = param$pop_growth_se,
thierrychambert
committed
survivals = param$s_calibrated,
fecundities = param$f_calibrated,
thierrychambert
committed
carrying_capacity = param$carrying_capacity,
theta = param$theta,
rMAX_species = param$rMAX_species,
thierrychambert
committed
model_demo = NULL,
time_horzion = param$time_horzion,
coeff_var_environ = param$coeff_var_environ,
fatal_constant = param$fatal_constant)
}) # Close withProgress
}else{
out$run <- NULL
out$msg <- "error_not_ready"
}
}) # Close observEvent
#####
#####
##-----------------------------------------------------------------------------------
## OUTPUTS
##-----------------------------------------------------------------------------------
##-------------------------------------------
## Impact text
##-------------------------------------------
## Functions to print the output as text (non cumulated impacts)
print_impact_text <- function(impact, lci, uci){
paste0("Impact : ", round(impact, 2)*100, "%",
"[", round(lci, 2)*100, "% ; ", round(uci, 2)*100, "%]")
} # end function print_impact_text
## Functions to print the output as text (non cumulated impacts)
print_impact_table <- function(res){
nfarm <- (dim(res$indiv_farm$impact)[3]-1)
fil <- paste0(round(t(res$indiv_farm$impact[time_horzion, -2, -1]),2)*100, "%")
matrix(fil,
nrow = nfarm,
dimnames = list(paste("Parc",1:nfarm), c("Impact", "IC (min)", "IC (max)"))
)
} # end function print_impact_table
thierrychambert
committed
print_out <- function(){