From 344f0cea9a7bec3be492d41718b35945087d9fad Mon Sep 17 00:00:00 2001 From: statnmap Date: Thu, 2 Jun 2022 16:38:26 +0200 Subject: [PATCH] Page 4: show results outputs map Why? - Show simulation outputs What? - Modify simu outputs to create map Issues issue #89 --- NAMESPACE | 2 +- R/globals.R | 2 +- R/mod_c_third.R | 3 +- R/mod_c_third_fct_query_and_plot.R | 1 + R/mod_d_fourth.R | 108 ++++++++++++------ R/mod_d_fourth_fct.R | 11 +- data-raw/be-page4-future.Rmd | 44 +++++-- ...pecies_basin.Rd => nit_feature_species.Rd} | 17 +-- tests/testthat/test-mod_d_fourth_fct.R | 8 +- 9 files changed, 124 insertions(+), 72 deletions(-) rename man/{nit_feature_species_basin.Rd => nit_feature_species.Rd} (54%) diff --git a/NAMESPACE b/NAMESPACE index 3f0aaa1..92562c2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,7 +13,7 @@ export(get_help_bubble_entries) export(get_hybrid_model) export(launch_mongo) export(nit_feature) -export(nit_feature_species_basin) +export(nit_feature_species) export(plot_hsi) export(plot_hsi_nit) export(plot_nit) diff --git a/R/globals.R b/R/globals.R index 7f64668..15a1fb5 100644 --- a/R/globals.R +++ b/R/globals.R @@ -39,6 +39,6 @@ globalVariables(unique(c( "arrival", "climatic_model_code", "country", "departure", "distance", "latin_name_s", "Nmax", "phase", "proportion", "r_eh2", "surface_area", "survival", "survivingProportion", "withNatalStray", - # nit_feature_species_basin + # nit_feature_species "nit", "rolling_mean" ))) \ No newline at end of file diff --git a/R/mod_c_third.R b/R/mod_c_third.R index bf2f5f8..2de386b 100644 --- a/R/mod_c_third.R +++ b/R/mod_c_third.R @@ -170,8 +170,7 @@ mod_third_server <- function(id, r = r) { filter(basin_id == !!loco$selected_bv_id) %>% mutate(basin_name = diadesatlas.translate(basin_name, !!r$lg)) %>% collect() - - + loco$leaflet <- draw_bv_leaflet( bv_df = loco$bv_df, model_res = loco$model_res, diff --git a/R/mod_c_third_fct_query_and_plot.R b/R/mod_c_third_fct_query_and_plot.R index 49dfbb0..c570787 100644 --- a/R/mod_c_third_fct_query_and_plot.R +++ b/R/mod_c_third_fct_query_and_plot.R @@ -183,6 +183,7 @@ plot_nit <- function(model_res_filtered, ymax = nit_max, fill = .data[[with_colour_source]] ), alpha = 0.3) + + geom_vline(xintercept = 2001, colour = "gray", linetype = "dashed") + geom_line( aes(y = nit_movingavg, colour = .data[[with_colour_source]], diff --git a/R/mod_d_fourth.R b/R/mod_d_fourth.R index 9244fce..fbbb113 100644 --- a/R/mod_d_fourth.R +++ b/R/mod_d_fourth.R @@ -95,9 +95,9 @@ mod_fourth_ui <- function(id) { sliderInput( ns("date"), NULL, - min = 1950, + min = 1951, max = 2100, - value = 1950, + value = 1951, sep = "" ) ), @@ -118,7 +118,7 @@ mod_fourth_ui <- function(id) { "prediction_map_abundance_help" ) ), - plotOutput(ns("map")) + leafletOutput(ns("plot"), height = 600) ), w3css::w3_half( h4( @@ -153,7 +153,9 @@ mod_fourth_server <- function(id, r = r) { yearsimuend = rep(0.1, length(golem::get_golem_options('countries_mortalities_list'))) ), data_simulation = get_data_simulation(conn_eurodiad), - results = NULL + results = NULL, + model_res_filtered = NULL, + trigger_graphs = 0 ) mod_species_server( @@ -201,6 +203,7 @@ mod_fourth_server <- function(id, r = r) { # Run simulations ---- observeEvent(input$launch_simu, { + golem::invoke_js("disable", paste0("#", ns("launch_simu"))) # loco$data_simulation # countries <- golem::get_golem_options('countries_mortalities_list') # loco$mortalities @@ -215,7 +218,7 @@ mod_fourth_server <- function(id, r = r) { shiny::withProgress( message = 'Run Simulation', value = 0, session = session, { - loco$results <- runSimulation( + results <- runSimulation( selected_latin_name = loco$species, #selected_latin_name, scenario = input$scenario, hydiad_parameter = loco$data_simulation[["hydiad_parameter"]], # 11 rows @@ -228,42 +231,77 @@ mod_fourth_server <- function(id, r = r) { verbose = TRUE ) }) + + Nit_list <- get_model_nit(results) + + loco$model_res_filtered <- nit_feature_species( + Nit_list = Nit_list, + reference_results = loco$data_simulation[["reference_results"]], + selected_latin_name = loco$species) + + if (!is.null(loco$model_res_filtered)) { + loco$trigger_graphs <- loco$trigger_graphs + 1 + } + golem::invoke_js("reable", paste0("#", ns("launch_simu"))) }, ignoreInit = TRUE) # Show results ---- - output$map <- renderPlot({ - input$launch_simu - the_data <- loco$mortalities - names(the_data) <- c("X1", "X2", "X3") - ggplot(the_data) + - aes(X2, X3) + - geom_point() + - # ggplot(map_data("france"), aes(long, lat, group = group)) + - # geom_polygon() + - # geom_polygon( - # data = map_data("france") %>% - # dplyr::filter(region %in% sample( - # unique(map_data("france")$region), - # 3 - # )), - # aes(fill = region) - # ) + - # coord_map() + - theme_classic() + - guides( - fill = "none" + observeEvent(list(loco$trigger_graphs, r$lg), { + req(loco$model_res_filtered) + + # loco$ui_summary <- create_ui_summary_html( + # species = loco$species, + # date = input$date, + # basin_name = loco$selected_bv_name$basin_name, + # country = loco$selected_bv_name$country + # ) + + output$plot <- renderLeaflet({ + + req(loco$model_res_filtered) + loco$bind_event <- rnorm(10000) + + model_res <- loco$model_res_filtered %>% + filter(source == "simul") %>% + left_join(loco$data_simulation[["data_catchment"]] %>% collect(), + by = "basin_name") + + loco$bv_df <- get_bv_geoms( + unique(model_res$basin_id), + lg = r$lg, + session ) - }) + + draw_bv_leaflet( + bv_df = loco$bv_df, + model_res = model_res, + year = input$date + ) + + }) + }, ignoreInit = TRUE) - output$prediction <- renderPlot({ - input$launch_simu - p1 <- shinipsum::random_ggplot(type = "line") - p2 <- shinipsum::random_ggplot(type = "line") - getFromNamespace("/.ggplot", "patchwork")( - p1, p2 - ) - }) + observeEvent(list(loco$trigger_graphs, r$lg), { + # req(loco$trigger_graphs) + req(loco$model_res_filtered) + + basin <- 'Adour' + + # Plot Nit predictions + model_res_filtered <- loco$model_res_filtered %>% + filter(basin_name == basin) + + output$prediction <- renderPlot({ + # same function as for Page 3 + plot_nit(model_res_filtered, + selected_year = input$date, + lg = r$lg, + withNitStandardisation = FALSE, + with_colour_source = "source") + }) + }, ignoreInit = TRUE) + # UI dropdown menus ---- observeEvent(input$scenario, { golem::invoke_js( "changeinnerhtmlwithid", diff --git a/R/mod_d_fourth_fct.R b/R/mod_d_fourth_fct.R index 23bdc84..185cc7c 100644 --- a/R/mod_d_fourth_fct.R +++ b/R/mod_d_fourth_fct.R @@ -569,22 +569,20 @@ nit_feature <- function(data_list) { return(res) } -#' Get nit reference and predictions for one species and one basin +#' Get nit reference and predictions for one species and all basins #' #' @param Nit_list Nit_list as issued from [get_model_nit()] #' @param reference_results reference_results as issued from [prepare_datasets()] #' @param selected_latin_name Latin species name -#' @param basin Name of the basin #' #' @importFrom dplyr mutate bind_rows filter group_by summarise #' @importFrom dplyr ungroup #' @importFrom data.table frollmean #' @return data.frame of Nit results for one species and one basin #' @export -nit_feature_species_basin <- function(Nit_list, +nit_feature_species <- function(Nit_list, reference_results, - selected_latin_name, - basin) { + selected_latin_name) { nit_feature(Nit_list) %>% mutate(source = 'simul') %>% bind_rows( @@ -604,8 +602,7 @@ nit_feature_species_basin <- function(Nit_list, ungroup() ) %>% suppressWarnings() %>% - filter(basin_name == basin, - year >= 1951) %>% + filter(year >= 1951) %>% rename( nit_min = min, nit_max = max, diff --git a/data-raw/be-page4-future.Rmd b/data-raw/be-page4-future.Rmd index e557d84..683f56c 100644 --- a/data-raw/be-page4-future.Rmd +++ b/data-raw/be-page4-future.Rmd @@ -60,6 +60,7 @@ catchment_surface <- data_simulation[["catchment_surface"]] ```{r} session <- shiny::MockShinySession$new() +session$userData$con <- conn_eurodiad input <- list() datasets <- generate_datasets(con = conn_eurodiad) lang <- "fr" @@ -125,24 +126,47 @@ shiny::withProgress( # graphics ---- Nit_list <- get_model_nit(results) -basin <- 'Adour' +basin <- 'Garonne' -#' Plot Nit predictions -model_res_filtered <- nit_feature_species_basin( +# Plot Nit predictions +model_res_filtered <- nit_feature_species( Nit_list = Nit_list, reference_results = reference_results, - selected_latin_name = selected_latin_name, - basin = basin) + selected_latin_name = selected_latin_name) # same function as for Page 3 -plot_nit(model_res_filtered, - selected_year = 2073, - lg = "fr", - withNitStandardisation = FALSE, - with_colour_source = "source") +model_res_filtered %>% + filter(basin_name == basin) %>% + # filter(source == "reference") %>% + plot_nit(selected_year = 2073, + lg = "fr", + withNitStandardisation = FALSE, + with_colour_source = "source") ``` +## Leaflet + +```{r} +loco <- list() +loco$model_res <- model_res_filtered %>% + filter(source == "simul") %>% + left_join(data_simulation[["data_catchment"]] %>% collect(), + by = "basin_name") + +loco$bv_df <- get_bv_geoms( + unique(loco$model_res$basin_id), + lg = "fr", #r$lg, + session +) + +draw_bv_leaflet( + bv_df = loco$bv_df, + model_res = loco$model_res, + year = 2100 + ) +``` + ### Stop connection diff --git a/man/nit_feature_species_basin.Rd b/man/nit_feature_species.Rd similarity index 54% rename from man/nit_feature_species_basin.Rd rename to man/nit_feature_species.Rd index ea495b1..00d0fbc 100644 --- a/man/nit_feature_species_basin.Rd +++ b/man/nit_feature_species.Rd @@ -1,15 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/mod_d_fourth_fct.R -\name{nit_feature_species_basin} -\alias{nit_feature_species_basin} -\title{Get nit reference and predictions for one species and one basin} +\name{nit_feature_species} +\alias{nit_feature_species} +\title{Get nit reference and predictions for one species and all basins} \usage{ -nit_feature_species_basin( - Nit_list, - reference_results, - selected_latin_name, - basin -) +nit_feature_species(Nit_list, reference_results, selected_latin_name) } \arguments{ \item{Nit_list}{Nit_list as issued from [get_model_nit()]} @@ -17,12 +12,10 @@ nit_feature_species_basin( \item{reference_results}{reference_results as issued from [prepare_datasets()]} \item{selected_latin_name}{Latin species name} - -\item{basin}{Name of the basin} } \value{ data.frame of Nit results for one species and one basin } \description{ -Get nit reference and predictions for one species and one basin +Get nit reference and predictions for one species and all basins } diff --git a/tests/testthat/test-mod_d_fourth_fct.R b/tests/testthat/test-mod_d_fourth_fct.R index f1f36eb..3ffe2d6 100644 --- a/tests/testthat/test-mod_d_fourth_fct.R +++ b/tests/testthat/test-mod_d_fourth_fct.R @@ -170,12 +170,12 @@ test_that("runSimulation works", { ungroup() expect_equal(model_nit_outputs, mno_expected) - # nit_feature_species_basin ---- - model_res_filtered <- nit_feature_species_basin( + # nit_feature_species ---- + model_res_filtered <- nit_feature_species( Nit_list = Nit_list, reference_results = reference_results, - selected_latin_name = selected_latin_name, - basin = basin) + selected_latin_name = selected_latin_name) %>% + filter(basin_name == basin) mrf_object <- model_res_filtered %>% arrange(basin_name, year)