", times = times)) -} - -#' Create an url -#' -#' @param url the URL -#' @param text the text to display -#' -#' @return an a tag -#' @noRd -#' -#' @examples -#' enurl("https://www.thinkr.fr", "ThinkR") -#' @importFrom shiny tags -enurl <- function(url, text) { - tags$a(href = url, text) -} - -#' Columns wrappers -#' -#' These are convenient wrappers around -#' `column(12, ...)`, `column(6, ...)`, `column(4, ...)`... -#' -#' @noRd -#' -#' @importFrom shiny column -col_12 <- function(...) { - column(12, ...) -} - -#' @importFrom shiny column -col_10 <- function(...) { - column(10, ...) -} - -#' @importFrom shiny column -col_8 <- function(...) { - column(8, ...) -} - -#' @importFrom shiny column -col_6 <- function(...) { - column(6, ...) -} - - -#' @importFrom shiny column -col_4 <- function(...) { - column(4, ...) -} - - -#' @importFrom shiny column -col_3 <- function(...) { - column(3, ...) -} - - -#' @importFrom shiny column -col_2 <- function(...) { - column(2, ...) -} - - -#' @importFrom shiny column -col_1 <- function(...) { - column(1, ...) -} - - - -#' Make the current tag behave like an action button -#' -#' Only works with compatible tags like button or links -#' -#' @param tag Any compatible tag. -#' @param inputId Unique id. This will host the input value to be used -#' on the server side. -#' -#' @return The modified tag with an extra id and the action button class. -#' @noRd -#' -#' @examples -#' if (interactive()) { -#' library(shiny) -#' -#' link <- a(href = "#", "My super link", style = "color: lightblue;") -#' -#' ui <- fluidPage( -#' make_action_button(link, inputId = "mylink") -#' ) -#' -#' server <- function(input, output, session) { -#' observeEvent(input$mylink, { -#' showNotification("Pouic!") -#' }) -#' } -#' -#' shinyApp(ui, server) -#' } -make_action_button <- function(tag, inputId = NULL) { - # some obvious checks - if (!inherits(tag, "shiny.tag")) stop("Must provide a shiny tag.") - if (!is.null(tag$attribs$class)) { - if (grep("action-button", tag$attribs$class)) { - stop("tag is already an action button") - } - } - if (is.null(inputId) && is.null(tag$attribs$id)) { - stop("tag does not have any id. Please use inputId to be able to - access it on the server side.") - } - - # handle id - if (!is.null(inputId)) { - if (!is.null(tag$attribs$id)) { - warning( - paste( - "tag already has an id. Please use input$", - tag$attribs$id, - "to access it from the server side. inputId will be ignored." - ) - ) - } else { - tag$attribs$id <- inputId - } - } - - # handle class - if (is.null(tag$attribs$class)) { - tag$attribs$class <- "action-button" - } else { - tag$attribs$class <- paste(tag$attribs$class, "action-button") - } - # return tag - tag -} - - -# UNCOMMENT AND USE -# -# attachment::att_amend_desc() -# -# To use this part of the UI -# -#' #' Include Content From a File -#' #' -#' #' Load rendered RMarkdown from a file and turn into HTML. -#' #' -#' #' @rdname includeRMarkdown -#' #' @export -#' #' -#' #' @importFrom rmarkdown render -#' #' @importFrom markdown markdownToHTML -#' #' @importFrom shiny HTML -#' includeRMarkdown <- function(path){ -#' -#' md <- tempfile(fileext = '.md') -#' -#' on.exit(unlink(md),add = TRUE) -#' -#' rmarkdown::render( -#' path, -#' output_format = 'md_document', -#' output_dir = tempdir(), -#' output_file = md,quiet = TRUE -#' ) -#' -#' html <- markdown::markdownToHTML(md, fragment.only = TRUE) -#' -#' Encoding(html) <- "UTF-8" -#' -#' return(HTML(html)) -#' } diff --git a/R_old/mod_classes_distribution.R b/R_old/mod_classes_distribution.R deleted file mode 100644 index 60ee260..0000000 --- a/R_old/mod_classes_distribution.R +++ /dev/null @@ -1,149 +0,0 @@ -#' classes_distribution UI Function -#' -#' @description A shiny Module. -#' -#' @import shiny -#' @importFrom shinyjs useShinyjs -#' @importFrom plotly plotlyOutput -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_classes_distribution_ui <- function(id){ - ns <- NS(id) - tagList( - useShinyjs(), - fluidRow( - style = "margin-top: 10px;", - textOutput(ns("placeholder_ui")), - column(width = 8, - plotlyOutput(ns("barplots_classes_metricUI")) - ) - ) - ) -} - -#' classes_distribution Server Functions -#' -#' @import shiny -#' @importFrom plotly renderPlotly -#' @noRd -mod_classes_distribution_server <- function(id, r_val){ - moduleServer( id, function(input, output, session){ - ns <- session$ns - - r_val_local <- reactiveValues( - barplots_classes_metric = NULL, - placeholder_text = "Sélectionnez un cours d'eau sur la carte et appliquez une classification pour afficher le graphique." - ) - - # text placeholder - output$placeholder_ui <- renderText({ - r_val_local$placeholder_text - }) - - # barplots showing distribution of classes - output$barplots_classes_metricUI <- renderPlotly({ - r_val_local$barplots_classes_metric - }) - - # listen to network changes and classify if new one is selected - observeEvent(c(r_val$network_region, r_val$classes_proposed_selected, r_val$manual_classes_table, r_val$tab_open2), { - - if (!is.null(r_val$network_region)) { - - # check if tab is open - if (r_val$tab_open2 == "Distribution des classes") { - - # classes proposed - if ((r_val$visualization == "classes") && !is.null(r_val$classes_proposed_selected)) { - - # Create classified network by adding the classes and colors - r_val$network_region_classified <- r_val$network_region %>% - na.omit() %>% - assign_classes_proposed(proposed_class = classes_proposed[r_val$classes_proposed_selected,]$class_name) - } - # classes manually selected - else if ((r_val$visualization == "manual") && !is.null(r_val$manual_classes_table)) { - - # Create classified network by adding the classes and colors - r_val$network_region_classified <- r_val$network_region %>% - na.omit() %>% - assign_classes_manual(classes = r_val$manual_classes_table) - } - - r_val$dgo_axis_classified = NULL - } - } - }) - - # listen to axis changes and classify if new one is selected - observeEvent(c(r_val$dgo_axis, r_val$classes_proposed_selected, r_val$manual_classes_table, r_val$tab_open2), { - - if (!is.null(r_val$dgo_axis)) { - - # check if tab is open - if (r_val$tab_open2 == "Distribution des classes") { - - # classes proposed - if ((r_val$visualization == "classes") && !is.null(r_val$classes_proposed_selected)){ - - # create classified axis network - r_val$dgo_axis_classified <- r_val$dgo_axis %>% - na.omit() %>% - assign_classes_proposed(proposed_class = classes_proposed[r_val$classes_proposed_selected,]$class_name) - } - # classes manually selected - else if ((r_val$visualization == "manual") && !is.null(r_val$manual_classes_table)) { - - # create classified axis network - r_val$dgo_axis_classified <- r_val$dgo_axis %>% - na.omit() %>% - assign_classes_manual(classes = r_val$manual_classes_table) - } - } - } - }) - - # classify regional and axis network and merge them - observeEvent(c(r_val$network_region_classified, r_val$dgo_axis_classified), { - - # check if tab is opend - if (r_val$tab_open2 == "Distribution des classes"){ - - # classes proposed - if (r_val$visualization == "classes") { - # merge regional and axis network in one df - r_val$merged_networks_classified <- merge_regional_axis_dfs(r_val$network_region_classified, - r_val$dgo_axis_classified, - "talweg_elevation_min", - classes = TRUE) - - } else if ((r_val$visualization == "manual") && !is.null(r_val$manual_classes_table)) { - - # merge regional and axis network in one df - r_val$merged_networks_classified <- merge_regional_axis_dfs(r_val$network_region_classified, - r_val$dgo_axis_classified, - r_val$manual_classes_table$variable[1], - classes = TRUE) - } - } - }) - - # create barplots of classes distribution - observeEvent(r_val$merged_networks_classified, { - if (!is.null(r_val$merged_networks_classified)) { - r_val_local$barplots_classes_metric <- create_plotly_barplot(r_val$merged_networks_classified) - r_val_local$placeholder_text = NULL - } else { - r_val_local$placeholder_text = "Sélectionnez une région sur la carte et appliquez une classification pour afficher le graphique." - r_val_local$barplots_classes_metric = NULL - } - }) - - - }) -} - diff --git a/R_old/mod_classification_manual.R b/R_old/mod_classification_manual.R deleted file mode 100644 index b2a3d27..0000000 --- a/R_old/mod_classification_manual.R +++ /dev/null @@ -1,364 +0,0 @@ - -# UI ---------------------------------------------------------------------- - -#' classification_manual UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @import shiny -#' @importFrom bslib accordion accordion_panel -#' @importFrom shinyjs useShinyjs -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_classification_manual_ui <- function(id){ - ns <- NS(id) - tagList( - golem_add_external_resources(), - useShinyjs(), - fluidRow( - style = "margin-top: 10px;", - textOutput(ns("metric_placeholder_descriptionUI")) - ), - fluidRow( - uiOutput(ns("metric_selectUI")) - ), - fluidRow( - uiOutput(ns("classificationUI")) - ) - ) -} - - -# SERVER ------------------------------------------------------------------ - -#' classification_manual Server Functions -#' -#' @import shiny -#' @importFrom htmltools HTML div img -#' @importFrom dplyr filter mutate if_else pull bind_cols arrange add_row -#' @importFrom tibble tibble -#' @importFrom bslib sidebar page_sidebar -#' @importFrom leaflet removeControl clearGroup -#' @importFrom leaflet.extras addWMSLegend -#' @importFrom shinyjs onclick runjs -#' @importFrom colourpicker colourInput -#' @noRd -mod_classification_manual_server <- function(id, con, r_val){ - moduleServer( id, function(input, output, session){ - ns <- session$ns - - - ### REACTIVES #### - r_val_local <- reactiveValues( - metric_placeholder_description = "Cliquez sur une région hydrographique pour afficher la classification de métriques. ", - ui_metric = NULL, # metric selection element - - # classification - classification_ui = NULL, # UI placeholder - scale_selectUI = NULL, # scale selection element - initial_classes_table = NULL, # datainput for table - - reactableUI = NULL # reactable table - ) - - ### OUTPUTS #### - output$metric_placeholder_descriptionUI <- renderText({ - r_val_local$metric_placeholder_description - }) - - # metric select input - output$metric_selectUI <- renderUI({ - if (!is.null(r_val_local$ui_metric)) { - div( - style = "display: flex; align-items: center; margin-left: 20px", - r_val_local$ui_metric, - span( - style = "display: flex; margin-left: 10px; margin-top: -10px", - popover( - trigger = bsicons::bs_icon("info-circle"), - "", - placement = "right", - id = ns("popover_metric") - ) - ) - ) - } - }) - - # classification UI enabling creation of different classes based on selected metric - output$classificationUI <- renderUI({ - r_val_local$classification_ui - }) - - # classification UI enabling creation of different classes based on selected metric - output$scale_select_UI <- renderUI({ - r_val_local$scale_selectUI - }) - - # reactable table of classes - output$reactable_classes <- renderUI({ - r_val_local$reactableUI - }) - - - ### EVENTS #### - - # update infobutton when metric selected changes for the first and second metric - observe({ - if (!is.null(input$metric)) { - update_popover("popover_metric", - HTML(metrics_params %>% - filter(metric_name == input$metric) %>% - pull(metric_description))) - } - }) - - #### region clicked first time #### - observeEvent(c(r_val$region_clicked, r_val$tab_open1), { - - if ((r_val$region_clicked == TRUE) && - # check if tab is open - (r_val$tab_open1 == "Classification manuelle")) { - - # remove placeholder text - r_val_local$metric_placeholder_description = NULL - - # create elements of manual grouping pane - r_val_local$ui_metric = selectInput(ns("metric"), NULL, - choices = params_get_metric_choices(), - selected = params_get_metric_choices()[1], - width = "100%") - - # create classification UI - r_val_local$classification_ui <- fluidPage( - fluidRow( - page_sidebar( - sidebar = sidebar( - fluidRow( - column(width = 7, - numericInput(inputId = ns("man_grouping_quantile"), - "Quantile [%]", value = 95, min = 0, max = 100) - ), - column(width = 5, - numericInput(inputId = ns("man_grouping_no_classes"), - "Classes", value = 4, min = 2, max = 10, step = 1) - ), - uiOutput(ns("scale_select_UI")), - actionButton(inputId = ns("recalculate_classes_button"), "Recalculer classes") - ), open = "closed", width = 220, position = "right" - ), - uiOutput(ns("reactable_classes")), - actionButton(inputId = ns("apply_to_map_button"), "Ajouter à la carte") - )) - ) - - # create classes-table to initialize classes UI - r_val_local$initial_classes_table = create_df_input( - axis_data = r_val$network_region, - variable_name = params_get_metric_choices()[[1]], - no_classes = 4, - quantile = 95 - ) - } - - }) - - #### region selected #### - observeEvent(c(r_val$region_click, r_val$tab_open1), { - - if (r_val$tab_open1 == "Classification manuelle") { - - # change scale selection UI - r_val_local$scale_selectUI = radioButtons(ns("man_grouping_scale_select"), - "Base de classification", - c("Région"), - selected = "Région", - inline = TRUE) - } - }) - - #### axis clicked first time #### - observe({ - - if ((r_val$axis_clicked == TRUE) && (r_val$tab_open1 == "Classification manuelle")){ - - # change scale selection UI - r_val_local$scale_selectUI = radioButtons(ns("man_grouping_scale_select"), - "Base de classification", - c("Région", "Axe fluvial"), - selected = "Région", - inline = TRUE) - } - }) - - #### metric change / re-calculation clicked #### - observeEvent(c(r_val$region_clicked, r_val$tab_open1), { - - if (r_val$tab_open1 == "Classification manuelle") { - - # check for valid selected metric - if (!is.null(input$metric) && - !is.null(r_val$network_region) && - (r_val$region_clicked == TRUE)) { - - # create classes-table - r_val_local$initial_classes_table = create_df_input( - axis_data = r_val$network_region, - variable_name = input$metric, - no_classes = input$man_grouping_no_classes, - quantile = input$man_grouping_quantile - ) - } - } - }) - - #### changes affecting classes #### - observeEvent(c(input$metric, r_val$network_region, input$recalculate_classes_button), { - - if (r_val$tab_open1 == "Classification manuelle") { - if (!is.null(input$metric) && - !is.null(input$man_grouping_scale_select)) { - - # region selected - if (input$man_grouping_scale_select == "Région" && - !is.null(r_val$network_region)) { - - # create classes-table - r_val_local$initial_classes_table = create_df_input( - axis_data = r_val$network_region, - variable_name = input$metric, - no_classes = input$man_grouping_no_classes, - quantile = input$man_grouping_quantile - ) - } - # axis selected - else if (input$man_grouping_scale_select == "Axe fluvial" && - !is.null(r_val$dgo_axis) ) { - - # create classes-table - r_val_local$initial_classes_table = create_df_input( - axis_data = r_val$dgo_axis, - variable_name = input$metric, - no_classes = input$man_grouping_no_classes, - quantile = input$man_grouping_quantile - ) - } - } - # when scale selection not created - else if (!is.null(input$metric) && - is.null(input$man_grouping_scale_select) && - !is.null(r_val$network_region)) { - - # create classes-table - r_val_local$initial_classes_table = create_df_input( - axis_data = r_val$network_region, - variable_name = input$metric, - no_classes = 4, - quantile = 95 - ) - } - } - - }) - - - #### UI classes creation #### - # update input fields for classification when setting the variables in the UI - observeEvent(r_val_local$initial_classes_table, { - - if (!is.null(r_val_local$initial_classes_table)) { - - # create classes UI - r_val_local$reactableUI = - renderUI({ - # Start with a list to collect UI elements - ui_elements <- list() - - # Add the first row of inputs - ui_elements[[1]] <- fluidRow( - column(width = 5, textInput(ns("class1"), label = "Classe", value = r_val_local$initial_classes_table$class[1])), - column(width = 3, colourInput(ns("color1"), label = "Couleur", - value = r_val_local$initial_classes_table$color[1], - showColour = "background", closeOnClick = TRUE)), - column(width = 4, numericInput(ns("greaterthan1"), label = "supérieur à", value = r_val_local$initial_classes_table$greaterthan[1])) - ) - - # Loop through the remaining rows and add inputs - for (row in 2:nrow(r_val_local$initial_classes_table)) { - ui_elements[[row]] <- fluidRow( - column(width = 5, textInput(ns(paste0("class", row)), label = NULL, value = r_val_local$initial_classes_table$class[row])), - column(width = 3, colourInput(ns(paste0("color", row)), label = NULL, - value = r_val_local$initial_classes_table$color[row], - showColour = "background", closeOnClick = TRUE)), - column(width = 4, numericInput(ns(paste0("greaterthan", row)), label = NULL, value = r_val_local$initial_classes_table$greaterthan[row])) - ) - } - - # Return the list of UI elements wrapped in tagList - do.call(tagList, ui_elements) - }) - } - }) - - #### apply-to-map button clicked #### - observeEvent(input$apply_to_map_button,{ - - r_val$visualization = "manual" - }) - - #### visualisation switched to manual #### - observeEvent(c(r_val$visualization, r_val$region_click, input$apply_to_map_button), { - - if (r_val$visualization == "manual") { - - # create classes table from input - # Initialize an empty tibble - r_val$manual_classes_table <- tibble(variable = character(), class = character(), greaterthan = numeric(), color = character()) - - # Add rows to the tibble looping through number of classes - if (!is.null(input$man_grouping_no_classes)) { - for (row in 1:input$man_grouping_no_classes) { - r_val$manual_classes_table <- r_val$manual_classes_table %>% - add_row(variable = input$metric, - class = input[[paste0("class", row)]], - greaterthan = input[[paste0("greaterthan", row)]], - color = input[[paste0("color", row)]]) - } - } else { - for (row in 1:4) { - r_val$manual_classes_table <- r_val$manual_classes_table %>% - add_row(variable = input$metric, - class = input[[paste0("class", row)]], - greaterthan = input[[paste0("greaterthan", row)]], - color = input[[paste0("color", row)]]) - } - } - - - # sort classes - classes <- r_val$manual_classes_table %>% - dplyr::arrange(greaterthan) %>% - dplyr::mutate(greaterthan = round(greaterthan, 2)) - - # build SLD symbology - r_val$sld_body = sld_get_style( - breaks = classes$greaterthan, - colors = classes$color, - metric = classes$variable[1] - ) - - # add classified network to map - r_val$map_proxy %>% - map_metric(wms_params = params_wms()$metric, - cql_filter = paste0("gid_region=",r_val$selected_region_feature[["gid"]]), - sld_body = r_val$sld_body, - data_axis = r_val$network_region_axis) - } - - }) - }) -} diff --git a/R_old/mod_classification_proposed - Copie.R b/R_old/mod_classification_proposed - Copie.R deleted file mode 100644 index 07e801c..0000000 --- a/R_old/mod_classification_proposed - Copie.R +++ /dev/null @@ -1,103 +0,0 @@ -#' classification_proposed UI Function -#' -#' @description A shiny Module. -#' -#' @import shiny -#' @importFrom shinyjs useShinyjs -#' @importFrom reactable reactableOutput -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_classification_proposed_ui <- function(id){ - ns <- NS(id) - tagList( - useShinyjs(), - fluidRow( - style = "margin-top: 10px;", - textOutput(ns("placeholder_ui")), - reactableOutput(ns("table"), width = "100%") - ) - ) -} - -#' classification_proposed Server Functions -#' -#' @import shiny -#' @importFrom reactable renderReactable getReactableState updateReactable -#' -#' @noRd -mod_classification_proposed_server <- function(id, r_val){ - moduleServer( id, function(input, output, session){ - ns <- session$ns - - r_val_local <- reactiveValues( - classes_tbl = NULL, - table = NULL, - placeholder_text = "Sélectionnez une région hydrographique sur la carte pour afficher la classification.", - selected = NULL - ) - - # text placeholder - output$placeholder_ui <- renderText({ - r_val_local$placeholder_text - }) - - output$table <- renderReactable( - r_val_local$table - ) - - # build table when region first time clicked - observeEvent(r_val$region_clicked, { - - if (!is.null(r_val$region_click)) { - r_val_local$placeholder_text = NULL - r_val_local$table = create_table_fluvialstyles(classes_proposed) - } - }) - - # create table output and add classification to map when region changed or other variable selected - observeEvent(c(input$table__reactable__selected, r_val$region_click), { - - # get actual selected classification from table - selected <- getReactableState("table", "selected") - - # check if row is actually selected - if (!is.null(selected)) { - - # create map styling based on selected classification - r_val$sld_body = classes_proposed[selected,]$class_sld - - # add styling to map - r_val$map_proxy %>% - map_class(wms_params = params_wms()$class, - cql_filter = paste0("gid_region=",r_val$selected_region_feature[["gid"]]), - sld_body = r_val$sld_body, - style = paste0("mapdo:", classes_proposed[selected,]$sld_style), - data_axis = r_val$network_region_axis) - - # set visualisation to classes to tell app that proposed classes are selected - r_val$visualization = "classes" - - r_val_local$selected = selected - } - }) - - observeEvent(r_val_local$selected, { - if (!is.null(r_val_local$selected)) { - r_val$classes_proposed_selected = r_val_local$selected - } - - }) - - - # check if other visualization is applied to map and de-select all proposed classifications - observeEvent(r_val$visualization, { - if (r_val$visualization != "classes") { - updateReactable("table", selected = NA) - } - }) - }) -} diff --git a/R_old/mod_classification_proposed.R b/R_old/mod_classification_proposed.R deleted file mode 100644 index bcb596a..0000000 --- a/R_old/mod_classification_proposed.R +++ /dev/null @@ -1,91 +0,0 @@ -#' classification_proposed UI Function -#' -#' @description A shiny Module. -#' -#' @import shiny -#' @importFrom shinyjs useShinyjs -#' @importFrom reactable reactableOutput -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_classification_proposed_ui <- function(id){ - ns <- NS(id) - tagList( - useShinyjs(), - fluidRow( - style = "margin-top: 10px;", - textOutput(ns("placeholder_ui")), - reactableOutput(ns("table"), width = "100%") - ) - ) -} - -#' classification_proposed Server Functions -#' -#' @import shiny -#' @importFrom reactable renderReactable getReactableState updateReactable -#' -#' @noRd -mod_classification_proposed_server <- function(id, r_val, globals){ - moduleServer( id, function(input, output, session){ - ns <- session$ns - - r_val_local <- reactiveValues( - classes_tbl = NULL, - table = NULL, - selected = NULL - ) - - # build table - output$table <- renderReactable( - create_table_fluvialstyles(globals$classes_proposed) - ) %>% - bindCache(globals$classes_proposed$sld_style) - - - # create table output and add classification to map when other variable selected - # observeEvent(input$table__reactable__selected, { - # - # # get actual selected classification from table - # selected <- getReactableState("table", "selected") - # - # # check if row is actually selected - # if (!is.null(selected)) { - # - # # create map styling based on selected classification - # r_val$sld_body = classes_proposed[selected,]$class_sld - # - # # add styling to map - # r_val$map_proxy %>% - # map_class(wms_params = params_wms()$class, - # cql_filter = paste0("gid_region=",r_val$selected_region_feature[["gid"]]), - # sld_body = r_val$sld_body, - # style = paste0("mapdo:", classes_proposed[selected,]$sld_style), - # data_axis = r_val$network_region_axis) - # - # # set visualisation to classes to tell app that proposed classes are selected - # r_val$visualization = "classes" - # - # r_val_local$selected = selected - # } - # }) - - # observeEvent(r_val_local$selected, { - # if (!is.null(r_val_local$selected)) { - # r_val$classes_proposed_selected = r_val_local$selected - # } - # - # }) - - - # check if other visualization is applied to map and de-select all proposed classifications - # observeEvent(r_val$visualization, { - # if (r_val$visualization != "classes") { - # updateReactable("table", selected = NA) - # } - # }) - }) -} diff --git a/R_old/mod_documentation.R b/R_old/mod_documentation.R deleted file mode 100644 index e3ab30b..0000000 --- a/R_old/mod_documentation.R +++ /dev/null @@ -1,49 +0,0 @@ -#' documentation UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @import shiny -mod_documentation_ui <- function(id){ - ns <- NS(id) - tagList( - golem_add_external_resources(), - fluidPage( - HTML(" -
MAPD'O est un projet visant le développement d'une interface web à l'intention des opérateurs autour des données et modèles en hydromorphologie. C'est un projet réalisé par le laboratoire Environnement Ville Société du CNRS et porté par l'Office Français de la Biodiversité depuis janvier 2023.
- -L'application repose sur des approches géomatiques d'analyse de la topographie et de l'occupation du sol permettant de produire une carte de continuité latérale des cours d'eau du réseau hydrographique. Différentes métriques morphologiques sont ensuite extraites à intervalle régulier du réseau (largeur, pente, surface drainée, élévation). L'application a pour ambition de fournir des outils d'analyse et d'interprétation de ces métriques afin de faciliter les diagnostics hydromorphologiques des cours d'eau français à l'échelle du bassin versant.
- -L'application dispose aujourd'hui d'un module d'exploration des données permettant de visualiser les différentes métriques mises à disposition pour l'analyse de bassin versant.
- "), - HTML(" -Contact : Lise Vaudor (CNRS UMR 5600, Environnement Ville Société) - lise.vaudor@ens-lyon.fr
- "), - tags$a( - href = "https://evs-gis.github.io/mapdowebsite/", - icon("book"), - "Toute la documentation est ici", - target = "_blank" - ) - ) - ) -} - -#' documentation Server Functions -#' -#' @noRd -mod_documentation_server <- function(id){ - moduleServer( id, function(input, output, session){ - ns <- session$ns - - }) -} - -## To be copied in the UI -# mod_documentation_ui("documentation_1") - -## To be copied in the server -# mod_documentation_server("documentation_1") diff --git a/R_old/mod_explore.R b/R_old/mod_explore.R deleted file mode 100644 index d6ef8f2..0000000 --- a/R_old/mod_explore.R +++ /dev/null @@ -1,914 +0,0 @@ -# for dev, create reactivity graph -# library(reactlog) -# reactlog_enable() - -#' explore UI Function -#' -#' @description A shiny Module. -#' -#' @param id shiny id -#' -#' @rdname mod_explore -#' -#' @import shiny -#' @importFrom shinyjs useShinyjs -#' @importFrom shinycssloaders withSpinner -#' @importFrom bslib popover -#' @importFrom bsicons bs_icon -#' -mod_explore_ui <- function(id){ - ns <- NS(id) - tagList( - # Leave this function for adding external resources - golem_add_external_resources(), - fluidPage( - useShinyjs(), - tags$head( - tags$style( - HTML(".form-group{margin-bottom: 10px}") # less space below selectInput metric_type - ) - ), - fluidRow( - column( - width = 6, - withSpinner(leafletOutput(ns("exploremap"), height = 700)) - ), # column - column( - width = 3, - uiOutput(ns("metricUI")), - uiOutput(ns("areaUI")), - uiOutput(ns("radioButtonsUI")) # uiOutput radios buttons metrics - ), # column - - column( - width = 2, - uiOutput(ns("strahlerfilterUI")), - uiOutput(ns("metricsfilterUI")), - uiOutput(ns("legendUI")), - # uncomment line below to add the download button - # uiOutput(ns("downloadUI")) - ) # column - ), # fluidRow - fluidRow( - tabsetPanel( - tabPanel( - "Profil en long", - div( - fluidRow( - column(width = 9, - plotlyOutput(ns("long_profile")) - ), - column( - width = 3, - style = "margin-top: 20px;", - uiOutput(ns("profilemetricUI")), - uiOutput(ns("profileareaUI")), - uiOutput(ns("profileradiobuttonUI")), - uiOutput(ns("removeprofileaxeUI"), - style = "margin-top: 10px;"), # more space above button - uiOutput(ns("profileroeUI"), - style = "margin-top: 10px;") - ) - ) - ) - ), # tabPanel - tabPanel( - title = div("Profil en travers", - span( - style = "display: inline; align-items: center", - popover( - trigger = bs_icon("info-circle"), - "Profil transversal médian correspondant à la - médiane des valeurs des transects réalisées tout les - 10m sur le fond de vallée du tronçon sélectionné", - placement = "right", - id = "popover_cross_section" - ) - )), - div( - fluidRow( - column(width = 12, - plotlyOutput(ns("cross_section")) - ) - ) - ) - ) # tabPanel - )# tabsetPanel - ),# fluidRow - ### UI DEV TOOLS #### - - # fluidRow( - # column( - # width = 4, - # actionButton(ns("browser"), "browser") - # ), - # column( - # width = 8, - # verbatimTextOutput(ns("printcheck")) - # ) - # ) # fluidRow DEV TOOLS - - ### END DEV TOOLS - ) # fluidPage - ) # tagList -} - -#' explore Server Functions -#' -#' @param input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @import shiny -#' @importFrom leaflet leafletProxy clearGroup leafletOutput renderLeaflet -#' @importFrom htmltools HTML div img -#' @importFrom dplyr filter mutate if_else pull -#' @importFrom plotly event_register event_data plotlyProxy plotlyProxyInvoke renderPlotly plotlyOutput -#' @importFrom bslib popover update_popover -#' @importFrom bsicons bs_icon -#' @importFrom sf st_write -#' @importFrom shinyjs onclick runjs -#' -mod_explore_server <- function(id, con){ - moduleServer(id, function(input, output, session){ - - ns <- session$ns - - ### DEV TOOLS #### - output$printcheck = renderPrint({ - tryCatch({ - # event_data("plotly_hover") - print(input$exploremap_center) - print("exists") - }, - shiny.silent.error = function(e) { - print("doesn't exist") - } - ) - }) - observeEvent(input$browser, { - browser() - }) - - ### R_VAL #### - r_val <- reactiveValues( - ### reactivity controler - region_already_clicked = FALSE, - profile_display = FALSE, # controle if metric and axis is selected = display the profile - - ### data - bassins = NULL, # bassins data - regions_in_bassin = NULL, # all the regions in selected bassin - network_region_axis = NULL, # all the axis in the selected region - selected_region_feature = NULL, # region data clicked - region_click = NULL, # region clicked information list - axis_click = NULL, # axis clicked information list - dgo_axis = NULL, # all DGO in selected axis - axis_start_end = NULL, # start / end df coordinates to add pin on map - strahler = NULL, # min and max strahler values to set strahler filter UI - min_max_metric = NULL, # min and max metric values to set metric filter UI - selected_axis_df = NULL, # DGO in axis dataframe to plot longitudinal profile - data_section = NULL, # DGO elevation data for section profile - roe_region = NULL, # ROE data in selected region - roe_axis = NULL, # ROE data in selected axis - hydro_sites_region = NULL, # hydro sites data in selected region - data_dgo_clicked = NULL, # DGO clicked by user for cross section profile - - ### metric selected by user - selected_metric = NULL, # select main metric column name - selected_metric_name = NULL, # select main metric name to display for user - selected_metric_type = NULL, # select main metric type name to display for user - - ### profile metric selected by user - selected_profile_metric = NULL, # select second metric column name - selected_profile_metric_name = NULL, # select second metric name to display for user - selected_profile_metric_type = NULL, # select second metric type name to display for user - - ### render UI generator - plot = lg_profile_empty(), # plotly render longitudinal profile output (default empty) - section = cr_profile_empty(), # plotly render cross section output (default empty) - ui_strahler_filter = NULL, - ui_metric_type = NULL, - ui_metric = NULL, - ui_unit_area = NULL, - ui_metric_filter = NULL, - ui_profile_metric_type = NULL, - ui_profile_metric = NULL, - ui_profile_unit_area = NULL, - ui_remove_profile_axe = NULL, - ui_roe_profile = NULL, - ui_download = NULL, - - ### geoserver controler - cql_filter = NULL, # WMS filter - sld_body = NULL, # WMS SLD symbology - - ### others variables - opacity = list(clickable = 0.01, not_clickable = 0.10), # opacity value to inform the user about available bassins and regions - leaflet_hover_measure = 2.5, # measure field from mesure to add vertical line on longitudinal profile - leaflet_hover_shapes = list(shapes = list(lg_vertical_line(2.5))), # list to store vertical lines to display on longitudinal profile - roe_vertical_line = NULL, # list with verticale line to plot on longitudinal profile - region_name = NULL # region name file formatted to be download - ) - - ### INIT MAP & PROFILE #### - - output$exploremap <- renderLeaflet({ - r_val$bassins = data_get_bassins(opacity = r_val$opacity, con = con) - map_init_bassins(bassins_data = r_val$bassins, - id_logo_ign_remonterletemps = ns("logo_ign_remonterletemps")) - }) - - onclick(id = "logo_ign_remonterletemps", expr = - runjs(sprintf("window.open('%s', '_blank')", - utils_url_remonterletemps(lng = input$exploremap_center$lng, - lat = input$exploremap_center$lat, - zoom = input$exploremap_zoom))) - ) - - output$long_profile <- renderPlotly({ - return(r_val$plot) - }) - - output$cross_section <- renderPlotly({ - return(r_val$section) - }) - - ### RENDER UI #### - - #### profile #### - - # add input UI for profile additional metric - output$profilemetricUI <- renderUI({ - r_val$ui_profile_metric_type - }) - - # add radiobutton for profile additional metric - output$profileradiobuttonUI <- renderUI({ - r_val$ui_profile_metric - }) - - # UI switch unit area for profile additional metric - output$profileareaUI <- renderUI({ - r_val$ui_profile_unit_area - }) - - # button to remove second axe - output$removeprofileaxeUI <- renderUI({ - r_val$ui_remove_profile_axe - }) - - # checkbox display ROE - output$profileroeUI <- renderUI({ - r_val$ui_roe_profile - }) - - #### metric #### - - # UI create choose metric - output$metricUI <- renderUI({ - if (!is.null(r_val$ui_metric_type)){ - div( - style = "display: flex; align-items: center; margin-bottom: 0px", - r_val$ui_metric_type, - span( - style = "display: flex; margin-left: 10px; margin-top: 12px", - popover( - trigger = bsicons::bs_icon("info-circle"), - "", - placement = "right", - id = ns("popover_metric_type") - ) - ) - ) - } else { - HTML('') - } - }) - - # UI metrics radio buttons - output$radioButtonsUI <- renderUI({ - r_val$ui_metric - }) - - # UI switch unit area - output$areaUI <- renderUI({ - r_val$ui_unit_area - }) - - #### download #### - - # Uncomment below to create add the download button - # output$downloadUI <- renderUI({ - # r_val$ui_download - # }) - # - # output$download <- downloadHandler( - # filename = function() { - # paste0(Sys.Date(), "_", r_val$region_name, ".gpkg") - # }, - # content = function(file) { - # data = data_get_dgo_in_region(r_val$region_click$id, con = con) - # st_write(obj = data, dsn = file, layer = r_val$region_name, - # driver = "GPKG", delete_dsn = TRUE) - # } - # ) - - #### filter #### - - # UI strahler filter - output$strahlerfilterUI <- renderUI( - { - r_val$ui_strahler_filter - }) - - # UI dynamic filter on metric selected - output$metricsfilterUI <- renderUI({ - r_val$ui_metric_filter - }) - - #### map legend #### - - metric_legend <- reactiveVal(NULL) - - output$legendUI <- renderUI({ - - div( - HTML(''), - # metric - div( - style = "display: flex; align-items: center;", - metric_legend(), - ), - # landuse map - if (any(input$exploremap_groups %in% params_map_group()$landuse)) { - map_legend_wms_overlayer(wms_params = params_wms()$landuse) - }, - # continuity map - if (any(input$exploremap_groups %in% params_map_group()$continuity)) { - map_legend_wms_overlayer(wms_params = params_wms()$continuity) - }, - # valley bottom map - if (any(input$exploremap_groups %in% params_map_group()$valley_bottom)) { - map_legend_wms_overlayer(wms_params = params_wms()$valley_bottom) - }, - # zone inondable - if (any(input$exploremap_groups %in% params_map_group()$inondation)) { - map_legend_wms_overlayer(wms_params = params_wms()$inondation) - }, - # ouvrage de protection - if (any(input$exploremap_groups %in% params_map_group()[["ouvrage_protection"]])) { - map_legend_wms_overlayer(wms_params = params_wms()$ouvrage_protection) - }, - # ROE - if (any(input$exploremap_groups %in% params_map_group()[["roe"]])) { - map_legend_vector_overlayer(layer_label = "Référentiel des Obstacles à l'Ecoulement", - color = "#323232") - }, - # Site hydrométrique - if (any(input$exploremap_groups %in% params_map_group()[["hydro_sites"]])) { - map_legend_vector_overlayer(layer_label = "Site hydrométrique", - color = "#33B1FF") - }, - style = "margin-bottom: 10px;" - ) # div - }) - - ### EVENT MAP CLICK #### - - observeEvent(input$exploremap_shape_click,{ - - # track input - track_inputs(input = input) - - #### bassin clicked #### - if (input$exploremap_shape_click$group == params_map_group()[["bassin"]]){ - # disable the click interactivity for the bassin selected - r_val$bassins = r_val$bassins %>% - mutate(click = if_else(display == TRUE, - TRUE, - click)) %>% - mutate(click = if_else(display == TRUE & cdbh == input$exploremap_shape_click$id, - FALSE, - click)) - # get the regions data in selected bassin - r_val$regions_in_bassin = data_get_regions_in_bassin(selected_bassin_id = input$exploremap_shape_click$id, - opacity = r_val$opacity, - con = con) - # update map : zoom in clicked bassin, clear bassin data, display region in bassin - leafletProxy("exploremap") %>% - map_add_regions_in_bassin(bassin_click = input$exploremap_shape_click, - regions_data = r_val$regions_in_bassin, - bassins_data = r_val$bassins) - } - - ### region clicked #### - if (input$exploremap_shape_click$group == params_map_group()$region){ - # store the region click values - r_val$region_click = input$exploremap_shape_click - # disable the click interactivity for the bassin selected - r_val$regions_in_bassin = r_val$regions_in_bassin %>% - mutate(click = if_else(display == TRUE, - TRUE, - click)) %>% - mutate(click = if_else(display == TRUE & gid == r_val$region_click$id, - FALSE, - click)) - - # save the selected region feature for mapping - r_val$selected_region_feature = data_get_region(region_click_id = r_val$region_click$id, - con = con) - # set region name to download - r_val$region_name = utils_normalize_string(r_val$selected_region_feature$lbregionhy) - # get the axis in the region - r_val$network_region_axis = data_get_axis(selected_region_id = r_val$region_click$id, - con = con) - # get ROE in region - r_val$roe_region = data_get_roe_in_region(r_val$region_click$id, - con = con) - # get hydro sites in region - r_val$hydro_sites_region = data_get_hydro_sites(r_val$region_click$id, - con = con) - # get strahler data - r_val$strahler = isolate(data_get_min_max_strahler(selected_region_id = r_val$region_click$id, - con = con)) - # build strahler slider - r_val$ui_strahler_filter = sliderInput(ns("strahler"), - label="Ordre de strahler", - min=r_val$strahler[["min"]], - max=r_val$strahler[["max"]], - value=c(r_val$strahler[["min"]], - r_val$strahler[["max"]]), - step=1) - - # map region clicked with region clicked and overlayers - leafletProxy("exploremap") %>% - map_region_clicked(region_click = input$exploremap_shape_click, - selected_region_feature = r_val$selected_region_feature, - regions_data = r_val$regions_in_bassin, - roe_region = r_val$roe_region, - hydro_sites_region = r_val$hydro_sites_region) - - # run only once, control with region_already_clicked - if (r_val$region_already_clicked == FALSE){ - # build metric selectInput - r_val$ui_metric_type = - selectInput(ns("metric_type"), "Sélectionnez une métrique :", - choices = utils_get_metric_type(params_metrics_choice()), - selected = utils_get_metric_type(params_metrics_choice())[1]) - - # create download button - r_val$ui_download = downloadButton( - ns("download"), - label = "Télécharger les données" - ) - r_val$region_already_clicked = TRUE - } - } - ### axis clicked #### - - if (input$exploremap_shape_click$group == params_map_group()$axis) { - # save the clicked axis values - r_val$axis_click = input$exploremap_shape_click - # reget the axis in the region without the selected axis - r_val$network_region_axis = data_get_axis(selected_region_id = r_val$region_click$id, - con = con) %>% - filter(axis != r_val$axis_click$id) - # get the DGO axis data - r_val$dgo_axis = data_get_network_axis(selected_axis_id = r_val$axis_click$id, - con = con) %>% - mutate(measure = measure/1000) - # extract axis start end point - r_val$axis_start_end = data_get_axis_start_end(dgo_axis = r_val$dgo_axis) - # get ROE in axis clicked - r_val$roe_axis = r_val$roe_region %>% - filter(axis == r_val$axis_click$id) - - # map dgo axis when axis clicked and metric selected - leafletProxy("exploremap") %>% - map_dgo_axis(selected_axis = r_val$dgo_axis, region_axis = r_val$network_region_axis, - main_metric = r_val$selected_metric, second_metric = r_val$selected_profile_metric) %>% - map_axis_start_end(axis_start_end = r_val$axis_start_end, region_axis = r_val$network_region_axis) - - # create or update profile dataset with new axis - r_val$selected_axis_df = r_val$dgo_axis %>% - as.data.frame() - - # update profile with new metric selected - if (r_val$profile_display == TRUE){ - proxy_main_axe <- - lg_profile_update_main( - data = r_val$selected_axis_df, - y = r_val$selected_axis_df[[r_val$selected_metric]], - y_label = r_val$selected_metric_name, - y_label_category = r_val$selected_metric_type - ) - - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("deleteTraces", 0) %>% - plotlyProxyInvoke("addTraces", proxy_main_axe$trace, 0) %>% - plotlyProxyInvoke("relayout", proxy_main_axe$layout) - - # update ROE vertical lines - if (input$roe_profile == TRUE){ - if (!is.null(r_val$roe_vertical_line)){ - # remove the previous ROE vertical lines if exist - r_val$leaflet_hover_shapes$shapes <- list(r_val$leaflet_hover_shapes$shapes[[1]]) - } - # create the vertical line from ROE distance_axis - r_val$roe_vertical_line <- lg_roe_vertical_line(r_val$roe_axis$distance_axis) - # increment the vertical list shape to keep the hover map vertical line - r_val$leaflet_hover_shapes$shapes <- c(r_val$leaflet_hover_shapes$shapes, - r_val$roe_vertical_line) - # update profile - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("relayout", r_val$leaflet_hover_shapes) - }else{ - # remove the previous ROE vertical lines if exist - r_val$leaflet_hover_shapes$shapes <- list(r_val$leaflet_hover_shapes$shapes[[1]]) - # update profile - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("relayout", r_val$leaflet_hover_shapes) - } - - - if(!is.null(input$profile_metric)){ # second metric selected = update second metric profile - # create the list to add trace and layout to change second axe plot - proxy_second_axe <- lg_profile_second(data = r_val$selected_axis_df, - y = r_val$selected_axis_df[[r_val$selected_profile_metric]], - y_label = r_val$selected_profile_metric_name, - y_label_category = r_val$selected_profile_metric_type) - - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("deleteTraces", 1) %>% - plotlyProxyInvoke("addTraces", proxy_second_axe$trace, 1) %>% - plotlyProxyInvoke("relayout", proxy_second_axe$layout) - } - } - } - - ### dgo clicked #### - - if (input$exploremap_shape_click$group == params_map_group()$dgo_axis) { - # get data with dgo id - r_val$data_section = data_get_elevation_profiles(selected_dgo_fid = input$exploremap_shape_click$id, - con = con) - # plot cross section - r_val$section = cr_profile_main(data = r_val$data_section, - axis_toponyme = unique(r_val$selected_axis_df$toponyme)) - # get dgo clicked feature - r_val$data_dgo_clicked = r_val$dgo_axis %>% - filter(fid == input$exploremap_shape_click$id) - # Highlight clicked DGO - leafletProxy("exploremap") %>% - map_dgo_cross_section(selected_dgo = r_val$data_dgo_clicked) - } - }) - - ### EVENT METRIC #### - - #### metric type select #### - - observeEvent(input$metric_type, { - - # track input - track_inputs(input = input) - - if (!is.null(input$metric_type)){ - update_popover("popover_metric_type", - HTML(params_metrics_choice()[[input$metric_type]]$metric_type_info)) - } - - - # build metric radioButtons with popover icon - r_val$ui_metric = radioButtons( - inputId = ns("metric"), - label = NULL, - choiceNames = utils_button_label_with_popover(input$metric_type), - choiceValues = as.list(names(utils_get_metric_name_value(input$metric_type))), - selected = character(0) - ) - - # build selectInput unit area for landuse or continuity - if (input$metric_type == "landuse" || input$metric_type == "continuity"){ - r_val$ui_unit_area = selectInput(ns("unit_area"), "Surfaces :", - choices = params_unit_area(), - selected = unname(params_unit_area()[1])) - }else{ - r_val$ui_unit_area = NULL - } - }) - - #### metric select #### - - observeEvent(c(input$metric, input$unit_area), ignoreInit = TRUE, { - - # track input - track_inputs(input = input) - - # change field if unit_area in percentage - if (!is.null(input$metric) && input$unit_area == "percent" - && (input$metric_type %in% c("landuse", "continuity"))){ - r_val$selected_metric = paste0(input$metric,"_pc") - } else if (!is.null(input$metric)) { - r_val$selected_metric = input$metric - } - - if (!is.null(input$metric)){ - r_val$selected_metric_name = params_metrics_choice()[[input$metric_type]]$metric_type_values[[input$metric]]$metric_title - r_val$selected_metric_type = params_metrics_choice()[[input$metric_type]]$metric_type_title - - # build metric filter slider - r_val$min_max_metric <- data_get_min_max_metric(selected_region_id = r_val$region_click$id, - selected_metric = r_val$selected_metric, - con = con) - - r_val$ui_metric_filter = sliderInput(ns("metricfilter"), - label = r_val$selected_metric_name, - min = isolate(r_val$min_max_metric[["min"]]), - max = isolate(r_val$min_max_metric[["max"]]), - value = c( - isolate(r_val$min_max_metric[["min"]]), - isolate(r_val$min_max_metric[["max"]]) - ) - ) - - # update profile with new metric selected - if (r_val$profile_display == TRUE){ - - proxy_main_axe <- - lg_profile_update_main( - data = r_val$selected_axis_df, - y = r_val$selected_axis_df[[r_val$selected_metric]], - y_label = r_val$selected_metric_name, - y_label_category = r_val$selected_metric_type - ) - - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("deleteTraces", 0) %>% - plotlyProxyInvoke("addTraces", proxy_main_axe$trace, 0) %>% - plotlyProxyInvoke("relayout", proxy_main_axe$layout) - } - } - }) - - ### EVENT METRIC & AXIS RESULTS #### - - observeEvent(c(r_val$selected_metric, r_val$axis_click), { - - if (r_val$profile_display == FALSE){ - - # track input - track_inputs(input = input) - - if (!is.null(r_val$selected_metric) && !is.null(r_val$axis_click)){ - - r_val$profile_display = TRUE # this event run only one time controlled with profile_display - - # build input for profile metric type - r_val$ui_profile_metric_type = selectInput(ns("profile_metric_type"), "Ajoutez une métrique :", - choices = utils_get_metric_type(params_metrics_choice()), - selected = utils_get_metric_type(params_metrics_choice())[1]) - - # built ROE checkboxInput and input - r_val$ui_roe_profile = checkboxInput(ns("roe_profile"), label = "ROE", value = FALSE) - - # update dgo on axis to reset tooltip - leafletProxy("exploremap") %>% - map_dgo_axis(selected_axis = r_val$dgo_axis, region_axis = r_val$network_region_axis, - main_metric = r_val$selected_metric, second_metric = r_val$selected_profile_metric) - - # plot single axe with metric selected - r_val$plot = lg_profile_main(data = r_val$selected_axis_df, - y = r_val$selected_axis_df[[r_val$selected_metric]], - y_label = r_val$selected_metric_name, - y_label_category = r_val$selected_metric_type) %>% - event_register("plotly_hover") - } - } - }) - - ### EVENT PROFILE METRIC #### - - #### profile metric type select #### - - observeEvent(input$profile_metric_type, { - - # track input - track_inputs(input = input) - - # build profile metric radio button - r_val$ui_profile_metric = radioButtons( - inputId = ns("profile_metric"), - label = NULL, - choiceNames = unname(utils_get_metric_name_value(input$profile_metric_type)), - choiceValues = names(utils_get_metric_name_value(input$profile_metric_type)), - selected = character(0) - ) - - # build profile unit area select - if (input$profile_metric_type == "landuse" || - input$profile_metric_type == "continuity") { - r_val$ui_profile_unit_area = selectInput( - ns("profile_unit_area"), - "Surfaces :", - choices = params_unit_area(), - selected = unname(params_unit_area()[1]) - ) - } else{ - r_val$ui_profile_unit_area = NULL - } - - r_val$ui_remove_profile_axe = actionButton( - ns("remove_profile_axe"), - label = "Retirer le second axe" - ) - }) - - #### profile metric select #### - - observeEvent(c(input$profile_metric, input$profile_unit_area), ignoreInit = TRUE, { - - # track input - track_inputs(input = input) - - # change field if unit_area in percentage - if (!is.null(input$profile_metric) && input$profile_unit_area == "percent" - && (input$profile_metric_type %in% c("landuse", "continuity"))){ - r_val$selected_profile_metric = paste0(input$profile_metric,"_pc") - } else if (!is.null(input$profile_metric)) { - r_val$selected_profile_metric = input$profile_metric - } - - if (!is.null(input$profile_metric)){ - r_val$selected_profile_metric_name = params_metrics_choice()[[input$profile_metric_type]]$metric_type_values[[input$profile_metric]]$metric_title - r_val$selected_profile_metric_type = params_metrics_choice()[[input$profile_metric_type]]$metric_type_title - - # update map to change tooltip labels - leafletProxy("exploremap") %>% - map_dgo_axis(selected_axis = r_val$dgo_axis, region_axis = r_val$network_region_axis, - main_metric = r_val$selected_metric, second_metric = r_val$selected_profile_metric) - - # create the list to add trace and layout to change second axe plot - proxy_second_axe <- lg_profile_second(data = r_val$selected_axis_df, - y = r_val$selected_axis_df[[r_val$selected_profile_metric]], - y_label = r_val$selected_profile_metric_name, - y_label_category = r_val$selected_profile_metric_type) - - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("deleteTraces", 1) %>% - plotlyProxyInvoke("addTraces", proxy_second_axe$trace, 1) %>% - plotlyProxyInvoke("relayout", proxy_second_axe$layout) - } - }) - - #### profile metric remove axe #### - - observeEvent(input$remove_profile_axe, { - - # track input - track_inputs(input = input) - - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("deleteTraces", 1) - - updateRadioButtons(session, "profile_metric", selected = character(0)) - - r_val$selected_profile_metric = NULL - # update dgo on axis to reset tooltip - leafletProxy("exploremap") %>% - map_dgo_axis(selected_axis = r_val$dgo_axis, region_axis = r_val$network_region_axis, - main_metric = r_val$selected_metric, second_metric = r_val$selected_profile_metric) - - }) - - #### profile metric add ROE #### - - observeEvent(input$roe_profile, { - - # track input - track_inputs(input = input) - - if (input$roe_profile == TRUE){ - if (!is.null(r_val$roe_vertical_line)){ - # remove the previous ROE vertical lines if exist - r_val$leaflet_hover_shapes$shapes <- list(r_val$leaflet_hover_shapes$shapes[[1]]) - } - # create the vertical line from ROE distance_axis - r_val$roe_vertical_line <- lg_roe_vertical_line(r_val$roe_axis$distance_axis) - # increment the vertical list shape to keep the hover map vertical line - r_val$leaflet_hover_shapes$shapes <- c(r_val$leaflet_hover_shapes$shapes, - r_val$roe_vertical_line) - # update profile - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("relayout", r_val$leaflet_hover_shapes) - }else{ - # remove the previous ROE vertical lines if exist - r_val$leaflet_hover_shapes$shapes <- list(r_val$leaflet_hover_shapes$shapes[[1]]) - # update profile - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("relayout", r_val$leaflet_hover_shapes) - } - }) - - ### EVENT FILTER #### - - observeEvent(c(input$strahler, input$metricfilter, r_val$ui_strahler_filter), { - - # track input - track_inputs(input = input) - - if (is.null(input$metricfilter)){ - # build WMS cql_filter - r_val$cql_filter = paste0("gid_region=", r_val$selected_region_feature[["gid"]], - " AND strahler>=", input$strahler[1], - " AND strahler <= ", input$strahler[2]) - - r_val$sld_body = NULL - - } else { - # build WMS cql_filter - r_val$cql_filter = paste0("gid_region=",r_val$selected_region_feature[["gid"]], - " AND strahler>=",input$strahler[1], - " AND strahler <= ",input$strahler[2], - " AND ",r_val$selected_metric,">=",input$metricfilter[1], - " AND ",r_val$selected_metric,"<=",input$metricfilter[2]) - - # build SLD symbology - r_val$sld_body = sld_get_style( - breaks = sld_get_quantile_metric( - selected_region_id = r_val$region_click$id, - selected_metric = r_val$selected_metric, - con = con - ), - colors = sld_get_quantile_colors( - quantile_breaks = sld_get_quantile_metric( - selected_region_id = r_val$region_click$id, - selected_metric = r_val$selected_metric, - con = con - ) - ), - metric = r_val$selected_metric - ) - - # update legend - metric_legend(map_legend_metric(sld_body = r_val$sld_body)) - } - # update map with basic style - leafletProxy("exploremap") %>% - map_metric(wms_params = params_wms()$metric, - cql_filter = r_val$cql_filter, sld_body = r_val$sld_body, - data_axis = r_val$network_region_axis) - }) - - ### EVENT MOUSEOVER #### - - #### plotly profile #### - - # Define an observeEvent to capture hover events - observeEvent(event_data("plotly_hover"), { - if (!is.null(event_data("plotly_hover"))) { - hover_fid <- event_data("plotly_hover")$key[1] - highlighted_feature <- r_val$dgo_axis[r_val$dgo_axis$fid == hover_fid, ] - leafletProxy("exploremap") %>% - addPolylines(data = highlighted_feature, color = "red", weight = 10, - group = params_map_group()$light) - } - }) - - # clear previous point on map when moving along profile to not display all the point move over - observe({ - if (is.null(event_data("plotly_hover"))) { - leafletProxy("exploremap") %>% - clearGroup(params_map_group()$light) - } - }) - - #### leaflet map #### - - # add vertical line on profil on map user mouseover axis - observeEvent(input$exploremap_shape_mouseover, { - if (input$exploremap_shape_mouseover$group == params_map_group()$dgo_axis && !is.null(input$exploremap_shape_mouseover)){ - # extract dgo axis fid from map - r_val$leaflet_hover_measure <- r_val$dgo_axis %>% - filter(fid == input$exploremap_shape_mouseover$id) %>% - pull(measure) - # remove the first element (hover dgo vertical line) - r_val$leaflet_hover_shapes <- list(shapes = r_val$leaflet_hover_shapes$shapes[-1]) - # add the new hover dgo vertical line - r_val$leaflet_hover_shapes$shapes <- c(list(lg_vertical_line(r_val$leaflet_hover_measure)), r_val$leaflet_hover_shapes$shapes) - # change profile layout with vertical line - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("relayout", r_val$leaflet_hover_shapes) - } - }) - }) -} - - -## To be copied in the UI -# mod_explore_ui("explore_1") - -## To be copied in the server -# mod_explore_server("explore_1") diff --git a/R_old/mod_mapdo_app.R b/R_old/mod_mapdo_app.R deleted file mode 100644 index cbbe267..0000000 --- a/R_old/mod_mapdo_app.R +++ /dev/null @@ -1,507 +0,0 @@ - -# UI ---------------------------------------------------------------------- - - - -#' mapdo_app UI Function -#' -#' @description A shiny Module. -#' -#' @import shiny -#' @importFrom shinyjs useShinyjs -#' @importFrom shinycssloaders withSpinner -#' @importFrom bslib popover -#' @importFrom bsicons bs_icon -#' @importFrom leaflet leafletOutput -#' @importFrom htmltools HTML div img -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_mapdo_app_ui <- function(id){ - ns <- NS(id) - tagList( - golem_add_external_resources(), - fluidPage( - useShinyjs(), - tags$head( - tags$style( - HTML(" - .form-group{margin-bottom: 10px} - ") - ) - ), # head - fluidRow( - column( - width = 7, - withSpinner(leafletOutput(ns("map"), height = 500)), - textOutput(ns("selection_textUI")) - ), - column( - width = 5, - tabsetPanel( - id = ns("tabset"), - tabPanel("Classes proposées", - mod_classification_proposed_ui("classification_proposed_1") - ), - tabPanel("Classification manuelle", - mod_classification_manual_ui("classification_manual_1") - ), - tabPanel("Aperçu métriques", - mod_metric_overview_ui("metric_overview_1") - ), type = "pills" - ) #tabsetpanel - ) #column - ), #row - fluidRow( - style = "margin-top: 10px; - margin-bottom: 10px;", - tabsetPanel( - id = ns("tabset2"), - tabPanel( - "Évolution longitudinale", - mod_profil_long_ui("profil_long_1") - ), - tabPanel("Profil transversal", - mod_profil_transverse_ui("profil_transverse_1") - ), - tabPanel("Distribution des classes", - mod_classes_distribution_ui("classes_distribution_1") - ), type = "pills" - ) - ) - ) #page - - ) -} - - - -# SERVER ------------------------------------------------------------------ - - -#' mapdo_app Server Functions -#' -#' @import shiny -#' @importFrom leaflet leafletProxy clearGroup leafletOutput renderLeaflet removeControl addLegend addControl -#' @importFrom leaflet.extras addWMSLegend -#' @importFrom htmltools HTML div img -#' @importFrom dplyr filter mutate if_else pull -#' @importFrom plotly event_register event_data plotlyProxy plotlyProxyInvoke renderPlotly plotlyOutput -#' @importFrom bslib popover update_popover -#' @importFrom bsicons bs_icon -#' @importFrom sf st_write -#' @importFrom shinyjs onclick runjs -#' @noRd -mod_mapdo_app_server <- function(id, con, r_val){ - moduleServer( id, function(input, output, session){ - ns <- session$ns - - - ### INITIALIZATION #### - - #### Map #### - - output$map <- renderLeaflet({ - r_val$bassins = data_get_bassins(opacity = r_val$opacity, con = con) - map_init_bassins(bassins_data = r_val$bassins, - id_logo_ign_remonterletemps = ns("logo_ign_remonterletemps")) - }) - - onclick(id = "logo_ign_remonterletemps", expr = - runjs(sprintf("window.open('%s', '_blank')", - utils_url_remonterletemps(lng = input$map_center$lng, - lat = input$map_center$lat, - zoom = input$map_zoom))) - ) - - #### Description Text #### - - output$selection_textUI <- renderText({ - r_val$selection_text - }) - - observe({ - r_val$map_proxy <- leafletProxy("map") - }) - - ### TABSET LISTENERS #### - - # save current tabs in reactive values - - observeEvent(input$tabset, { - r_val$tab_open1 = input$tabset - }) - - observeEvent(input$tabset2, { - r_val$tab_open2 = input$tabset2 - }) - - ### EVENT MAP CLICK #### - - observeEvent(input$map_shape_click, { - - # track input - track_inputs(input = input) - - #### bassin clicked #### - if (input$map_shape_click$group == params_map_group()[["bassin"]]){ - - # get bassin name - r_val$bassin_name = r_val$bassins %>% - filter(cdbh == input$map_shape_click$id) %>% - pull(lbbh) - - # disable the click interactivity for the bassin selected - r_val$bassins = r_val$bassins %>% - mutate(click = if_else(display == TRUE, TRUE, click)) %>% - mutate(click = if_else(display == TRUE & cdbh == input$map_shape_click$id, FALSE, click)) - # get the regions data in selected bassin - r_val$regions_in_bassin = data_get_regions_in_bassin(selected_bassin_id = input$map_shape_click$id, - opacity = r_val$opacity, - con = con) - # update map : zoom in clicked bassin, clear bassin data, display region in bassin - leafletProxy("map") %>% - map_add_regions_in_bassin(bassin_click = input$map_shape_click, - regions_data = r_val$regions_in_bassin, - bassins_data = r_val$bassins) - # print name of basin below map - r_val$selection_text = paste0("Bassin: ", r_val$bassin_name) - } - - #### region clicked #### - if (input$map_shape_click$group == params_map_group()$region){ - - # register first selection of region - r_val$region_clicked = TRUE - - # set axis and dgo values back to NULL - r_val$network_region_classified = NULL - r_val$axis_name = NULL - r_val$axis_click = NULL - r_val$axis_clicked = FALSE - r_val$dgo_axis = NULL - r_val$axis_start_end = NULL - r_val$data_dgo_clicked = NULL - r_val$data_section = NULL - r_val$network_region_classified = NULL - r_val$dgo_axis_classified = NULL - r_val$merged_networks_classified = NULL - r_val$roe_region = NULL - - # store the region click values - r_val$region_click = input$map_shape_click - - # disable the click interactivity for the bassin selected - r_val$regions_in_bassin = r_val$regions_in_bassin %>% - mutate(click = if_else(display == TRUE, TRUE, click)) %>% - mutate(click = if_else(display == TRUE & gid == r_val$region_click$id, FALSE, click)) - - # save the selected region feature for mapping - r_val$selected_region_feature = data_get_region(region_click_id = r_val$region_click$id, - con = con) - - # get network of region - r_val$network_region = data_get_network_region(selected_region_id = r_val$region_click$id, - con = con) - - # set region name to download - r_val$region_name = utils_normalize_string(r_val$selected_region_feature$lbregionhy) - - # get the axis in the region - r_val$network_region_axis = data_get_axis(selected_region_id = r_val$region_click$id, - con = con) - # get ROE in region - r_val$roe_region = data_get_roe_in_region(r_val$region_click$id, - con = con) - - # get hydro sites in region - r_val$hydro_sites_region = data_get_hydro_sites(r_val$region_click$id, - con = con) - - # build SLD symbology - r_val$sld_body = sld_get_style( - breaks = sld_get_quantile_metric( - selected_region_id = r_val$region_click$id, - selected_metric = r_val$selected_metric, - con = con - ), - colors = sld_get_quantile_colors( - quantile_breaks = sld_get_quantile_metric( - selected_region_id = r_val$region_click$id, - selected_metric = r_val$selected_metric, - con = con - ) - ), - metric = r_val$selected_metric - ) - - # map region clicked with region clicked and overlayers and initial network with strahler-order - r_val$map_proxy %>% - map_region_clicked(region_click = input$map_shape_click, - selected_region_feature = r_val$selected_region_feature, - regions_data = r_val$regions_in_bassin, - roe_region = r_val$roe_region, - hydro_sites_region = r_val$hydro_sites_region) - - # add strahler-order network visualization to map when classes visualisation is selected (and not manual) - # if ((r_val$visualization == "classes") && is.null(r_val$classes_proposed_selected)) { - # r_val$map_proxy %>% - # map_class(wms_params = params_wms()$class, - # cql_filter = paste0("gid_region!=",r_val$selected_region_feature[["gid"]]), - # style = "mapdo:", - # data_axis = r_val$network_region_axis) - # } - # map_metric(wms_params = params_wms()$metric, - # cql_filter = paste0("gid_region=",r_val$selected_region_feature[["gid"]]), - # sld_body = r_val$sld_body, - # data_axis = r_val$network_region_axis) %>% - # addWMSLegend(uri = map_legend_metric(sld_body = r_val$sld_body), - # position = "bottomright", - # layerId = "legend_metric") - # addControl( - # html = HTML(paste0('
- #
- # ')),
- # position = "bottomright"
- # )
-
- # addControl(
- # html = paste0('Legend Title
- #
- # , ')
- #
- #
- #
- #
'),
- # position = "bottomright"
- # )
- # addControl(
- # html = "Custom Legend Title",
- # position = "bottomright",
- # className = "legend-title"
- # )
-
-
-
-
- # print name of basin and region below map
- r_val$selection_text = paste0("Bassin: ", r_val$bassin_name,
- ", région: ", r_val$selected_region_feature$lbregionhy)
- }
-
- #### axis clicked ####
-
- if (input$map_shape_click$group == params_map_group()$axis) {
-
- # set values back to NULL
- r_val$data_dgo_clicked = NULL
- r_val$data_section = NULL
- r_val$dgo_axis_classified = NULL
- r_val$merged_networks_classified = NULL
- r_val$leaflet_hover_measure = NULL
- r_val$roe_axis = NULL
- r_val$dgo_axis = NULL
-
- # save the clicked axis values
- r_val$axis_click = input$map_shape_click
-
- # reget the axis in the region without the selected axis
- r_val$network_region_axis = data_get_axis(selected_region_id = r_val$region_click$id,
- con = con) %>%
- filter(axis != r_val$axis_click$id)
-
- # get the DGO axis data
- r_val$dgo_axis = data_get_network_axis(selected_axis_id = r_val$axis_click$id,
- con = con) %>%
- mutate(measure = measure/1000)
-
- # get axis name
- r_val$axis_name = r_val$dgo_axis$toponyme[1]
-
- # extract axis start end point
- r_val$axis_start_end = data_get_axis_start_end(dgo_axis = r_val$dgo_axis)
-
- # get ROE in axis clicked
- r_val$roe_axis = r_val$roe_region %>%
- filter(axis == r_val$axis_click$id)
-
- # map dgo axis when axis clicked and metric selected
- r_val$map_proxy %>%
- map_dgo_axis(selected_axis = r_val$dgo_axis, region_axis = r_val$network_region_axis,
- main_metric = r_val$selected_metric, second_metric = r_val$selected_profile_metric) %>%
- map_axis_start_end(axis_start_end = r_val$axis_start_end, region_axis = r_val$network_region_axis)
-
- # print name of basin and region below map
- r_val$selection_text = paste0("Bassin: ", r_val$bassin_name,
- ", région: ", r_val$selected_region_feature$lbregionhy,
- ", axe: ", r_val$axis_name)
-
- # create or update profile dataset with new axis
- r_val$selected_axis_df = r_val$dgo_axis %>%
- as.data.frame()
-
- # inform the first axis has been clicked
- r_val$axis_clicked = TRUE
- }
-
- #### dgo clicked ####
-
- if (input$map_shape_click$group == params_map_group()$dgo_axis) {
- # get data with dgo id
- r_val$data_section = data_get_elevation_profiles(selected_dgo_fid = input$map_shape_click$id,
- con = con)
-
- # get dgo clicked feature
- r_val$data_dgo_clicked = r_val$dgo_axis %>%
- filter(fid == input$map_shape_click$id)
-
- # Highlight clicked DGO
- r_val$map_proxy %>%
- map_dgo_cross_section(selected_dgo = r_val$data_dgo_clicked)
- }
- })
-
- #### DGO Mouseover ####
-
- # check for hover over dgo event
- observeEvent(input$map_shape_mouseover, {
- if (input$map_shape_mouseover$group == params_map_group()$dgo_axis && !is.null(input$map_shape_mouseover)){
-
- # extract dgo axis fid from map
- r_val$leaflet_hover_measure = r_val$dgo_axis %>%
- filter(fid == input$map_shape_mouseover$id) %>%
- pull(measure)
- } else {
- r_val$leaflet_hover_measure = NULL
- }
- })
-
- #### EVENT legend update ####
-
- observeEvent(input$map_groups, {
-
- # landuse map
- if (any(input$map_groups %in% params_map_group()$landuse)) {
- leafletProxy("map") %>%
- addWMSLegend(map_legend_wms_overlayer(wms_params = params_wms()$landuse),
- position = "bottomleft",
- layerId = "landuse")
- } else {
- leafletProxy("map") %>%
- removeControl(layerId = "landuse")
- }
-
- # lateral continuity map
- if (any(input$map_groups %in% params_map_group()$continuity)) {
- leafletProxy("map") %>%
- addWMSLegend(map_legend_wms_overlayer(wms_params = params_wms()$continuity),
- position = "bottomleft",
- layerId = "continuity")
- } else {
- leafletProxy("map") %>%
- removeControl(layerId = "continuity")
- }
-
- # valley bottom map
- if (any(input$map_groups %in% params_map_group()$valley_bottom)) {
- leafletProxy("map") %>%
- addWMSLegend(map_legend_wms_overlayer(wms_params = params_wms()$valley_bottom),
- position = "bottomleft",
- layerId = "valley_bottom")
- } else {
- leafletProxy("map") %>%
- removeControl(layerId = "valley_bottom")
- }
-
- # zone inondable map
- if (any(input$map_groups %in% params_map_group()$inondation)) {
- leafletProxy("map") %>%
- addWMSLegend(map_legend_wms_overlayer(wms_params = params_wms()$inondation),
- position = "bottomleft",
- layerId = "inondation")
- } else {
- leafletProxy("map") %>%
- removeControl(layerId = "inondation")
- }
-
- # ouvrage de protection map
- if (any(input$map_groups %in% params_map_group()[["ouvrage_protection"]])) {
- leafletProxy("map") %>%
- addWMSLegend(map_legend_wms_overlayer(wms_params = params_wms()$ouvrage_protection),
- position = "bottomleft",
- layerId = "ouvrage_protection")
- } else {
- leafletProxy("map") %>%
- removeControl(layerId = "ouvrage_protection")
- }
-
- # Custom legend HTML
- custom_legend <-
-
- # ROE
- if (any(input$map_groups %in% params_map_group()[["roe"]])) {
- leafletProxy("map") %>%
- addControl(
- HTML("
- Legend Title
- #
-
-
"),
- position = "bottomleft", layerId = "roe"
- )
- # addLegend(
- # position = "bottomright",
- # colors = "#323232",
- # labels = "Obstacles à l'Ecoulement (ROE)",
- # layerId = "roe"
- # )
- } else {
- leafletProxy("map") %>%
- removeControl(layerId = "roe")
- }
-
- # Site hydrométrique
- if (any(input$map_groups %in% params_map_group()[["hydro_sites"]])) {
- leafletProxy("map") %>%
- addControl(
- HTML("
- Obstacles à l'Ecoulement (ROE)
-
-
-
"),
- position = "bottomleft", layerId = "hydro_sites"
- )
- # addLegend(
- # position = "bottomright",
- # colors = "#33B1FF",
- # labels = "Obstacles à l'Ecoulement (ROE)",
- # layerId = "hydro_sites"
- # )
- } else {
- leafletProxy("map") %>%
- removeControl(layerId = "hydro_sites")
- }
-
- # Site hydrométrique
- # if (any(input$map_groups %in% params_map_group()[["hydro_sites"]])) {
- # map_legend_vector_overlayer(layer_label = "Site hydrométrique",
- # color = "#33B1FF")
- # }
- })
-
-
- })
-}
diff --git a/R_old/mod_metric_overview.R b/R_old/mod_metric_overview.R
deleted file mode 100644
index a7bd06d..0000000
--- a/R_old/mod_metric_overview.R
+++ /dev/null
@@ -1,158 +0,0 @@
-#' metric_overview UI Function
-#'
-#' @description A shiny Module.
-#'
-#' @import shiny
-#' @importFrom shinyjs useShinyjs
-#' @importFrom reactable reactableOutput
-#'
-#' @param id,input,output,session Internal parameters for {shiny}.
-#'
-#' @noRd
-#'
-#' @importFrom shiny NS tagList
-mod_metric_overview_ui <- function(id){
- ns <- NS(id)
- tagList(
- useShinyjs(),
- tags$style(HTML("
- .reactable-table {
- font-size: 15px; /* Adjust this value to change the text size */
- }
- ")),
- fluidRow(style = "margin-top: 10px;",
- textOutput(ns("placeholder_ui")),
- column(width = 6,
- uiOutput(ns("description"))),
- column(width = 6,
- uiOutput(ns("selectinput")))
- ),
- fluidRow(
- div(class = "reactable-table",
- reactableOutput(ns("table"), width = "100%")
- )
- )
- )
-}
-
-#' metric_overview Server Functions
-#'
-#' @import shiny
-#' @import dplyr
-#' @importFrom reactable renderReactable
-#' @importFrom sf st_drop_geometry
-#' @importFrom tidyr pivot_longer
-#'
-#' @noRd
-mod_metric_overview_server <- function(id, r_val){
- moduleServer( id, function(input, output, session){
- ns <- session$ns
-
- r_val_local <- reactiveValues(
- characteristics_table = NULL, # reactable table
- descriptionUI = NULL, # Description/Title text
- placeholder_text = "Cliquez sur un région hydrographique pour afficher la comparaison régionale des métriques. ",
- selectinputUI = NULL, # select input for unit
- unit = NULL, # unit for metrics
-
- region_pivot = NULL, # pivoted df of region as input for data_df
- axis_pivot = NULL, # pivoted df of region as input for data_df
- dgo_pivot = NULL, # pivoted df of dgo as input for data_df
- data_df = NULL # df to create table
- )
-
- output$table <- renderReactable(
- r_val_local$characteristics_table
- )
-
- output$description <- renderUI(
- r_val_local$descriptionUI
- )
-
- # text placeholder
- output$placeholder_ui <- renderText({
- r_val_local$placeholder_text
- })
-
- output$selectinput <- renderUI(
- r_val_local$selectinputUI
- )
-
- # observe if region clicked to create UI
- observe({
- if (r_val$region_clicked == TRUE) {
- # remove placeholder text
- r_val_local$placeholder_text = NULL
-
- # create header
- r_val_local$descriptionUI = HTML("Sites hydrométriques
- Comparaison de moyennes
") - - # create metric-select input - r_val_local$selectinputUI = selectInput(ns("select_unit"), label = NULL, - choices = list("surface relative (%)", "surface absolute (ha)")) - } - }) - - # create pivoted df for axis each time it changes - observeEvent(c(r_val$network_region, r_val$tab_open1), { - if (!is.null(r_val$network_region) && (r_val$tab_open1 == "Aperçu métriques")) { - - r_val_local$region_pivot <- fct_table_pivot_sf(r_val$network_region) %>% - dplyr::rename(mean_region = mean, distr_region = distr) - - # set axis and dgo to NULL - r_val_local$axis_pivot = NULL - r_val_local$dgo_pivot = NULL - } - }) - - # create pivoted df for axis each time it changes - observeEvent(c(r_val$dgo_axis, r_val$tab_open1), { - if (!is.null(r_val$dgo_axis) && (r_val$tab_open1 == "Aperçu métriques")) { - - r_val_local$axis_pivot <- fct_table_pivot_sf(r_val$dgo_axis) %>% - dplyr::rename(mean_axis = mean, distr_axis = distr) - - # set dgo_pivot to NULL - r_val_local$dgo_pivot = NULL - } - }) - - # create pivoted df for dgo each time it changes - observeEvent(c(r_val$data_dgo_clicked, r_val$tab_open1), { - if (!is.null(r_val$data_dgo_clicked) && (r_val$tab_open1 == "Aperçu métriques")) { - # dgo data - r_val_local$dgo_pivot <- r_val$data_dgo_clicked %>% - sf::st_drop_geometry() %>% - dplyr::select(-c(fid, axis, measure, toponyme, strahler, gid_region)) %>% - tidyr::pivot_longer(-c(), names_to = "metric_name", values_to = "segment") %>% - dplyr::mutate(segment = round(segment, 2)) - } - }) - - # check for changes in unit, or regional and axis network or selected dgo to create the df as basis for table - observeEvent(c(r_val_local$region_pivot, r_val_local$axis_pivot, r_val_local$dgo_pivot), { - - if (!is.null(r_val_local$region_pivot)) { - # create data for table - r_val_local$data_df <- fct_table_create_table_df(region_pivot = r_val_local$region_pivot, - axis_pivot = r_val_local$axis_pivot, - dgo_pivot = r_val_local$dgo_pivot) - } - }) - - # create new table each time when df changed - observeEvent(c(r_val_local$data_df, input$select_unit),{ - - if (!is.null(r_val_local$data_df) & !is.null(input$select_unit)){ - # check which surface unit should be used for metrics - if (input$select_unit == "surface relative (%)") { - r_val_local$characteristics_table <- fct_table_create_reactable(r_val_local$data_df, "%") - } else { - r_val_local$characteristics_table <- fct_table_create_reactable(r_val_local$data_df, "ha") - } - } - - }) - }) -} diff --git a/R_old/mod_profil_long.R b/R_old/mod_profil_long.R deleted file mode 100644 index 2354642..0000000 --- a/R_old/mod_profil_long.R +++ /dev/null @@ -1,424 +0,0 @@ - - -# UI ---------------------------------------------------------------------- - -#' profil_long UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_profil_long_ui <- function(id){ - ns <- NS(id) - tagList( - useShinyjs(), - div( - fluidRow( - style = "margin-top: 10px;", - column(width = 10, - plotlyOutput(ns("long_profile")) - ), - column( - width = 2, - style = "margin-top: 20px;", - uiOutput(ns("profile_first_metricUI")), - uiOutput(ns("add_sec_axeUI"), - style = "margin-top: 30px;"), - uiOutput(ns("profile_sec_metricUI"), - style = "margin-left : 23px; margin-top: 10px"), - uiOutput(ns("profileroeUI")), - uiOutput(ns("profile_backgroundUI")) - ) - ) - ) - ) -} - - -# Server ------------------------------------------------------------------ - -#' profil_long Server Functions -#' -#' @importFrom dplyr filter pull -#' @importFrom plotly event_register plotlyOutput renderPlotly event_data -#' @importFrom leaflet addPolylines clearGroup -#' -#' @noRd -mod_profil_long_server <- function(id, r_val){ - moduleServer( id, function(input, output, session){ - ns <- session$ns - - ### INITIALIZATION #### - - #### REACTIVES #### - r_val_local <- reactiveValues( - plot = lg_profile_empty(), # plotly render longitudinal profile output (default empty) - leaflet_hover_shapes = NULL, # list to store vertical lines to display on longitudinal profile - ui_roe_profile = NULL, # UI placeholder for ROE checkbox - ui_background_profile = NULL, # UI placeholder for background classes checkbox - roe_vertical_line = NULL, # list with verticale line to plot on longitudinal profile - - # first metric - profile_first_metric = NULL, - - selected_profile_metric_title = NULL, # metric title to be displayed instead of pure variable name - selected_profile_metric_type = NULL, # metric type title - - # second metric - proxy_second_axe = NULL, - profile_sec_metric = NULL, # second metric selection - add_sec_axe = NULL, # add second axis - sec_metric_name = NULL, # title - sec_metric_type = NULL, # metric type title - - # plotly shapes - shapes_dgo = NULL, # list with shapes to plot clicked dgo element as line - shapes_roe = NULL, # list with shapes to plot ROE obstacles as lines - shapes_background = NULL, # list with shapes to plot classes in background - - ) - - #### OUTPUTS #### - output$long_profile <- renderPlotly({ - return(r_val_local$plot) - }) - - # selectinput for metric - output$profile_first_metricUI <- renderUI({ - if (!is.null(r_val_local$profile_first_metric)) { - div( - style = "display: flex; align-items: center", - r_val_local$profile_first_metric, - span( - style = "display: flex; margin-left: 10px; margin-top: 20px", - popover( - trigger = bsicons::bs_icon("info-circle"), - "", - placement = "right", - id = ns("popover_metric") - ) - ) - ) - } - }) - - # add selectinput for additional metric - output$profile_sec_metricUI <- renderUI({ - - if (!is.null(r_val_local$profile_sec_metric)) { - div( - style = "display: flex; align-items: center", - r_val_local$profile_sec_metric, - span( - style = "margin-left: 10px; margin-top: -10px", - popover( - trigger = bsicons::bs_icon("info-circle"), - "", - placement = "right", - id = ns("popover_metric2") - ) - ) - ) - } - }) - - # button to add second axe - output$add_sec_axeUI <- renderUI({ - r_val_local$add_sec_axe - }) - - # checkbox display ROE - output$profileroeUI <- renderUI({ - r_val_local$ui_roe_profile - }) - - # checkbox display background based on classification - output$profile_backgroundUI <- renderUI({ - r_val_local$ui_background_profile - }) - - - # make plot available to other - observe({ - r_val$plot_long_proxy <- plotlyProxy("long_profile") - }) - - #### axis select #### - - observeEvent(r_val$axis_clicked, { - - # track input - track_inputs(input = input) - - if (!is.null(r_val$dgo_axis) & (r_val$axis_clicked == TRUE)) { - - # build second axis input and add and remove buttons - r_val_local$profile_first_metric = selectInput(ns("profile_first_metric"), label = "Métrique :", - choices = params_get_metric_choices(), - selected = params_get_metric_choices()[1]) - } - }) - - #### build longitudinal profile plot #### - observeEvent(c(input$profile_first_metric, r_val$dgo_axis), { - - if (!is.null(input$profile_first_metric) & !is.null(r_val$dgo_axis)) { - r_val_local$plot <- - lg_profile_main( - data = r_val$dgo_axis, - y = r_val$dgo_axis[[input$profile_first_metric]], - y_label = metrics_params[metrics_params$metric_name == input$profile_first_metric,]$metric_title, - y_label_category = metrics_params[metrics_params$metric_name == input$profile_first_metric,]$metric_type_title - ) %>% - event_register("plotly_hover") - - # build second axis input and add and remove buttons - r_val_local$add_sec_axe = checkboxInput(ns("sec_axis"), - label = "Ajoutez 2éme métrique :", - value = FALSE) - r_val_local$profile_sec_metric = selectInput(ns("profile_sec_metric"), label = NULL, - choices = params_get_metric_choices(), - selected = params_get_metric_choices()[[2]][1], - width = "100%") - - # build ROE checkboxInput - r_val_local$ui_roe_profile = NULL # delete checkbox before creating new one - r_val_local$ui_roe_profile = checkboxInput(ns("roe_profile"), - label = "Obstacles à l'Ecoulement", - value = FALSE) - - # build background classification checkboxInput - r_val_local$ui_background_profile = NULL # delete checkbox before creating new one - r_val_local$ui_background_profile = checkboxInput(ns("background_profile"), - label = "Classifications en arrière-plan", - value = FALSE) - } else { - r_val_local$plot = lg_profile_empty() - } - }) - - - #### add or remove second axis #### - - observeEvent(c(input$sec_axis, input$profile_sec_metric), { - - # track input - track_inputs(input = input) - - # add second axis - if (input$sec_axis == TRUE) { - # get metric title and type - r_val_local$sec_metric_name = - metrics_params |> filter(metric_name == input$profile_sec_metric) |> pull(metric_title) - r_val_local$sec_metric_type = - metrics_params |> filter(metric_name == input$profile_sec_metric) |> pull(metric_type_title) - - # create the list to add trace and layout to change second axe plot - r_val_local$proxy_second_axe <- lg_profile_second(data = r_val$dgo_axis, - y = r_val$dgo_axis[[input$profile_sec_metric]], - y_label = r_val_local$sec_metric_name, - y_label_category = r_val_local$sec_metric_type) - # add second metric to plot - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("deleteTraces", 1) %>% - plotlyProxyInvoke("addTraces", r_val_local$proxy_second_axe$trace, 1) %>% - plotlyProxyInvoke("relayout", r_val_local$proxy_second_axe$layout) - } - # remove second axis - else { - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("deleteTraces", 1) - - r_val_local$proxy_second_axe = NULL - } - }) - - ### SHAPES Plotly #### - - #### clicked dgo #### - - observe({ - - if (!is.null(r_val$data_dgo_clicked)) { - # remove the previous element - r_val_local$shapes_dgo = NULL - - # get new shapes-element for longitudinal plot marker of clicked dgo for - r_val_local$shapes_dgo <- list(lg_vertical_line(r_val$data_dgo_clicked %>% pull(measure))) - } else if (is.null(r_val$data_dgo_clicked)) { - r_val_local$shapes_dgo = NULL - } - }) - - #### ROE #### - - observeEvent(input$roe_profile, { - - if (input$roe_profile == TRUE) { - # create the vertical line from ROE distance_axis - r_val_local$shapes_roe = lg_roe_vertical_line(r_val$roe_axis$distance_axis) - - } else { - # remove the previous ROE vertical lines if exist - r_val_local$shapes_roe = NULL - } - }) - - #### background classification #### - - observeEvent(c(input$background_profile, r_val$classes_proposed_selected, - r_val$manual_classes_table), { - - # track input - track_inputs(input = input) - - if (!is.null(input$background_profile) && !is.null(r_val$dgo_axis)) { - - # add background classification shapes - if (input$background_profile == TRUE) { - - # proposed classification applied - if (r_val$visualization == "classes") { - r_val$dgo_axis_classified = r_val$dgo_axis %>% - assign_classes_proposed(proposed_class = classes_proposed[r_val$classes_proposed_selected,]$class_name) - } - - # manual classification applied - else if (r_val$visualization == "manual" & - !is.null(r_val$manual_classes_table)) { - r_val$dgo_axis_classified <- r_val$dgo_axis %>% - na.omit() %>% - assign_classes_manual(classes = r_val$manual_classes_table) - } - - if (!is.null(r_val$dgo_axis_classified)) { - r_val_local$shapes_background = create_classes_background(r_val$dgo_axis_classified) - } - - } - # remove background classification - else if (input$background_profile == FALSE) { - r_val_local$shapes_background = NULL - } - } - }) - - #### COMBINE shapes #### - - # reactive that listens to all changes in shapes and returns a combined list of them - combined_shapes <- reactive({ - - # create always new an empty list to store only shapes which are really activated - shapes_list <- list() - - if (!is.null(r_val_local$shapes_dgo)) { - shapes_list <- c(shapes_list, r_val_local$shapes_dgo) - } - - if (!is.null(r_val_local$shapes_roe)) { - shapes_list <- c(shapes_list, r_val_local$shapes_roe) - } - - if (!is.null(r_val_local$shapes_background)) { - shapes_list <- c(shapes_list, r_val_local$shapes_background) - } - - if (!is.null(r_val_local$leaflet_hover_shapes)) { - shapes_list <- c(shapes_list, r_val_local$leaflet_hover_shapes) - } - - shapes_list - - }) - - # observe the combined shapes and update the plotly plot - observe({ - - if (!is.null(combined_shapes())) { - - shapes <- combined_shapes() - - # update profile with changed shapes - plotlyProxy("long_profile") %>% - plotlyProxyInvoke("relayout", list(shapes = shapes)) - } - }) - - - ### METRIC INFO #### - - # update infobutton when metric selected changes for the first and second metric - observe({ - if (!is.null(input$profile_first_metric)) { - update_popover("popover_metric", - HTML(metrics_params %>% - filter(metric_name == input$profile_first_metric) %>% - pull(metric_description))) - } - }) - - observe({ - if (!is.null(input$profile_sec_metric)) { - update_popover("popover_metric2", - HTML(metrics_params %>% - filter(metric_name == input$profile_sec_metric) %>% - pull(metric_description))) - } - }) - - - ### HOVER EVENTS #### - - #### plotly profile #### - - # capture hover events on profile-plot to display dgo on map - observeEvent(event_data("plotly_hover", source = 'L'), { - - if(!is.null(r_val_local$plot)) { - # event data - hover_event <- event_data("plotly_hover", source = 'L') - - # add line to map and plot - if (!is.null(hover_event)) { - hover_fid <- hover_event$key[1] - highlighted_feature <- r_val$dgo_axis[r_val$dgo_axis$fid == hover_fid, ] - r_val$map_proxy %>% - addPolylines(data = highlighted_feature, color = "red", weight = 10, - group = params_map_group()$light) - } - } - - }) - - # clear previous point on map when moving along profile to not display all the point move over - observe({ - if (!is.null(r_val_local$plot)) { - if (is.null(event_data("plotly_hover", source = 'L'))) { - r_val$map_proxy %>% - clearGroup(params_map_group()$light) - } - } - }) - - - #### leaflet map dgo mouseover #### - - observe({ - - if (!is.null(r_val$leaflet_hover_measure)) { - if (!is.null(r_val_local$plot)) { - # remove the first element (hover dgo vertical line) - r_val_local$leaflet_hover_shapes = NULL - # add the new hover dgo vertical line - r_val_local$leaflet_hover_shapes = list(lg_vertical_line(r_val$leaflet_hover_measure, color = "red")) - } - } else if (is.null(r_val$leaflet_hover_measure)) { - r_val_local$leaflet_hover_shapes = NULL - } - - }) - }) -} diff --git a/R_old/mod_profil_transverse.R b/R_old/mod_profil_transverse.R deleted file mode 100644 index 9d8490d..0000000 --- a/R_old/mod_profil_transverse.R +++ /dev/null @@ -1,55 +0,0 @@ -#' profil_transverse UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_profil_transverse_ui <- function(id){ - ns <- NS(id) - tagList( - fluidRow( - style = "margin-top: 10px;", - column(width = 12, - plotlyOutput(ns("cross_section")) - ) - ) - ) -} - -#' profil_transverse Server Functions -#' -#' @noRd -mod_profil_transverse_server <- function(id, r_val){ - moduleServer( id, function(input, output, session){ - ns <- session$ns - - r_val_locals <- reactiveValues( - section = cr_profile_empty() # plotly render cross section output (default empty) - ) - - # output - output$cross_section <- renderPlotly({ - return(r_val_locals$section) - }) - - # plot cross section when dgo clicked - observe({ - - if (!is.null(r_val$data_section)) { - r_val_locals$section = cr_profile_main(data = r_val$data_section, - axis_toponyme = unique(r_val$selected_axis_df$toponyme)) - } else if (is.null(r_val$data_section)){ - r_val_locals$section = cr_profile_empty() - } - }) - }) -} - -## To be copied in the UI -# mod_profil_transverse_ui("profil_transverse_1") - -## To be copied in the server -# mod_profil_transverse_server("profil_transverse_1") diff --git a/R_old/run_app.R b/R_old/run_app.R deleted file mode 100644 index 5d60ac1..0000000 --- a/R_old/run_app.R +++ /dev/null @@ -1,28 +0,0 @@ -#' Run the Shiny Application -#' -#' @param ... arguments to pass to golem_opts. -#' See `?golem::get_golem_options` for more details. -#' @inheritParams shiny::shinyApp -#' -#' @export -#' @importFrom shiny shinyApp -#' @importFrom golem with_golem_options -run_app <- function( - onStart = NULL, - options = list(), - enableBookmarking = NULL, - uiPattern = "/", - ... -) { - with_golem_options( - app = shinyApp( - ui = app_ui, - server = app_server, - onStart = onStart, - options = options, - enableBookmarking = enableBookmarking, - uiPattern = uiPattern - ), - golem_opts = list(...) - ) -} diff --git a/R_old/utils-pipe.R b/R_old/utils-pipe.R deleted file mode 100644 index fd0b1d1..0000000 --- a/R_old/utils-pipe.R +++ /dev/null @@ -1,14 +0,0 @@ -#' Pipe operator -#' -#' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. -#' -#' @name %>% -#' @rdname pipe -#' @keywords internal -#' @export -#' @importFrom magrittr %>% -#' @usage lhs \%>\% rhs -#' @param lhs A value or the magrittr placeholder. -#' @param rhs A function call using the magrittr semantics. -#' @return The result of calling `rhs(lhs)`. -NULL