From 41e24ecde495a40fa7a015de312f8a74d8aacf42 Mon Sep 17 00:00:00 2001
From: thierrychambert <thierry.chambert@gmail.com>
Date: Sun, 5 Sep 2021 10:26:17 +0200
Subject: [PATCH] Surv & fec csv file : change juv1 by juv 0 Server : cleaned
annotation and re-organized parts
---
inst/ShinyApp/server.R | 758 +++++++++---------
.../survivals_fecundities_species.csv | 16 +-
2 files changed, 393 insertions(+), 381 deletions(-)
diff --git a/inst/ShinyApp/server.R b/inst/ShinyApp/server.R
index d1ab895..f623e2b 100644
--- a/inst/ShinyApp/server.R
+++ b/inst/ShinyApp/server.R
@@ -1,6 +1,6 @@
server <- function(input, output, session){
- ##--------------------------------------------
+ ##############################################
## Hide/Show : level 1
##--------------------------------------------
@@ -54,7 +54,7 @@ server <- function(input, output, session){
- ##--------------------------------------------
+ ##############################################
## Hide/Show : level 2
##--------------------------------------------
observe({
@@ -180,23 +180,9 @@ server <- function(input, output, session){
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
- ##--------------------------------------------
- ## Function to run the elicitation analysis
- ##----------------------------------------------
- # Function to extract value from elicitation matrix and 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)))
- }
- ###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
-
+ #####
- ##--------------------------------------------
+ ##############################################
## Reactive value
##--------------------------------------------
out <- reactiveValues(run = NULL)
@@ -241,196 +227,93 @@ server <- function(input, output, session){
- ##--------------------------------------------
- ## 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
- ###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
-
-
#####
- ##--------------------------------------------
- ## Display parameter distribution
- ##--------------------------------------------
-
- # Function to plot a gamma distribution
- plot_gamma <- function(mu, se, show_se = TRUE, ...){
-
- ## Define shape and scale parameter of gamma distribution
- shape = (mu/se)^2
- scale = se^2/mu
-
- ## Plot the curve
- 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 paramètre", cex.lab = 1.2)
- mtext(text = "Densité de probabilité", side = 2, line = 2, cex = 1.2)
-
- y2 <- 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, y2)
- abline(v = mu, lwd = 3, col = "darkblue")
-
- 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, 2)), side = 3, line = 1, cex = 1.2, adj = 0)
+ ################################################
+ ## 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)
}
- ##----------------------
- ## Fatalities
- ##----------------------
+ # Update the vital rate matrix (mat_fill_vr) when changing species in the list
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"
- if(input$button_fatalities%%2 == 1 & input$fatalities_input_type == "val"){
- output$title_distri_plot <- renderText({ "Mortalités annuelles" })
- output$distri_plot <- renderPlot({ plot_gamma(mu = input$fatalities_mean, se = input$fatalities_se) })
- } 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({ "Mortalités 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
- }
- }
+ input$species_choice
+ }, {
- # Hide otherwise (when analysis = cumulated impacts)
- }else{
- output$title_distri_plot <- renderText({ "Mortalités annuelles par parc (impacts cumulés)" })
+ if(input$species_choice == "Espèce générique") {} else {
- # output$distri_plot <- NULL
- output$distri_plot <- renderPlot({
- par(mfrow = c(1,input$farm_number_cumulated), mar = c(5, 4, 7, 2) + 0.1, oma = c(0,0,0,0))
- for(j in 1:input$farm_number_cumulated){
- plot_gamma(mu = input$fatalities_mat_cumulated[j,1], se = input$fatalities_mat_cumulated[j,2])
- title(paste("Parc", j), line = 5, outer = FALSE, cex.main = 1.8)
- }
- })
+ tab_species <- create.matrice(data_sf = data_sf, species = input$species_choice)
- }
- }, ignoreInit = FALSE)
+ 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", "Fécondité"))))
+ } else {
+ number_age_class <- nrow(tab_species)
+ ages <- tab_species$classes_age
+ survivals <- tab_species$survie
+ fecundities <- tab_species$fecondite
- ##----------------------
- ## 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
- }
- }
- }, ignoreInit = FALSE)
+ updateMatrixInput(session, inputId = "mat_fill_vr",
+ value = matrix(data = c(survivals, fecundities),
+ nrow = number_age_class,
+ ncol = 2,
+ dimnames = list(ages, c("Survie", "Fécondité"))))
+ } # end if 2
+ } # end if 1
+ }) # end observeEvent species_list
+ #####
- ##----------------------
- ## 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
- }
+ ##############################################
+ ## Update matrix cumulated impact
+ ##-------------------------------------------
+ observeEvent({input$farm_number_cumulated}, {
+ rows_names <- function(n){
+ v <- c(paste0("Parc n°", c(1:n)))
+ return(v)
}
- }, 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)
- ###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
+ nrow <- input$farm_number_cumulated
+ number_parks <- rows_names(nrow)
+ init_cumul_new <- rep(init_cumul_add, nrow)
+ updateMatrixInput(session, inputId = "fatalities_mat_cumulated",
+ value = matrix(init_cumul_new, nrow = nrow, ncol = 3, byrow = TRUE,
+ dimnames = list(number_parks,
+ c("Moyenne",
+ "Erreur-type",
+ "Année de mise en service du parc"))))
+ })
+ #####
#####
-
##--------------------------------------------
- ## Run expert elicitation --
+ ## Run expert elicitation
##--------------------------------------------
+ # 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 paramètre", cex.lab = 1.2, yaxt = "n")
mtext(text = "Densité de probabilité", side = 2, line = 2, cex = 1.2)
@@ -444,7 +327,7 @@ server <- function(input, output, session){
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({
@@ -464,7 +347,7 @@ server <- function(input, output, session){
} # end if
}) # end observeEvent
- ##----------------------
+ ########################
## Population size
##----------------------
observeEvent({
@@ -484,7 +367,7 @@ server <- function(input, output, session){
} # end if
}) # end observeEvent
- ##----------------------
+ ########################
## Population growth
##----------------------
observeEvent({
@@ -504,7 +387,7 @@ server <- function(input, output, session){
} # end if
}) # end observeEvent
- ##----------------------
+ ########################
## Carrying capacity
##----------------------
observeEvent({
@@ -528,11 +411,13 @@ server <- function(input, output, session){
#####
+
+ #####
##--------------------------------------------
- ## Select parameter values for simulations --
+ ## Select parameter values for simulations
##--------------------------------------------
- ##-------------------------------
+ #################################
## Cumulated impacts or not ?
##-------------------------------
observe({
@@ -544,7 +429,7 @@ server <- function(input, output, session){
}) # end observeEvent
- ##-------------------------------
+ #################################
## Fatalities
##-------------------------------
observeEvent({
@@ -555,9 +440,13 @@ server <- function(input, output, session){
# Case 1.1 : Values from expert elicitation (if2)
if(input$fatalities_input_type == "eli_exp"){
- param$fatalities_mean <- c(0, round(param$fatalities_eli_result$mean))
- param$onset_time <- NULL
- param$fatalities_se <- c(0, round(param$fatalities_eli_result$SE))
+ if(!(is.null(param$pop_size_eli_result))){
+ param$fatalities_mean <- c(0, round(param$fatalities_eli_result$mean))
+ param$onset_time <- NULL
+ param$fatalities_se <- c(0, round(param$fatalities_eli_result$SE))
+ } else {
+ print("Erreur: Vous n'avez pas lancer l'analyse 'valeurs experts' ")
+ }
} else {
@@ -578,8 +467,9 @@ server <- function(input, output, session){
}) # end observeEvent
###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
- ###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~###
- ## Population size ###~~~~~~~~~~~~~~~~~~~~~~~~~~###
+ #################################
+ ## Population size
+ ##-------------------------------
observeEvent({
input$run
},{
@@ -602,22 +492,12 @@ server <- function(input, output, session){
})
- ###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~##
- ## 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
-
-
-
-
- ###~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~##
- ## Population growth ###~~~~~~~~~~~~~~~~~~~~~~~~~~###
- observeEvent({
- input$run
- }, {
+ #################################
+ ## Population growth
+ ##-------------------------------
+ observeEvent({
+ input$run
+ }, {
# Case 1 : Values from expert elicitation
if(input$pop_growth_input_type == "eli_exp"){
@@ -659,20 +539,11 @@ server <- function(input, output, session){
}
})
- # Survival and fecundity calibration
- 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 carrying capacity
+ #################################
+ ## Carrying capacity
+ ##------------------------------
observeEvent({
input$run
}, {
@@ -680,137 +551,233 @@ server <- function(input, output, session){
if(!(is.null(param$carrying_cap_eli_result))){
param$carrying_capacity <- round(param$carrying_cap_eli_result$mean)
} else {
- print("#intégrer un message d'erreur")
+ print("Erreur: Vous n'avez pas lancer l'analyse 'valeurs experts'")
}
} else {
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
- }, {
- print(param$pop_growth_mean)
- print(param$pop_growth_se)
+ },{
+ 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))
})
+ #####
- # End of reactive
-
- # Simulations
-
- observeEvent({
- input$run
- }, {
-
- withProgress(message = 'Simulation progress', value = 0, {
-
- out$run <- run_simul_shiny(nsim = param$nsim,
- cumulated_impacts = param$cumulated_impacts,
-
- fatalities_mean = param$fatalities_mean,
- fatalities_se = param$fatalities_se,
- onset_time = param$onset_time,
+ ############################################################
+ ## Observe parameter values to be used in simulations run
+ ##----------------------------------------------------------
+ observe({
+ param # required to ensure up-to-date values are run
- pop_size_mean = param$pop_size_mean,
- pop_size_se = param$pop_size_se,
- pop_size_type = param$pop_size_unit,
+ # simple inputs
+ param$nsim <- input$nsim
+ param$fatal_constant <- input$fatal_constant
- pop_growth_mean = param$pop_growth_mean,
- pop_growth_se = param$pop_growth_se,
+ # fixed in global environment (for now)
+ param$theta = theta
+ param$time_horzion = time_horzion
+ param$coeff_var_environ = coeff_var_environ
- survivals = param$s_calibrated,
- fecundities = param$f_calibrated,
+ }) # end observe
+ #####
- carrying_capacity = param$carrying_capacity,
- theta = param$theta,
- rMAX_species = param$rMAX_species,
- model_demo = NULL,
- time_horzion = param$time_horzion,
- coeff_var_environ = param$coeff_var_environ,
- fatal_constant = param$fatal_constant)
- }) # Close withProgress
- }) # Close observEvent
+ #####
+ ##--------------------------------------------
+ ## Display parameter distribution
+ ##--------------------------------------------
+ # Function to plot a gamma distribution
+ plot_gamma <- function(mu, se, show_mean = TRUE, show_se = TRUE, ...){
+ ## Define shape and scale parameter of gamma distribution
+ shape = (mu/se)^2
+ scale = se^2/mu
+ ## Plot the curve
+ 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 paramètre", cex.lab = 1.2)
+ mtext(text = "Densité de probabilité", side = 2, line = 2, cex = 1.2)
+ y2 <- 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, y2)
+ abline(v = mu, lwd = 3, col = "darkblue")
+ 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, 2)), side = 3, line = 1, cex = 1.2, adj = 0)
+ }
+ ########################
+ ## Fatalities
+ ##----------------------
+ observeEvent({
+ input$analysis_choice
+ input$button_fatalities
+ input$fatalities_input_type
+ input$fatalities_run_expert
- ##--------------------------------------------------------------------------##
- ## OUTPUTS
- ##--------------------------------------------------------------------------##
+ 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"
+ if(input$button_fatalities%%2 == 1 & input$fatalities_input_type == "val"){
+ output$title_distri_plot <- renderText({ "Mortalités annuelles" })
+ output$distri_plot <- renderPlot({ plot_gamma(mu = input$fatalities_mean, se = input$fatalities_se) })
+ } 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({ "Mortalités 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
+ }
+ }
- ##--------------------------------------------
- # Show result : impact text
- ##--------------------------------------------
- ## Two Functions to print the output
- # print_it
- print_it <- function(impact, lci, uci){
- paste0("Impact sur la taille de population : ", round(impact, 2)*100, "%",
- "[", round(lci, 2)*100, "% ; ", round(uci, 2)*100, "%]")
- }
+ # Hide otherwise (when analysis = cumulated impacts)
+ }else{
+ output$title_distri_plot <- renderText({ "Mortalités annuelles par parc (impacts cumulés)" })
- # print_out
- print_out <- function() if(is.null(out$run$N)) {} else {
- print_it(impact = get_metrics(N = out$run$N)$scenario$impact[time_horzion, "avg",-1],
- lci = get_metrics(N = out$run$N)$scenario$impact[time_horzion, "lci",-1],
- uci = get_metrics(N = out$run$N)$scenario$impact[time_horzion, "uci",-1])
- }
+ # output$distri_plot <- NULL
+ output$distri_plot <- renderPlot({
+ par(mfrow = c(1,input$farm_number_cumulated), mar = c(5, 4, 7, 2) + 0.1, oma = c(0,0,0,0))
+ for(j in 1:input$farm_number_cumulated){
+ plot_gamma(mu = input$fatalities_mat_cumulated[j,1], se = input$fatalities_mat_cumulated[j,2])
+ title(paste("Parc", j), line = 5, outer = FALSE, cex.main = 1.8)
+ }
+ })
- # Display result (text)
- output$impact_text <- renderText({
- if(!param$cumulated_impacts){
- print_out()
- } else{
- NULL
}
- })
+ }, ignoreInit = FALSE)
- # Plot Impacts
- plot_out_impact <- function(){
- if(is.null(out$run)) {} else {plot_impact(N = out$run$N, xlab = "year", ylab = "pop size")}
- }
- output$title_impact_plot <- renderText({
- if(input$run > 0){
- "Résultat : Impact relatif au cours du temps"
+ ########################
+ ## 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
+ }
}
- })
-
- output$impact_plot <- renderPlot({
- plot_out_impact()
- })
-
- # Plot trajectories
- plot_out_traj <- function(){
- if(is.null(out$run)) {} else {plot_traj(N = out$run$N, xlab = "year", ylab = "pop size")}
- }
-
- output$graph_traj <- renderPlot({
- plot_out_traj()
- })
-
-
-
-
+ }, ignoreInit = FALSE)
- ##--------------------------------------------
- ## Display General information --
- ##--------------------------------------------
+ ########################
+ ## 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)
- #output$species_name <- renderText({ paste0("Espèce : ", as.character(input$species_choice)) })
+ ########################
+ ## 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)
+ ##-------------------------------------------------
+ #################################
## Fatalities
+ ##-------------------------------
output$fatalities_mean_info <- renderText({ paste0("Moyenne : ", tail(param$fatalities_mean, 1)) })
output$fatalities_se_info <- renderText({ paste0("Erreur-type : ", tail(param$fatalities_se, 1)) })
- ## Poplutation size UNIT information
+ #################################
+ ## Poplutation size
+ ##-------------------------------
+ ## UNIT
output$pop_size_unit_info <- renderText({
if(!is.null(param$pop_size_unit)){
if(param$pop_size_unit == "Npair"){
@@ -821,29 +788,32 @@ server <- function(input, output, session){
}
})
-
- ## Poplutation size information
+ ## VALUES
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 information
+ #################################
+ ## Population growth
+ ##-------------------------------
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) })
-
+ #################################
## Carrying capacity
+ ##-------------------------------
+ # UNIT (like pop size)
output$carrying_capacity_info <- renderText({
# Source info "unit"
if(is.null(param$pop_size_unit)){
- unit1 <- input$pop_size_unit
- }else{
- unit1 <- param$pop_size_unit
- }
+ unit1 <- input$pop_size_unit
+ }else{
+ unit1 <- param$pop_size_unit
+ }
- # N type
+ # UNIT information
if(unit1 == "Npair"){
info1 <- paste0("Nombre de couple")
} else {
@@ -854,73 +824,115 @@ server <- function(input, output, session){
paste0(info1, " : ", param$carrying_capacity)
})
+
+ #################################
## Vital rates
+ ##-------------------------------
output$vital_rates_info <- renderTable({
input$mat_fill_vr
}, rownames = TRUE)
+ #####
- ## Update matrix cumulated impact
+ #####
+ ##-----------------------------------------------------------------------------------
+ ## RUN SIMULATIONS
+ ##-----------------------------------------------------------------------------------
+ observeEvent({
+ input$run
+ }, {
+ withProgress(message = 'Simulation progress', value = 0, {
- observeEvent({input$farm_number_cumulated}, {
- rows_names <- function(n){
- v <- c(paste0("Parc n°", c(1:n)))
- return(v)
- }
+ out$run <- run_simul_shiny(nsim = param$nsim,
+ cumulated_impacts = param$cumulated_impacts,
- nrow <- input$farm_number_cumulated
- number_parks <- rows_names(nrow)
+ fatalities_mean = param$fatalities_mean,
+ fatalities_se = param$fatalities_se,
+ onset_time = param$onset_time,
- init_cumul_new <- rep(init_cumul_add, nrow)
+ pop_size_mean = param$pop_size_mean,
+ pop_size_se = param$pop_size_se,
+ pop_size_type = param$pop_size_unit,
- updateMatrixInput(session, inputId = "fatalities_mat_cumulated",
- value = matrix(init_cumul_new, nrow = nrow, ncol = 3, byrow = TRUE,
- dimnames = list(number_parks,
- c("Moyenne",
- "Erreur-type",
- "Année de mise en service du parc"))))
- })
+ pop_growth_mean = param$pop_growth_mean,
+ pop_growth_se = param$pop_growth_se,
- # Survivals and Fecundities
+ survivals = param$s_calibrated,
+ fecundities = param$f_calibrated,
- create.matrice <- function(data_sf, species){
- out_mat <- data_sf %>%
- filter(species == data_sf$Nom_espece) %>%
- select(classes_age, survie, fecondite)
- return(out_mat)
- }
+ carrying_capacity = param$carrying_capacity,
+ theta = param$theta,
+ rMAX_species = param$rMAX_species,
+ model_demo = NULL,
+ time_horzion = param$time_horzion,
+ coeff_var_environ = param$coeff_var_environ,
+ fatal_constant = param$fatal_constant)
+ }) # Close withProgress
+ }) # Close observEvent
+ #####
- ## Update the vital rate matrix when changing species in the list
- observeEvent({input$species_choice}, {
- if(input$species_choice == "Espèce générique") {} else {
- tab_species <- create.matrice(data_sf = data_sf, species = input$species_choice)
+ #####
+ ##-----------------------------------------------------------------------------------
+ ## OUTPUTS
+ ##-----------------------------------------------------------------------------------
- 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", "Fécondité"))))
+ ##-------------------------------------------
+ ## Impact text
+ ##-------------------------------------------
+ ## Two Functions to print the output
+ print_it <- function(impact, lci, uci){
+ paste0("Impact sur la taille de population : ", round(impact, 2)*100, "%",
+ "[", round(lci, 2)*100, "% ; ", round(uci, 2)*100, "%]")
+ }
+ print_out <- function() if(is.null(out$run$N)) {} else {
+ print_it(impact = get_metrics(N = out$run$N)$scenario$impact[time_horzion, "avg",-1],
+ lci = get_metrics(N = out$run$N)$scenario$impact[time_horzion, "lci",-1],
+ uci = get_metrics(N = out$run$N)$scenario$impact[time_horzion, "uci",-1])
+ }
- } else {
- number_age_class <- nrow(tab_species)
- ages <- tab_species$classes_age
- survivals <- tab_species$survie
- fecundities <- tab_species$fecondite
+ # Display result (text)
+ output$impact_text <- renderText({
+ if(!param$cumulated_impacts){
+ print_out()
+ } else{
+ NULL
+ }
+ })
- updateMatrixInput(session, inputId = "mat_fill_vr",
- value = matrix(data = c(survivals, fecundities),
- nrow = number_age_class,
- ncol = 2,
- dimnames = list(ages, c("Survie", "Fécondité"))))
- } # end if 2
- } # end if 1
+ ##-------------------------------------------
+ ## Plot Impacts
+ ##-------------------------------------------
+ ## Function to plot the impact
+ plot_out_impact <- function(){
+ if(is.null(out$run)) {} else {plot_impact(N = out$run$N, xlab = "year", ylab = "pop size")}
+ }
- }) # end observeEvent species_list
+ output$title_impact_plot <- renderText({
+ if(input$run > 0){
+ "Résultat : Impact relatif au cours du temps"
+ }
+ })
+
+ output$impact_plot <- renderPlot({
+ plot_out_impact()
+ })
+
+ ##-------------------------------------------
+ ## Plot Demographic Trajectories
+ ##-------------------------------------------
+ # Function to plot trajectories
+ plot_out_traj <- function(){
+ if(is.null(out$run)) {} else {plot_traj(N = out$run$N, xlab = "year", ylab = "pop size")}
+ }
+
+ output$graph_traj <- renderPlot({
+ plot_out_traj()
+ })
+ #####
###################################################################################
diff --git a/inst/ShinyApp/survivals_fecundities_species.csv b/inst/ShinyApp/survivals_fecundities_species.csv
index df0645a..adfcdad 100644
--- a/inst/ShinyApp/survivals_fecundities_species.csv
+++ b/inst/ShinyApp/survivals_fecundities_species.csv
@@ -1,12 +1,12 @@
Nom_espece,classes_age,survie,fecondite
-Aigle de Bonelli,Juv 1,0.65,0
-Aigle de Bonelli,Juv 2,0.75,0
-Aigle de Bonelli,Juv 3,0.85,0.05
+Aigle de Bonelli,Juv 0,0.65,0
+Aigle de Bonelli,Juv 1,0.75,0
+Aigle de Bonelli,Juv 2,0.85,0.05
Aigle de Bonelli,Adulte,0.94,0.4
-Aigle royal,Juv 1,0.5,0
-Aigle royal,Juv 2,0.6,0
-Aigle royal,Juv 3,0.75,0.05
-Aigle royal,Juv 4,0.8,0.35
+Aigle royal,Juv 0,0.5,0
+Aigle royal,Juv 1,0.6,0
+Aigle royal,Juv 2,0.75,0.05
+Aigle royal,Juv 3,0.8,0.35
Aigle royal,Adulte,0.95,0.55
-Alouette des champs,Juv 1,0.5,0
+Alouette des champs,Juv 0,0.4,0
Alouette des champs,Adulte,0.5,2.5
\ No newline at end of file
--
GitLab