Skip to content

Commit

Permalink
Merge pull request #170 from inrae/page1_button
Browse files Browse the repository at this point in the history 
Page1 pop up with good informaton #153
Page1 remove division #152
Page1 button #168 
Page 4 simulation #151 #167
  • Loading branch information
@PMHLambert
PMHLambert authored May 15, 2023
2 parents 4f295bd + 7b6f392 commit 5a8c926
Show file tree
Hide file tree
Showing 10 changed files with 22,618 additions and 23,293 deletions.
35 changes: 22 additions & 13 deletions R/mod_a_first.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,19 +25,6 @@ mod_first_ui <- function(id) {
mod_species_ui(ns("species_ui_1"))
)
),
actionButton(ns("showaqua"),
label = 'AquaMaps'),
actionButton(ns("positive_catch"),
label = 'Positive catch'),

# radioButtons(
# ns("showaqua"),
# label = NULL,
# choices = c(
# "Hide AquaMaps" = "hide",
# "Show AquaMaps" = "show"
# )
# ),
w3css::w3_quarter()
)
),
Expand All @@ -60,6 +47,28 @@ mod_first_ui <- function(id) {
),
w3css::w3_col(
class = "s2",
actionButton(ns("showaqua"),
label = 'AquaMaps',
style = "background-color: #FFFF0080"),
# radioButtons(
# ns("showaqua"),
# label = NULL,
# choices = c(
# "Hide AquaMaps" = "hide",
# "Show AquaMaps" = "show"
# )
# ),
w3_help_button(
"Display AquaMpas",
"display_aquamaps_help"
),
actionButton(ns("positive_catch"),
label = with_i18('Positive catch', 'positive_catch_button'),
style = "background-color: #00FF0080"),
w3_help_button(
"Display positive catch",
"display_positive_catch_help"
),
h4(
with_i18(
"Conservation status",
Expand Down
2 changes: 1 addition & 1 deletion R/mod_a_first_fct_map.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,6 +38,7 @@ tm_ocean <- function(dataOcean,
title = paste0(title, "\n(", yearStart, "-", yearEnd, ")"),
palette = c("#F7FBFF", "#C6DBEF", "#9ECAE1", "#4292C6", "#08519C", "#08306B"),
n = 6,
alpha = .5,
border.col = "gray90",
labels = c(
"Not recorded in the period" %>% with_i18("absent") %>% as.character(),
Expand Down Expand Up @@ -144,7 +145,6 @@ bbox <- sf::st_bbox(c(xmin = -17.5, xmax = 19, ymax = 36, ymin = 62), crs = sf::
#' @param spatial_type Geom to use in the map
#' @param con The Connection object
#' @param yearStart,yearEnd date used
#' @param dataCatchment,catchment_geom,dataALL,ices_geom,ices_division internal datasets
#' @param dataCatchment,catchment_geom internal datasets for continental waters
#' @param dataALL,ices_geom,ices_division,positive_catch_area internal datasets for marines water
#' @param session The Shiny Session object
Expand Down
21 changes: 7 additions & 14 deletions data-raw/altas_simulation.R
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
# ==== Run this to create the dput for unit tests ====
library(tictoc)
#library(tictoc)
library(purrr)
# library(Rfast)
library(Matrix)
Expand All @@ -17,7 +17,6 @@ source('data-raw/preparation_atlas_simulation.R')
hydiad_parameter %>%
print()


# Anthropogenic mortality ----
# build from sliders in interface
# here fake data
Expand Down Expand Up @@ -55,8 +54,7 @@ selected_latin_name = "Alosa alosa"

runSimulation_pml = function(selected_latin_name, hydiad_parameter, anthropogenic_mortality,
catchment_surface, data_hsi_nmax, data_ni0, outlet_distance, verbose = FALSE) {
if (verbose) tic()


# --------------------------------------------------------------------------------------- #
results = list()

Expand Down Expand Up @@ -141,9 +139,6 @@ runSimulation_pml = function(selected_latin_name, hydiad_parameter, anthropogeni
arrange(year)
results[['param']][['years']] <- years

if (verbose) toc()

if (verbose) tic()
# ------------------------------------------------------------------------------- #
## compute Nmax_eh1 matrix and prepare Nit matrix ----
resultsPM <- results[["model"]] <- lapply(models, function(model) {
Expand Down Expand Up @@ -255,8 +250,6 @@ runSimulation_pml = function(selected_latin_name, hydiad_parameter, anthropogeni

#Rq: transpose of Besty's matrix (not sure now)

if (verbose) toc()

# for testing: resultsModel <- results[['model']][[1]]
# compute effective for 1 model ----
computeEffectiveForModel_PML = function(model, currentYear, results, generationtime, nbCohorts){
Expand Down Expand Up @@ -333,7 +326,6 @@ runSimulation_pml = function(selected_latin_name, hydiad_parameter, anthropogeni


# run simulation over years
if (verbose) tic()
for (currentYear in yearsToRun) {
# currentYear <- yearsToRun[1]
## print a progress bar to the console
Expand All @@ -343,17 +335,17 @@ runSimulation_pml = function(selected_latin_name, hydiad_parameter, anthropogeni

# dput(results, file = "tests/testthat/results_pml_dput")
cat('\n')
if (verbose) toc()


return(results)
}

# =======================================================================================================
# run simulation ----
tic()

results <- runSimulation_pml(selected_latin_name, hydiad_parameter, anthropogenic_mortality,
catchment_surface, data_hsi_nmax, data_ni0, outlet_distance, verbose = FALSE)
toc()


dput(results, file = "tests/testthat/results_pml_dput")
utils::zip("tests/testthat/results_pml_dput", zipfile = "tests/testthat/results_pml_dput.zip")
Expand Down Expand Up @@ -448,7 +440,8 @@ dput(model_res_filtered_pml, file = "tests/testthat/model_res_filtered_dput")
model_res_filtered_pml %>%
ggplot(aes(x = year)) +
geom_ribbon(aes(ymin = min, ymax = max, fill = source), alpha = .5) +
geom_line(aes(y = rolling_mean, colour = source, linetype = source),
geom_line(data = . %>% filter(!is.na(rolling_mean)),
aes(y = rolling_mean, colour = source, linetype = source),
alpha = 0.9) +
ylab('Nit')

Expand Down
203 changes: 119 additions & 84 deletions data-raw/preparation_atlas_simulation.R
View file
Original file line number Diff line number Diff line change
@@ -1,39 +1,35 @@
library(DBI)
# library(tidyverse)

library(tictoc)
library(tidyverse)

# rm(list = ls())
connection_sql = TRUE


# connection to the data base
if (connection_sql)
# conn_eurodiad <- dbConnect(RPostgres::Postgres(), dbname = 'eurodiad',
# host = 'citerne.bordeaux.irstea.priv',
# port = 5432,
# user = 'patrick.lambert',
# password = rstudioapi::askForPassword("Database password"))
conn_eurodiad <- connect()
pkgload::load_all(here::here()) # simulate installation and give access to objects in the package
# session <- shiny::MockShinySession$new() #new.env()
# connect(session)
# con <- get_con(session)
# connection to the data base
conn_eurodiad <- connect()

# data upload ----

# ---------------------------------------------------------------------- #
## Catchment features ----
if (connection_sql) {
data_catchment <- dbGetQuery(conn_eurodiad, "SELECT basin_id, basin_name, country, surface_area_drainage_basin as surface_area, ccm_area FROM diadesatlas.basin b
INNER JOIN diadesatlas.basin_outlet bo USING (basin_id);" ) %>%
data_catchment <- dbGetQuery(conn_eurodiad,
"SELECT
basin_id,
basin_name,
country,
surface_area_drainage_basin as surface_area,
ccm_area
FROM
diadesatlas.basin b
INNER JOIN
diadesatlas.basin_outlet bo
USING (basin_id);" ) %>%
tibble()


# write_rds(data_catchment, './data_input/data_catchment.rds')
} else {
data_catchment <- read_rds('./data_input/data_catchment.rds')
}

# ---------------------------------------------------------------------- #
## Distances between catchment ----
if ( connection_sql) {
outlet_distance = dbGetQuery(conn_eurodiad,"SELECT
outlet_distance = dbGetQuery(conn_eurodiad,
"SELECT
b.basin_name AS departure,
od.departure AS departure_id,
b2.basin_name AS arrival,
Expand All @@ -48,37 +44,54 @@ INNER JOIN diadesatlas.basin b2 ON
ORDER BY departure, distance ;") %>%
tibble()

# write_rds(outlet_distance, "./data_input/outletDistance.rds")
} else {
outlet_distance <- read_rds( "./data_input/outletDistance.rds")
}

# ---------------------------------------------------------------------- #
# HyDiaD parameters ----
if (connection_sql) {
hydiad_parameter <- dbGetQuery(conn_eurodiad, "
SELECT s.latin_name, s.local_name AS \"Lname\", h.* FROM diadesatlas.hydiadparameter h
INNER JOIN diadesatlas.species s USING (species_id);") %>%
hydiad_parameter <-
dbGetQuery(conn_eurodiad,
"SELECT
s.latin_name,
s.local_name AS \"Lname\",
h.*
FROM
diadesatlas.hydiadparameter h
INNER JOIN
diadesatlas.species s
USING (species_id);") %>%
tibble()

# hydiad_parameter %>% write_rds("./data_input/HyDiaDParameter.rds")

} else {
hydiad_parameter <- read_rds("./data_input/HyDiaDParameter.rds")
}


# ---------------------------------------------------------------------- #
## HSI abd Nmax ----
if (connection_sql) {
# a query to load HSI for only 8.5 scenario (which do not change between simulations)
query = "SELECT s.latin_name, basin_id, basin_name, country, surface_area_drainage_basin as surface_area, year, climatic_scenario, climatic_model_code, hsi FROM diadesatlas.hybrid_model_result hmr
INNER JOIN diadesatlas.species s USING (species_id)
INNER JOIN diadesatlas.basin b USING (basin_id)
INNER JOIN diadesatlas.climatic_model cm USING (climatic_model_id)
WHERE year > 0 AND climatic_scenario = 'rcp85'"

data_hsi_nmax <- dbGetQuery(conn_eurodiad, query) %>%
# a query to load HSI for only 8.5 scenario (which do not change between simulations)
query =
"SELECT
s.latin_name,
basin_id,
basin_name,
country,
surface_area_drainage_basin as surface_area,
year,
climatic_scenario,
climatic_model_code,
hsi
FROM
diadesatlas.hybrid_model_result hmr
INNER JOIN
diadesatlas.species s
USING (species_id)
INNER JOIN
diadesatlas.basin b
USING (basin_id)
INNER JOIN
diadesatlas.climatic_model cm
USING (climatic_model_id)
WHERE
year > 0
AND climatic_scenario = 'rcp85'"

data_hsi_nmax <- dbGetQuery(conn_eurodiad, query) %>%
tibble() %>%
# compute the maximum abundance (#) according to hsi,
# maximal density (Dmax) , catchment area (ccm_area)
Expand All @@ -88,53 +101,75 @@ WHERE year > 0 AND climatic_scenario = 'rcp85'"
mutate(Nmax = hsi * Dmax * surface_area) %>%
select(-c(surface_area, Dmax))

# write_rds(data_hsi_nmax, './data_input/data_hsi_Nmax.rds')

rm(query)
} else {
data_hsi_nmax <- read_rds('./data_input/data_hsi_Nmax.rds')
}
rm(query)


# No ccm_area for Bou_Regreg, Loukkos, Oum_er_Rbia, Sebou. use surface_area_drainage_basin

# reference results
if (connection_sql) {
reference_results <- dbGetQuery(conn_eurodiad,
"SELECT s.latin_name, basin_id, basin_name, year, climatic_scenario, climatic_model_code, nit FROM diadesatlas.hybrid_model_result hmr
INNER JOIN diadesatlas.species s USING (species_id)
INNER JOIN diadesatlas.basin b USING (basin_id)
INNER JOIN diadesatlas.climatic_model cm USING (climatic_model_id)
WHERE year > 0 AND climatic_scenario = 'rcp85'
ORDER BY latin_name, basin_id, climatic_model_code") %>%
reference_results <- dbGetQuery(conn_eurodiad,
"SELECT
s.latin_name,
basin_id,
basin_name,
year,
climatic_scenario,
climatic_model_code,
nit
FROM
diadesatlas.hybrid_model_result hmr
INNER JOIN
diadesatlas.species s
USING (species_id)
INNER JOIN
diadesatlas.basin b
USING (basin_id)
INNER JOIN
diadesatlas.climatic_model cm
USING (climatic_model_id)
WHERE
year > 0 AND
climatic_scenario = 'rcp85'
ORDER BY
latin_name,
basin_id,
climatic_model_code") %>%
tibble()

# write_rds(reference_results, './data_input/referenceResults.rds')
} else {
reference_results <- read_rds('./data_input/referenceResults.rds')
}


## initial abundance in catchments ----
if (connection_sql) {
data_ni0 <- dbGetQuery(conn_eurodiad, "SELECT s.latin_name, basin_id, basin_name, surface_area_drainage_basin as surface_area, year, climatic_scenario, climatic_model_code, nit, hsi FROM diadesatlas.hybrid_model_result hmr
INNER JOIN diadesatlas.species s USING (species_id)
INNER JOIN diadesatlas.basin b USING (basin_id)
INNER JOIN diadesatlas.climatic_model cm USING (climatic_model_id)
WHERE climatic_scenario = 'rcp85'
AND year = 0
ORDER BY latin_name, basin_id, climatic_model_code") %>%
data_ni0 <-
dbGetQuery(conn_eurodiad,
"SELECT
s.latin_name,
basin_id,
basin_name,
surface_area_drainage_basin as surface_area,
year,
climatic_scenario,
climatic_model_code,
nit,
hsi
FROM
diadesatlas.hybrid_model_result hmr
INNER JOIN
diadesatlas.species s
USING (species_id)
INNER JOIN
diadesatlas.basin b
USING (basin_id)
INNER JOIN
diadesatlas.climatic_model cm
USING (climatic_model_id)
WHERE
climatic_scenario = 'rcp85'
AND year = 0
ORDER BY
latin_name,
basin_id,
climatic_model_code") %>%
tibble() %>%
inner_join(hydiad_parameter %>%
select(latin_name, Dmax),
by = 'latin_name') %>%
mutate(Nmax = hsi * Dmax * surface_area) %>%
select(-c(surface_area, Dmax))

# write_rds(data_ni0, './data_input/data_ni0.rds')
} else {
data_ni0 <- read_rds('./data_input/data_ni0.rds')
}

#

Loading

0 comments on commit 5a8c926

Please sign in to comment.