Newer
Older
thierrychambert
committed
input$vr_mat_number_age_classes
}, {
req(input$vr_mat_number_age_classes)
number_age_class <- input$vr_mat_number_age_classes
updateMatrixInput(session, inputId = "mat_fill_vr",
value = matrix(data = NA,
nrow = number_age_class,
ncol = 2,
dimnames = list(c(paste("Age", (1:number_age_class)-1)), c("Survie", "Fcondit"))))
thierrychambert
committed
}) # end observeEvent
# Update the vital rate matrix (mat_fill_vr) when changing species in the list
observeEvent({
input$species_choice
}, {
thierrychambert
committed
if(input$species_choice == "Espce gnrique") {
number_age_class <- input$vr_mat_number_age_classes
updateMatrixInput(session, inputId = "mat_fill_vr",
value = matrix(data = NA,
nrow = number_age_class,
ncol = 2,
dimnames = list(c(paste("Age", (1:number_age_class)-1)), c("Survie", "Fcondit"))))
thierrychambert
committed
} else {
tab_species <- make_mat_vr(data_sf = data_sf, species = input$species_choice)
if(all(is.na(tab_species))) {
thierrychambert
committed
number_age_class <- input$vr_mat_number_age_classes
updateMatrixInput(session, inputId = "mat_fill_vr",
value = matrix(data = NA,
thierrychambert
committed
nrow = number_age_class,
dimnames = list(c(paste("Age", (1:number_age_class)-1)), 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
# Display vital rates output table
delay(ms = 300,
output$vital_rates_info <- renderTable({
#input$mat_fill_vr
tab_species <- make_mat_vr(data_sf = data_sf, species = input$species_choice)
ages <- tab_species$classes_age
matrix(data = c(param$s_calib0, param$f_calib0),
nrow = length(param$s_calib0),
ncol = 2,
dimnames = list(ages, c("Survie", "Fcondit"))
)
}, rownames = TRUE)
)
thierrychambert
committed
# Display intrinsic lambda (based solely on Leslie matrix)
req(all(!is.na(input$mat_fill_vr)))
lam <- lambda(build_Leslie(s = param$s_calib0, f = param$f_calib0))
if(taux < 0) Text <- "Dclin : " else Text <- "Croissance : "
if(taux == 0) Text <- "Population stable : "
paste0(Text, taux, "% par an")
#####
#################################
## Dispersal
##-------------------------------
observeEvent({
input$species_choice
}, {
distAVG <- species_data %>%
filter(NomEspece == input$species_choice) %>%
select(DistDispMoyKM)
rv$distAVG <- round(distAVG, 1)
rv$dist <- c(round(-log(0.03)*distAVG, 1),
round(-log(0.05)*distAVG, 1),
round(-log(0.10)*distAVG, 1))
})
output$dispersal_mean_info <- renderText({
paste0("Distance moyenne de dispersion : ", rv$distAVG, " km")
})
output$dispersal_d03p_info <- renderText({
paste0("Seuil de distance quiv. 3% de dispersion : ", rv$dist[1], " km")
})
output$dispersal_d05p_info <- renderText({
paste0("Seuil de distance quiv. 5% de dispersion : ", rv$dist[2], " km")
})
output$dispersal_d10p_info <- renderText({
paste0("Seuil de distance quiv. 10% de dispersion : ", rv$dist[3], " km")
#####
##--------------------------------------------
## 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 == "cumulated"){
param$cumulated_impacts = TRUE
} else {
param$cumulated_impacts = FALSE
} # end if
}) # end observeEvent
#################################
## Fatalities
##-------------------------------
observe({
# Case 1 : Not cumulated effects (if1)
if(input$analysis_choice == "single_farm"){
# 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
param$fatalities_mean <- c(0, round(get_mu(lower = input$fatalities_lower, upper = input$fatalities_upper), 2))
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
} else {
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
if(input$analysis_choice == "cumulated"){
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
# Case 3 : Scenarios
}else{
req(input$fatalities_vec_scenario)
vec01 <- as.numeric(unlist(strsplit(input$fatalities_vec_scenario, " ")))
param$fatalities_mean <- c(0, vec01)
param$fatalities_se <- rep(0, length(vec01)+1)
param$onset_time <- NULL
ready$fatalities <- TRUE
}
} # 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, 1)
param$pop_size_se <- round(param$pop_size_eli_result$SE, 1)
ready$pop_size <- TRUE
} else {
ready$pop_size <- FALSE
}
} else {
if(input$pop_size_input_type == "val"){
# Case 2 : Values directly provided as mean & SE
ready$pop_size <- TRUE
param$pop_size_mean <- round(input$pop_size_mean, 1)
param$pop_size_se <- round(input$pop_size_se, 1)
}else{
# Case 3 : Values directly provided as lower/upper interval
ready$pop_size <- TRUE
param$pop_size_mean <- round(get_mu(lower = input$pop_size_lower, upper = input$pop_size_upper), 1)
param$pop_size_se <- round(get_sd(lower = input$pop_size_lower, upper = input$pop_size_upper, coverage = CP), 1)
}
param$pop_size_unit <- input$pop_size_unit
})
#################################
## Population growth
##-------------------------------
observe({
# Case 1 : Values from expert elicitation
if(input$pop_growth_input_type == "eli_exp"){
if(!(is.null(param$pop_growth_eli_result))){
thierrychambert
committed
param$pop_growth_mean <- round(param$pop_growth_eli_result$mean, 4)
param$pop_growth_se <- round(param$pop_growth_eli_result$SE, 5)
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") {
} else if(input$pop_trend_strength == "average"){
} else {
}
} else if(input$pop_trend == "decline"){
if(input$pop_trend_strength == "weak") {
} else if(input$pop_trend_strength == "average"){
} else {
}
} else {
# Case 3 : Values directly provided (i.e., not from expert elicitation)
} else {
if(input$pop_growth_input_type == "val"){
# Case 2 : Values directly provided as mean & SE
ready$pop_growth <- TRUE
thierrychambert
committed
param$pop_growth_mean <- round(make_lambda(input$pop_growth_mean), 4)
param$pop_growth_se <- round(input$pop_growth_se/100, 5)
}else{
# Case 3 : Values directly provided as lower/upper interval
ready$pop_growth <- TRUE
thierrychambert
committed
param$pop_growth_mean <- round(get_mu(lower = make_lambda(input$pop_growth_lower),
upper = make_lambda(input$pop_growth_upper)), 4)
param$pop_growth_se <- round(get_sd(lower = make_lambda(input$pop_growth_lower),
upper = make_lambda(input$pop_growth_upper), coverage = CP), 5)
}
}
})
#################################
## Carrying capacity
##------------------------------
observe({
if(input$carrying_cap_input_type == "eli_exp"){
if(!is.null(param$carrying_cap_eli_result)){
param$carrying_capacity_mean <- round(param$carrying_cap_eli_result$mean)
param$carrying_capacity_se <- round(param$carrying_cap_eli_result$SE, 1)
ready$carrying_capacity <- TRUE
} else {
ready$carrying_capacity <- FALSE
}
} else {
if(input$carrying_cap_input_type == "no_K"){
ready$carrying_capacity <- TRUE
param$carrying_capacity_mean <- max(param$pop_size_mean*100, 1e30) # use a very large K
param$carrying_capacity_se <- 0
if(input$carrying_cap_input_type == "val"){
ready$carrying_capacity <- TRUE
param$carrying_capacity_mean <- input$carrying_capacity_mean
param$carrying_capacity_se <- input$carrying_capacity_se
}else{
# lower/upper interval
ready$carrying_capacity <- TRUE
param$carrying_capacity_mean <- round(get_mu(lower = input$carrying_capacity_lower, upper = input$carrying_capacity_upper), 0)
param$carrying_capacity_se <- round(get_sd(lower = input$carrying_capacity_lower, upper = input$carrying_capacity_upper, coverage = CP), 1)
}
})
#############################################
##-------------------------------------------
param$survivals <- input$mat_fill_vr[,1]
param$fecundities <- input$mat_fill_vr[,2]
# for now, until calibration is really done
param$s_calib0 <- param$survivals
param$f_calib0 <- param$fecundities
}) # end observeEvent
#####
#############################################
## Calibration of survivals & fecundities
##-------------------------------------------
## Calibration 1 : just for information display
observeEvent({
thierrychambert
committed
print(param$pop_growth_mean)
vr_calib0 <- 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_calib0 <- head(vr_calib0, length(param$survivals))
param$f_calib0 <- tail(vr_calib0, length(param$fecundities))
})
## Calibration 2 : for simulation run
observeEvent({
input$run
},{
# We also define rMAX and theta here
rMAX_species <- rMAX_spp(surv = tail(param$survivals,1), afr = min(which(param$fecundities != 0)))
param$rMAX_species <- rMAX_species
thierrychambert
committed
param$pop_growth_mean_use <- round(min(1 + rMAX_species, param$pop_growth_mean), 4)
param$vr_calibrated <- calibrate_params(
thierrychambert
committed
inits = init_calib(s = param$survivals, f = param$fecundities, lam0 = param$pop_growth_mean_use),
f = param$fecundities, s = param$survivals, lam0 = param$pop_growth_mean_use
)
param$s_calibrated <- head(param$vr_calibrated, length(param$survivals))
param$f_calibrated <- tail(param$vr_calibrated, length(param$fecundities))
})
#####
thierrychambert
committed
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
############################################################
## Convert Fatalities as numbers (not rates)
##----------------------------------------------------------
# Make sure fatalities are expressed as "number" (not rate) for the run_simul function
se_prod2 <- function(mu1, se1, mu2, se2) sqrt((se1^2 * se2^2) + (se1^2 * mu2^2) + (mu1^2 * se2^2))
observeEvent({
input$run
},{
if(input$fatalities_unit == "h"){
pop_size_tot <- sum(pop_vector(pop_size = param$pop_size_mean, pop_size_type = param$pop_size_type, s = param$s_calibrated, f = param$f_calibrated)[-1])
param$fatalities_mean_nb <- (param$fatalities_mean/100) * pop_size_tot
param$fatalities_se_nb <- se_prod2(mu1 = param$fatalities_mean/100,
se1 = param$fatalities_se/100,
mu2 = pop_size_tot,
se2 = (pop_size_tot/param$pop_size_mean) * param$pop_size_se)
}else{
param$fatalities_mean_nb <- param$fatalities_mean
param$fatalities_se_nb <- param$fatalities_se
}
})
############################################################
## Observe parameter values to be used in simulations run
##----------------------------------------------------------
param$nsim <- input$nsim
param$fatal_constant <- input$fatalities_unit
param$time_horizon <- input$time_horizon
# This condition is used to avoid wild population swings in fast-paced species
if(max(param$fecundities) < 1.5){
param$coeff_var_environ <- coeff_var_environ
}else{
param$coeff_var_environ <- 0
}
}) # Close observEvent
observe ({
param # to ensure up-to-date values are run
}) # end observe
#####
## Function to translate time units in french
units_time_french <- function(u){
if(u == "secs") u_fr <- "secondes"
if(u == "mins") u_fr <- "minutes"
if(u == "hours") u_fr <- "heures"
if(u == "days") u_fr <- "jours"
if(u == "weeks") u_fr <- "semaines"
return(u_fr)
}
#####
##-----------------------------------------------------------------------------------
## RUN SIMULATIONS
##-----------------------------------------------------------------------------------
observeEvent({
input$run
}, {
thierrychambert
committed
print(param$pop_growth_mean_use)
thierrychambert
committed
if(ready$fatalities & ready$pop_size & ready$pop_growth & ready$carrying_capacity){
out$analysis_choice <- input$analysis_choice
out$species_choice <- input$species_choice
thierrychambert
committed
withProgress(message = 'Simulation progress', value = 0, {
out$run <- run_simul_shiny(nsim = param$nsim,
cumulated_impacts = param$cumulated_impacts,
fatalities_mean = param$fatalities_mean_nb,
fatalities_se = param$fatalities_se_nb,
thierrychambert
committed
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_use,
thierrychambert
committed
pop_growth_se = param$pop_growth_se,
thierrychambert
committed
survivals = param$s_calibrated,
fecundities = param$f_calibrated,
carrying_capacity_mean = param$carrying_capacity_mean,
carrying_capacity_se = param$carrying_capacity_se,
thierrychambert
committed
theta = param$theta,
rMAX_species = param$rMAX_species,
thierrychambert
committed
model_demo = NULL,
thierrychambert
committed
coeff_var_environ = param$coeff_var_environ,
fatal_constant = param$fatal_constant)
}) # Close withProgress
end_time <- Sys.time()
duration <- end_time - start_time
out$run_time <- paste(round(as.numeric(duration), 2), units_time_french(units(duration)))
print(out$run_time)
thierrychambert
committed
}else{
out$run <- NULL
out$msg <- "error_not_ready"
}
}) # Close observEvent
#####
#####
##-----------------------------------------------------------------------------------
## OUTPUTS
##-----------------------------------------------------------------------------------
### Run time
output$run_time <- renderText({
req(input$run > 0)
paste("Temps de calcul (simulations) :", out$run_time)
})
#######################################################################
## Impact : individual farms (for "cumulated impact" analysis only)
##---------------------------------------------------------------------
print_indiv_impact <- function(){
req(out$run)
res <- get_metrics(N = out$run$N, cumulated_impacts = TRUE)
n_farm <- (dim(res$indiv_farm$impact)[3]-1)
fil <- paste0(round(t(res$indiv_farm$impact[param$time_horizon, -2, -1]),2)*100, "%")
matrix(fil,
nrow = n_farm,
dimnames = list(paste("Parc",1:n_farm), c("Impact", "IC (min)", "IC (max)"))
)
} # end function print_impact
# Display title
output$title_indiv_impact_result <- renderText({
req(input$run > 0, out$analysis_choice == "cumulated")
paste("Rsultat : Impact de chaque parc olien, estim au bout de" , param$time_horizon, "ans")
})
# Display impact result (table)
output$indiv_impact_table <- renderTable({
req(input$run & out$analysis_choice == "cumulated")
print_indiv_impact()
}, rownames = TRUE)
##################################################
## Impact : GLOBAL (for all types of analysis)
##------------------------------------------------
print_impact <- function(){
req(out$run)
res <- get_metrics(N = out$run$N, cumulated_impacts = FALSE)
n_scen <- (dim(res$scenario$impact)[3]-1)
RowNam <- NULL
if(out$analysis_choice == "single_farm") RowNam <- c("Parc 1")
if(out$analysis_choice == "cumulated") RowNam <- c("Parc 1", paste("... + Parc", (2:n_scen)))
if(out$analysis_choice == "multi_scenario") RowNam <- paste("Scenario", (1:n_scen))
fil <- paste0(round(t(res$scenario$impact[param$time_horizon, -2, -1]),2)*100, "%")
matrix(fil,
nrow = n_scen,
dimnames = list(RowNam, c("Impact", "IC (min)", "IC (max)"))
)
# Display title
output$title_impact_result <- renderText({
req(input$run)
paste("Rsultat : Impact global estim au bout de" , param$time_horizon, "ans")
})
# Display impact result (table)
output$impact_table <- renderTable({
req(input$run)
print_impact()
}, rownames = TRUE)
#############################################
## Probability of extinction
##-------------------------------------------
print_PrExt <- function(){
req(out$run)
res <- get_metrics(N = out$run$N, cumulated_impacts = FALSE)
n_scen <- dim(res$scenario$impact)[3]
RowNam <- NULL
if(out$analysis_choice == "single_farm") RowNam <- c("Sans parc", "Avec parc")
if(out$analysis_choice == "cumulated") RowNam <- c("Sans parc", "+ Parc 1", paste("... + Parc", (3:n_scen)-1))
if(out$analysis_choice == "multi_scenario") RowNam <- paste("Scenario", (1:n_scen)-1)
fil <- paste0(round(t(res$scenario$Pext),2)*100, "%")
matrix(fil,
nrow = n_scen,
dimnames = list(RowNam, c("Probabilit d'extinction"))
)
} # end function print_PrExt
# Display title
output$title_PrExt_result <- renderText({
req(input$run)
paste("Rsultat : Probabilit d'extinction ", param$time_horizon, "ans")
# Display impact result (table)
output$PrExt_table <- renderTable({
req(input$run)
print_PrExt()
}, rownames = TRUE)
#############################################
## Plot Impacts
##-------------------------------------------
## Function to plot the impact
plot_out_impact <- function(){
n_scen <- dim(out$run$N)[3]
Legend <- NULL
if(out$analysis_choice == "single_farm") Legend <- c("Sans parc", "Avec parc")
if(out$analysis_choice == "cumulated") Legend <- c("Sans parc", "+ Parc 1", paste("... + Parc", (3:n_scen)-1))
if(out$analysis_choice == "multi_scenario") Legend <- paste("Scenario", (1:n_scen)-1)
plot_impact(N = out$run$N, onset_year = param$onset_year, percent = TRUE,
xlab = "\nAnne", ylab = "Impact relatif (%)\n", Legend = Legend)
output$title_impact_plot <- renderText({
if(input$run > 0){
"Rsultat : Impact relatif au cours du temps"
}
})
output$impact_plot <- renderPlot({
out$impact_plot <- plot_out_impact()
out$impact_plot
#############################################
## Plot Demographic Trajectories
##-------------------------------------------
# Function to plot trajectories
plot_out_traj <- function(){
if(is.null(out$run)) {
} else {
thierrychambert
committed
# Define Legend
Legend <- NULL
if(out$analysis_choice == "single_farm") Legend <- c("Sans parc", "Avec parc")
if(out$analysis_choice == "cumulated") Legend <- c("Sans parc", "+ Parc 1", paste("... + Parc", (3:n_scen)-1))
if(out$analysis_choice == "multi_scenario") Legend <- paste("Scenario", (1:n_scen)-1)
thierrychambert
committed
# Plot population trajectories
plot_traj(N = out$run$N, age_class_use = input$age_class_show, fecundities = param$f_calibrated, onset_year = param$onset_year,
xlab = "\nAnne", ylab = "Taille de population\n", Legend = Legend, ylim = c(0, NA))}
thierrychambert
committed
} # End function
output$title_traj_plot <- renderText({
if(input$run > 0){
"Graphique : Trajectoires dmographiques"
output$warning_traj_plot <- renderText({
if(input$run > 0){
"Attention : Il s'agit de prdictions en l'tat actuel des connaissances.
Personne ne peut prdire comment les facteurs d'influence dmographique (environnement, etc.)
vont voluer dans le futur. Donc personne ne peut prdire de faon exacte ce que sera la taille
de population dans plusieurs annes.\n
Ce graphe est simplementfourni titre informatif. Attention ne pas le sur-interprter.\n
L'impact des collisions doit tre valu partir des valeurs et du graphe ci-dessus, qui fournissent
une estimation plus robuste (c--d. moins sensibles aux postulats et incertitudes) de cet impact."
}
})
output$traj_plot <- renderPlot({
out$trajectory_plot <- plot_out_traj()
out$trajectory_plot
#############################################
## Save outputs for report
##-------------------------------------------
# Type d'analyse
observeEvent({
input$run
}, {
if(out$analysis_choice == "single_farm") out$analysis_choice_report <- "Impacts non cumuls"
if(out$analysis_choice == "cumulated") out$analysis_choice_report <- "Impacts cumuls"
if(out$analysis_choice == "multi_scenario") out$analysis_choice_report <- "Multiple scnarios"
})
observeEvent({
input$run
}, {
if(input$fatalities_unit == "M"){
out$fatalities_unit <- paste0("Unit : nombre de mortalits annuelles")
unit <- " mortalits"
}
if(input$fatalities_unit == "h"){
out$fatalities_unit <- paste0("Unit : taux de mortalit (%) annuel")
unit <- " %"
}
if(input$fatalities_input_type == "itvl"){
out$fatalities_input_type <- "Saisie : intervalle"
out$fatalities_val1 <- paste0("Min : ", input$fatalities_lower, unit, " ; ")
out$fatalities_val2 <- paste0("Max : ", input$fatalities_upper, unit)
}
if(input$fatalities_input_type == "val"){
out$fatalities_input_type <- "Saisie : estimation et erreur-type"
out$fatalities_val1 <- paste0("Valeur estime : ", input$fatalities_mean, unit, " ; ")
out$fatalities_val2 <- paste0("Erreur-type : ", input$fatalities_se, unit)
}
if(input$fatalities_input_type == "eli_exp"){
out$fatalities_input_type <- "Saisie : licitation d'experts"
out$fatalities_val1 <- paste0("Moyenne estime : ", round(param$fatalities_eli_result$mean, 2), unit, " ; ")
out$fatalities_val2 <- paste0("Erreur_type : ", round(param$fatalities_eli_result$SE, 2), unit)
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
# Population Size
observeEvent({
input$run
}, {
if(input$pop_size_unit == "Npair"){
out$pop_size_unit <- paste0("Unit : nombre de couples")
unit <- " couples"
}
if(input$pop_size_unit == "Ntotal"){
out$pop_size_unit <- paste0("Unit : effectif total")
unit <- " individus"
}
if(input$pop_size_input_type == "itvl"){
out$pop_size_input_type <- "Saisie : intervalle"
out$pop_size_val1 <- paste0("Min : ", input$pop_size_lower, unit, " ; ")
out$pop_size_val2 <- paste0("Max : ", input$pop_size_upper, unit)
}
if(input$pop_size_input_type == "val"){
out$pop_size_input_type <- "Saisie : estimation et erreur-type"
out$pop_size_val1 <- paste0("Valeur estime : ", input$pop_size_mean, unit, " ; ")
out$pop_size_val2 <- paste0("Erreur-type : ", input$pop_size_se, unit)
}
if(input$pop_size_input_type == "eli_exp"){
out$pop_size_input_type <- "Saisie : licitation d'experts"
out$pop_size_val1 <- paste0("Moyenne estime : ", round(param$pop_size_eli_result$mean, 2), unit, " ; ")
out$pop_size_val2 <- paste0("Erreur_type : ", round(param$pop_size_eli_result$SE, 2), unit)
}
})
# Population Growth rate
observeEvent({
input$run
}, {
unit <- "%"
if(input$pop_growth_input_type == "itvl"){
out$pop_growth_input_type <- "Saisie : intervalle"
out$pop_growth_val1 <- paste0("Min : ", input$pop_growth_lower, unit, " ; ")
out$pop_growth_val2 <- paste0("Max : ", input$pop_growth_upper, unit)
}
if(input$pop_growth_input_type == "val"){
out$pop_growth_input_type <- "Saisie : estimation et erreur-type"
out$pop_growth_val1 <- paste0("Valeur estime : ", input$pop_growth_mean, unit, " ; ")
out$pop_growth_val2 <- paste0("Erreur-type : ", input$pop_growth_se, unit)
}
if(input$pop_growth_input_type == "eli_exp"){
out$pop_growth_input_type <- "Saisie : licitation d'experts"
out$pop_growth_val1 <- paste0("Moyenne estime : ", round(param$pop_growth_eli_result$mean, 2), unit, " ; ")
out$pop_growth_val2 <- paste0("Erreur_type : ", round(param$pop_growth_eli_result$SE, 2), unit)
}
## TREND
if(input$pop_growth_input_type == "trend"){
out$pop_growth_input_type <- "Saisie : tendance"
if(input$pop_trend == "stable"){
V1 <- "Stable"
V2 <- NULL
}
if(input$pop_trend == "growth"){
V1 <- "En croissance"
if(input$pop_trend_strength == "weak") V2 <- "faible"
if(input$pop_trend_strength == "average") V2 <- "modre"
if(input$pop_trend_strength == "strong") V2 <- "forte"
}
if(input$pop_trend == "decline"){
V1 <- "En dclin"
if(input$pop_trend_strength == "weak") V2 <- "faible"
if(input$pop_trend_strength == "average") V2 <- "modr"
if(input$pop_trend_strength == "strong") V2 <- "fort"
}
out$pop_growth_val1 <- V1
out$pop_growth_val2 <- V2
}
})
# Carrying capacity
observeEvent({
input$run
}, {
if(input$pop_size_unit == "Npair"){
out$carrying_cap_unit <- paste0("Unit : nombre de couples")
unit <- " couples"
}
if(input$pop_size_unit == "Ntotal"){
out$carrying_cap_unit <- paste0("Unit : effectif total")
unit <- " individus"
}
if(input$carrying_cap_input_type == "itvl"){
out$carrying_cap_input_type <- "Saisie : intervalle"
out$carrying_cap_val1 <- paste0("Min : ", input$carrying_capacity_lower, unit, " ; ")
out$carrying_cap_val2 <- paste0("Max : ", input$carrying_capacity_upper, unit)
}
if(input$carrying_cap_input_type == "val"){
out$carrying_cap_input_type <- "Saisie : estimation et erreur-type"
out$carrying_cap_val1 <- paste0("Valeur estime : ", input$carrying_capacity_mean, unit, " ; ")
out$carrying_cap_val2 <- paste0("Erreur-type : ", input$carrying_capacity_se, unit)
}
if(input$carrying_cap_input_type == "eli_exp"){
out$carrying_cap_input_type <- "Saisie : licitation d'experts"
out$carrying_cap_val1 <- paste0("Moyenne estime : ", round(param$carrying_cap_eli_result$mean, 2), unit, " ; ")
out$carrying_cap_val2 <- paste0("Erreur_type : ", round(param$carrying_cap_eli_result$SE, 2), unit)
}
if(input$carrying_cap_input_type == "no_K"){
out$carrying_cap_input_type <- NULL
out$carrying_cap_val1 <- paste0("Absence de capacit de charge")
out$carrying_cap_val2 <- paste0("Justifi ou pas ??")
}
})
#####
##-----------------------------------------------------------------------------------
## REPORT
##-----------------------------------------------------------------------------------
output$report <- downloadHandler(
filename = "RapportEolpopTEST001.pdf",
content = function(file) {
# Copy the report file to a temporary directory before processing it, in
# case we don't have write permissions to the current working dir (which
# can happen when deployed).
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("./inst/ShinyApp/report.Rmd", tempReport, overwrite = TRUE)
# Set up parameters to pass to Rmd document
paramsRMD <- list(
intro = input$intro_report,
analysis = out$analysis_choice_report,
species = out$species_choice,
#def_pop_text = input$intro_report,
#vital_rates = out$vital_rates,
fatalities_input_type = out$fatalities_input_type,
fatalities_val1 = out$fatalities_val1,
fatalities_val2 = out$fatalities_val2,
pop_size_unit = out$pop_size_unit,
pop_size_input_type = out$pop_size_input_type,
pop_size_val1 = out$pop_size_val1,
pop_size_val2 = out$pop_size_val2,
pop_growth_input_type = out$pop_growth_input_type,
pop_growth_val1 = out$pop_growth_val1,
pop_growth_val2 = out$pop_growth_val2,
carrying_cap_unit = out$carrying_cap_unit,
carrying_cap_input_type = out$carrying_cap_input_type,
carrying_cap_val1 = out$carrying_cap_val1,
carrying_cap_val2 = out$carrying_cap_val2,
impact_plot = out$impact_plot,
trajectory_plot = out$trajectory_plot
)
# Knit the document, passing in the `params` list, and eval it in a
# child of the global environment (this isolates the code in the document
# from the code in this app).
rmarkdown::render(tempReport, output_file = file,
params = paramsRMD,
envir = new.env(parent = globalenv())
)
}
) # close downloadHandler
###################################################################################