Merge pull request #25 from EVS-GIS/roe_profile_v2

Roe profile v2

NAMESPACE

@@ -14,11 +14,16 @@ export(data_get_regions_in_bassin)
 export(data_get_roe_in_region)
 export(data_get_station_hubeau)
 export(db_con)
+export(lg_add_trace)
+export(lg_annotations_layout)
 export(lg_profile_empty)
 export(lg_profile_main)
 export(lg_profile_second)
 export(lg_profile_update_main)
+export(lg_roe_vertical_line)
 export(lg_vertical_line)
+export(lg_xaxis_layout)
+export(lg_yaxis_layout)
 export(map_add_basemaps)
 export(map_add_regions_in_bassin)
 export(map_add_wms_overlayers)
@@ -56,6 +61,7 @@ importFrom(dplyr,arrange)
 importFrom(dplyr,filter)
 importFrom(dplyr,if_else)
 importFrom(dplyr,mutate)
+importFrom(dplyr,pull)
 importFrom(glue,glue)
 importFrom(golem,activate_js)
 importFrom(golem,add_resource_path)

R/fct_data.R

@@ -153,7 +153,7 @@ data_get_min_max_metric <- function(selected_region_id, selected_metric) {
 data_get_roe_in_region <- function(selected_region_id) {
   query <- glue::glue("
       SELECT
-      roe.gid, nomprincip, lbtypeouvr, lbhautchut, gid_region, roe.geom
+      roe.gid, axis, distance_axis, nomprincip, lbtypeouvr, lbhautchut, gid_region, roe.geom
       FROM roe
       WHERE gid_region = {selected_region_id}
           AND (roe.cdetouvrag LIKE '2')

R/fct_lg_profile.R

@@ -16,12 +16,19 @@
 lg_profile_empty <- function() {
   temp <- data.frame()
   plot <- plot_ly(data = temp, source = "plot_pg") %>%
-    layout(title = list(
-      text = "Sélectionnez un cours d'eau sur la carte et une métrique pour afficher le graphique",
-      y = 0.80,  # y title position
-      x = 0.3,   # x title position
-      font = list(size = 15)
-    ))
+    layout(
+      title = list(
+        text = "Sélectionnez un cours d'eau sur la carte et une métrique pour afficher le graphique",
+        y = 0.80,  # y title position
+        x = 0.3,   # x title position
+        font = list(size = 15)
+      ),
+      xaxis = list(
+        zeroline = FALSE
+      ),
+      yaxis = list(
+        zeroline = FALSE
+      ))
   return(plot)
 }
 
@@ -54,16 +61,105 @@ lg_vertical_line <- function(x = 0, color = "green") {
   )
 }
 
+#' Create the ROE vertical lines for plotly shapes
+#'
+#' @param roe_distance_axis vector ROE distance on axis.
+#'
+#' @return list of each vertical lines
+#' @export
+lg_roe_vertical_line <- function(roe_distance_axis){
+  shapes_list <- lapply(roe_distance_axis, function(x) {
+    lg_vertical_line(x = x/1000, color = "#323232")
+  })
+  return (shapes_list)
+}
+
+#' plotly xaxis layout.
+#'
+#' @param data data.frame dgo from axis.
+#'
+#' @return list
+#' @export
+lg_xaxis_layout <- function(data){
+  xaxis <- list(
+    title = 'Distance depuis l\'exutoire (km)',
+    range = c(0, max(data$measure)),
+    zeroline = FALSE)
+  return(xaxis)
+}
+
+#' plotly yaxis layout.
+#'
+#' @param y_label text name of the metric plotted.
+#' @param y_label_category text metric category name.
+#'
+#' @return list
+#' @export
+lg_yaxis_layout <- function(y_label_category, y_label){
+  yaxis <- list(
+    title = paste0(y_label_category, " - ", y_label),
+    side = 'left',
+    zeroline = FALSE
+  )
+  return(yaxis)
+}
+
+#' plotly annotations layout.
+#'
+#' @param data data.frame dgo from axis.
+#'
+#' @return list
+#' @export
+lg_annotations_layout <- function(data){
+  annotations = list(
+    text = unique(data$toponyme),
+    x = 1,  # x-coordinate (0 to 1, where 0 is left and 1 is right)
+    y = -0.18,  # y-coordinate (0 to 1, where 0 is bottom and 1 is top)
+    xref = "paper",  # "paper" to specify coordinates relative to the entire plot
+    yref = "paper",
+    showarrow = FALSE,  # Don't show the arrow
+    font = list(
+      # family = "Open Sans",
+      size = 14,
+      # color = "black"
+      weight = "bold"
+    )
+  )
+  return(annotations)
+}
+
+#' plotly add trace.
+#'
+#' @param data data frame containing the selected axis data.
+#' @param y text metric to be plotted on the y-axis.
+#' @param y_label text name of the metric plotted.
+#' @param yaxis text axis id.
+#'
+#' @return list
+#' @export
+lg_add_trace <- function(data, y, y_label, yaxis = 'y1'){
+  trace <- list(
+    x = data$measure,
+    y = y,
+    key = data$fid,  # the "id" column for hover text
+    type = 'scatter',
+    mode = 'lines',
+    name = y_label,
+    yaxis = yaxis
+  )
+  return(trace)
+}
+
 #' Create a longitudinal profile plot for selected axis data
 #'
 #' This function generates a longitudinal profile plot using the 'plot_ly'
 #' function from the 'plotly' package. It allows you to visualize a specific
 #' metric along the selected axis.
 #'
-#' @param data A data frame containing the selected axis data.
-#' @param y The metric to be plotted on the y-axis.
-#' @param y_label The name of the metric plotted.
-#' @param y_label_category The metric category name.
+#' @param data data frame containing the selected axis data.
+#' @param y text metric to be plotted on the y-axis.
+#' @param y_label text name of the metric plotted.
+#' @param y_label_category text metric category name.
 #'
 #' @return A longitudinal profile plot with the specified metric.
 #'
@@ -84,26 +180,10 @@ lg_profile_main <- function(data, y, y_label, y_label_category) {
                   key = data$fid,  # the "id" column for hover text
                   type = 'scatter', mode = 'lines', name = y_label) %>%
     layout(
-      xaxis = list(title = 'Distance depuis l\'exutoire (km)'),
-      yaxis = list(
-        title = paste0(y_label_category, " - ", y_label),
-        side = 'left'
-      ),
+      xaxis = lg_xaxis_layout(data),
+      yaxis = lg_yaxis_layout(y_label_category, y_label),
       # river name
-      annotations = list(
-        text = unique(data$toponyme),
-        x = 1,  # x-coordinate (0 to 1, where 0 is left and 1 is right)
-        y = -0.18,  # y-coordinate (0 to 1, where 0 is bottom and 1 is top)
-        xref = "paper",  # Use "paper" to specify coordinates relative to the entire plot
-        yref = "paper",
-        showarrow = FALSE,  # Don't show the arrow
-        font = list(
-          # family = "Open Sans",
-          size = 14,
-          # color = "black"
-          weight = "bold"
-        )
-      ),
+      annotations = lg_annotations_layout(data),
       showlegend=TRUE,
       legend = list(orientation = 'h'),
       hovermode = "x unified",
@@ -164,35 +244,14 @@ lg_profile_main <- function(data, y, y_label, y_label_category) {
 #'
 #' @export
 lg_profile_update_main <- function(data, y, y_label, y_label_category){
-  proxy_trace <- list(
-    x = data$measure,
-    y = y,
-    key = data$fid,  # the "id" column for hover text
-    type = 'scatter',
-    mode = 'lines',
-    name = y_label,
-    yaxis = 'y1'
-  )
+
+  proxy_trace <- lg_add_trace(data, y, y_label, yaxis = 'y1')
 
   proxy_layout <- list(
-    yaxis = list(
-      title = paste0(y_label_category, " - ", y_label),
-      side = 'left'
-    ),
+    xaxis = lg_xaxis_layout(data),
+    yaxis = lg_yaxis_layout(y_label_category, y_label),
     # put all the annotation options to replace the river name
-    annotations = list(list(
-      text = unique(data$toponyme),
-      x = 1,  # x-coordinate (0 to 1, where 0 is left and 1 is right)
-      y = -0.18,  # y-coordinate (0 to 1, where 0 is bottom and 1 is top)
-      xref = "paper",  # Use "paper" to specify coordinates relative to the entire plot
-      yref = "paper",
-      showarrow = FALSE,  # Don't show the arrow
-      font = list(
-        size = 14,
-        weight = "bold"
-      )
-    )
-    )
+    annotations = lg_annotations_layout(data)
   )
   proxy <- list("trace" = proxy_trace,
                 "layout" = proxy_layout)
@@ -219,15 +278,8 @@ lg_profile_update_main <- function(data, y, y_label, y_label_category){
 #'
 #' @export
 lg_profile_second <- function(data, y, y_label, y_label_category){
-  proxy_trace <- list(
-    x = data$measure,
-    y = y,
-    key = data$fid,  # the "id" column for hover text
-    type = 'scatter',
-    mode = 'lines',
-    name = y_label,
-    yaxis = 'y2'
-  )
+
+  proxy_trace <- lg_add_trace(data, y, y_label, yaxis = 'y2')
 
   proxy_layout <- list(
     yaxis2 = list(

R/fct_map.R

@@ -145,6 +145,8 @@ map_add_regions_in_bassin <- function(map, bassins_data,
 #' @param region_click A vector containing information about the clicked region.
 #' @param selected_region_feature A sf data frame containing information about the selected region feature.
 #' @param regions_data A sf data.frame with the hydrographic regions of the bassin selected.
+#' @param roe_region sf data.frame ROE in selected region.
+#' @param hydro_station_region sf data.frame Hubeau hydrometric stations in selected region.
 #'
 #' @return An updated Leaflet map with relevant layers and information displayed.
 #'
@@ -182,18 +184,27 @@ map_add_regions_in_bassin <- function(map, bassins_data,
 #'          "lat" = Y)
 #' centre_region_coord$id <- 11
 #'
+#' # get ROE in region
+#' roe_region <- data_get_roe_in_region(centre_region_coord$id)
+#' # get hydro stations in region
+#' hydro_station_region <- data_get_station_hubeau(centre_region_coord$id)
+#'
 #' # map the element in the region clicked
 #' map <- map_region_clicked(map = map_region,
 #'                           region_click = centre_region_coord,
 #'                           selected_region_feature = selected_region,
-#'                           regions_data = region_hydrographique)
+#'                           regions_data = region_hydrographique,
+#'                           roe_region = roe_region,
+#'                           hydro_station_region = hydro_station_region)
 #' map
 #'
 #' @export
 map_region_clicked <- function(map,
                                region_click,
                                selected_region_feature,
-                               regions_data) {
+                               regions_data,
+                               roe_region,
+                               hydro_station_region) {
   map %>%
     setView(lng = region_click$lng , lat = region_click$lat, zoom = 7.5) %>%
     clearGroup(c(params_map_group()[["region"]],
@@ -215,7 +226,7 @@ map_region_clicked <- function(map,
                 group = params_map_group()[["region"]]
     ) %>%
     # add ROE overlayers from PostgreSQL
-    addCircleMarkers(data = data_get_roe_in_region(region_click$id),
+    addCircleMarkers(data = roe_region,
                      radius = 3,
                      weight = 0.5,
                      opacity = 0.9,
@@ -227,7 +238,7 @@ map_region_clicked <- function(map,
     ) %>%
     # hydrometric stations layer hidden by default
     hideGroup(params_map_group()[["roe"]]) %>%
-    addCircleMarkers(data = data_get_station_hubeau(region_click$id),
+    addCircleMarkers(data = hydro_station_region,
                      radius = 3,
                      weight = 0.5,
                      opacity = 0.9,
@@ -368,11 +379,18 @@ map_axis <- function(map, data_axis) {
 #'          "lat" = Y)
 #' centre_region_coord$id <- 11
 #'
+#' # get ROE in region
+#' roe_region <- data_get_roe_in_region(centre_region_coord$id)
+#' # get hydro stations in region
+#' hydro_station_region <- data_get_station_hubeau(centre_region_coord$id)
+#'
 #' # map the element in the region clicked
 #' map <- map_region_clicked(map = map_region,
 #'                           region_click = centre_region_coord,
 #'                           selected_region_feature = selected_region,
-#'                           regions = region_hydrographique)
+#'                           regions_data = region_hydrographique,
+#'                           roe_region = roe_region,
+#'                           hydro_station_region = hydro_station_region)
 #' map
 #'
 #' # build geoserver WMS filter