inst/doc/data_extraction_naiades.R

In hubeau: Get Data from the French National Database on Water 'Hub'Eau'

## ----setup, include=FALSE-----------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.width = 8,
  fig.asp = 0.618,
  out.width = "90%",
  fig.align = "center",
  warning = FALSE,
  message = FALSE
)
load(system.file("vignettes/data_extraction_naiades.RData", package = "hubeau"))

## -----------------------------------------------------------------------------
library(hubeau)
library(dplyr)
library(lubridate)
library(ggplot2)
library(Hmisc)

## -----------------------------------------------------------------------------
list_apis()

## -----------------------------------------------------------------------------
list_endpoints(api = "qualite_rivieres")

## -----------------------------------------------------------------------------
list_params(api = "qualite_rivieres", endpoint = "condition_environnementale_pc")

## -----------------------------------------------------------------------------
list_params(api = "qualite_rivieres", endpoint = "station_pc")

## ----eval = FALSE-------------------------------------------------------------
# station_21 <- get_qualite_rivieres_station(code_departement = "21")

## -----------------------------------------------------------------------------
station_21

## -----------------------------------------------------------------------------
list_params(api = "qualite_rivieres", endpoint = "analyse_pc")

## ----eval = FALSE-------------------------------------------------------------
# nitrates_21_raw <- get_qualite_rivieres_analyse(code_departement = "21",
#                                             date_debut_prelevement = "2000-01-01",
#                                             date_fin_prelevement = "2000-12-31",
#                                             code_parametre = "1340")

## -----------------------------------------------------------------------------
dim(nitrates_21_raw)
nitrates_21_raw

## ----eval = FALSE-------------------------------------------------------------
# nitrates_21 <- get_qualite_rivieres_analyse(
#   code_departement = "21",
#   date_debut_prelevement = "2000-01-01",
#   date_fin_prelevement = "2022-12-31",
#   code_parametre = "1340",
#   fields = c(
#     "code_station",
#     "libelle_station",
#     "libelle_fraction",
#     "date_prelevement",
#     "resultat",
#     "symbole_unite"
#   )
# )

## -----------------------------------------------------------------------------
dim(nitrates_21)
nitrates_21

## ----eval = FALSE-------------------------------------------------------------
# #list of station to query
# station_21 <- get_qualite_rivieres_station(code_departement = "21")

## -----------------------------------------------------------------------------
nrow(station_21)

## ----eval = FALSE-------------------------------------------------------------
# nitrates_21 <- get_qualite_rivieres_analyse(
#   code_departement = "21",
#   date_debut_prelevement = "2000-01-01",
#   date_fin_prelevement = "2022-12-31",
#   code_parametre = "1340",
#   fields = c(
#     "code_station",
#     "libelle_station",
#     "libelle_fraction",
#     "date_prelevement",
#     "resultat",
#     "symbole_unite"
#   )
# )

## -----------------------------------------------------------------------------
nitrates_21 <- nitrates_21 %>% 
  mutate(date_prelevement = as.POSIXct(date_prelevement),
         year = year(date_prelevement))

station_stats <- nitrates_21 %>%
  group_by(code_station, libelle_station, year) %>%
  summarise(nb_analyses = n(), 
            nitrate_mean = mean(resultat),
            nitrate_p90 = quantile(resultat, probs = 0.9), 
            .groups = 'drop')
station_stats

## -----------------------------------------------------------------------------
valid_stations <- station_stats %>%
  group_by(code_station, libelle_station) %>%
  summarise(analyses_per_year = mean(nb_analyses), nb_years = n()) %>%
  filter(analyses_per_year >= 10, nb_years >= 10)

valid_stations

## -----------------------------------------------------------------------------
plot_nitrates <- function(code) {
  
  station_details <- station_21[station_21$code_station == code, , drop = FALSE]
  mean_samples <- valid_stations$analyses_per_year[valid_stations$code_station == code]
  nitrates_station <- nitrates_21 %>% filter(code_station == code)
  station_yearly_stats <- station_stats %>% filter(code_station == code)
  
  p  <-  ggplot(nitrates_station, aes(x = as.factor(year), y = resultat)) +
    labs(
      x = "year",
      y = "nitrates (mg/l)",
      title = paste(
        "station:",
        station_details$code_station,
        station_details$libelle_station
      ),
      subtitle = paste(round(mean_samples, 1), "samples per year on average"),
      caption = "mean and sd in blue, median + 1rst and 3rd quartile represented by dashed lines,  percentile 90 in red"
    ) +
    scale_x_discrete(labels = paste0(station_yearly_stats$year, "\nn=", station_yearly_stats$nb_analyses))
  p  <-
    p +
    geom_violin(
      trim = TRUE,
      scale = "width",
      adjust = 0.5,
      draw_quantiles = 0.9,
      color = "red",
      fill = "lightblue1"
    ) + # draw the violin and adds an horizontal red line corresponding to the quantile 90
    
    geom_violin(
      trim = TRUE,
      scale = "width",
      adjust = 0.5,
      color = "black",
      fill = "transparent"
    ) + # draw the same violin but with black lines and no fill
    
    geom_violin(
      trim = TRUE,
      scale = "width",
      adjust = 0.5,
      draw_quantiles = c(0.25, 0.5, 0.75),
      linetype = "dashed",
      fill = "transparent"
    ) + # adds the median, the 1st and 3rd quartiles in dashed line
    stat_summary(
      fun.data = mean_sdl,
      fun.args = list(mult = 1),
      geom = "pointrange",
      color = "blue4",
      fill = "transparent"
    )  # adds the mean and the standard deviation in blue
}

## ----message = FALSE, results='hide', fig.keep='all'--------------------------
lapply(valid_stations$code_station, plot_nitrates)